Constract IP Box without Component

Der Delphi-Compiler besitzt in seinen Grundkomponenten keine echte IP-Box. Es werden andere Komponenten genutzt, um eine IP einzugeben oder zu ermitteln. Der Nachteil dieser Boxen ist, dass die Falscheingabe des Users nicht zu vermeiden ist, da der Entwickler die Eingabe nicht kennt. Um dieses Problem zu verhindern, muss eine Box existieren, die nur die möglichen Werte einer IP-Zahl zulässt und sie auch als solche liest. Das lässt sich mit einem Constractor ermöglichen, um seine eigene IP-Box zu erschaffen.

Das folgende Beispiel zeigt, wie diese Boxen ohne Komponenten gebaut werden und als Range funktionieren. Das Programm ermittelt anhand des Ranges alle Netzwerk-User.

uses ComCtrls, CommCtrl, Winsock, ImgList

resourcestring
  RES_UNKNOWN = 'UNKNOWN';
  RES_THREADCOUNT = 'THREADCOUNT: %d';
  RES_COMPCOUNT = 'COMPCOUNT: %d';
  RES_ERR_RANGE = 'ERR_RANGE';

const
  WSA_TYPE = $101;

type
  LMSTR = LPWSTR;
  NET_API_STATUS = DWORD;

  PShareInfo1 = ^_SHARE_INFO_1;
  _SHARE_INFO_1 = record
   shi1_netname: LMSTR;
   shi1_type: DWORD;
   shi1_remark: LMSTR;
  end;
  TShareInfo1 = _SHARE_INFO_1;

  TIPEdit = class
  private
    FHandle: THandle;
    FIP: Integer;
    FFont: Integer;
    function GetText: String;
    procedure SetText(const Value: String);
  public
    constructor Create(AOwner: TWinControl; Rect: TRect);
    destructor Destroy; override;
    property Text: String read GetText write SetText;
  end;

  TScanThread = class(TThread)
  private
    FIP: Integer;
    FRes: TStringList;
    function GetCompName(const Addr: Integer): String;
    procedure Scan;
    procedure UpdateTree;
    procedure IncCount;
    procedure DecCount;
  protected
    procedure Execute; override;
  public
    property IP: Integer read FIP write FIP;
  end;
  
private
    { Private declarations }
    IPFrom, IPTo: TIPEdit;
    FThreadCount, FCompFound: Integer;
    procedure SetThreadCount(const Value: Integer);
    procedure SetCompFound(const Value: Integer);
  public
    { Public declarations }
    property ThreadCount: Integer read FThreadCount write SetThreadCount;
    property CompFound: Integer read FCompFound write SetCompFound;
  end;

  function NetShareEnum(servername: LMSTR; level: DWORD; var bufptr: Pointer;
   prefmaxlen: DWORD; entriesread, totalentries,
   resume_handle: LPDWORD): NET_API_STATUS; stdcall; external 'Netapi32.dll';
  function NetApiBufferFree(Buffer: Pointer): NET_API_STATUS; stdcall; external 'Netapi32.dll';
  
//

// Hier wird der Constractor erstellt
constructor TIPEdit.Create(AOwner: TWinControl; Rect: TRect);
begin
  InitCommonControl(ICC_INTERNET_CLASSES);
  FHandle:= CreateWindow(WC_IPADDRESS, nil, WS_CHILD or WS_VISIBLE,
            Rect.Left, Rect.Top, Rect.Right, Rect.Bottom,
            AOwner.Handle, 0, hInstance, nil);

  FFont := CreateFont(-11, 0, 0, 0, 400, 0, 0, 0, DEFAULT_CHARSET,
           OUT_DEFAULT_PRECIS, CLIP_DEFAULT_PRECIS, DEFAULT_QUALITY,
           DEFAULT_PITCH or FF_DONTCARE, 'MS Sans Serif');

  SendMessage(FHandle, WM_SETFONT, FFont, 0);
  Text := '0.0.0.0';
end;

// Hier wird der Constractor wieder entfernt
destructor TIPEdit.Destroy;
begin
  DeleteObject(FFont);
  inherited;
end;

// Ermitteln der IP Addressen
function TIPEdit.GetText: String;
begin
  SendMessage(FHandle, IPM_GETADDRESS, 0, Longint(PDWORD(@FIP)));
  Result := IntToStr(FIRST_IPADDRESS(FIP))+
      '.' + IntToStr(SECOND_IPADDRESS(FIP)) +
      '.' + IntToStr(THIRD_IPADDRESS(FIP)) +
      '.' + IntToStr(FOURTH_IPADDRESS(FIP));
end;

// Kopieren der Addressen in die Boxen
procedure TIPEdit.SetText(const Value: String);

  function MakeIPAddressEx(b1, b2, b3, b4: Char):LPARAM;
  begin
    Result := MAKEIPADDRESS(DWORD(b1), DWORD(b2), DWORD(b3), DWORD(b4));
  end;

var
  Tmp: TInAddr;
begin
  Tmp.S_addr := inet_addr(PChar(Value));
  if Tmp.S_addr = INADDR_NONE then Exit;
  with Tmp.S_un_b do
    FIP := MakeIPAddressEx(s_b1, s_b2, s_b3, s_b4);
  SendMessage(FHandle, IPM_SETADDRESS, 0, FIP);
end;

procedure TScanThread.DecCount;
begin
  Form1.ThreadCount := Form1.ThreadCount - 1;
end;

procedure TScanThread.Execute;
begin
  inherited;
  Synchronize(IncCount);
  Scan;
  Synchronize(DecCount);
end;

function TScanThread.GetCompName(const Addr: Integer): String;
var
  WSA: TWSAData;
  Host: PHostEnt;
  Err: Integer;
begin
  Result := RES_UNKNOWN;
  Err := WSAStartup(WSA_TYPE, WSA);
  if Err <> 0 then
  begin
    //ShowMessage(SysErrorMessage(GetLastError));
    Exit;
  end;
  try
    if Addr = INADDR_NONE then Exit;
    Host := gethostbyaddr(@Addr, SizeOf(Addr), PF_INET);
    if Assigned(Host) then
      Result := Host.h_name
    else
      //ShowMessage(SysErrorMessage(GetLastError));
  finally
    WSACleanup;
  end;
end;

procedure TScanThread.IncCount;
begin
  Form1.ThreadCount := Form1.ThreadCount + 1;
end;

procedure TScanThread.Scan;
type
  TShareInfo1Array = array of TShareInfo1;
var
  entriesread, totalentries: DWORD;
  Info: Pointer;
  I: Integer;
  CompName: PWideChar;
begin
  CompName := StringToOleStr(GetCompName(FIP));
  if CompName = RES_UNKNOWN then Exit;
  FRes := TStringList.Create;
  try
    Fres.Add(CompName);
    if NetShareEnum(CompName, 1, Info, DWORD(-1), @entriesread,
      @totalentries, nil) = 0 then
    try
     if entriesread > 0 then
     begin
       for I := 0 to entriesread - 1 do
         FRes.Add(TShareInfo1Array(@(Info^))[I].shi1_netname);
       Synchronize(UpdateTree);
     end;
    finally
     NetApiBufferFree(Info);
    end;
  finally
    FRes.Free;
  end;
end;

procedure TScanThread.UpdateTree;
var
  I: Integer;
  Root: TTreeNode;
begin
  Form1.TreeView1.Items.BeginUpdate;
  try
    Root := Form1.TreeView1.Items.Add(nil, FRes.Strings[0]);
    for I := 1 to FRes.Count - 1 do
      Form1.TreeView1.Items.AddChild(Root, FRes.Strings[I]);
    Form1.CompFound := Form1.CompFound + 1;
  finally
    Form1.TreeView1.Items.EndUpdate;
  end;    
end;

{ TMainForm }

procedure TForm1.Button1Click(Sender: TObject);
var
  I, AFrom, ATo: Integer;
  Prefix: String;

  function ValidRange: Boolean;
  var
    F, T: TInAddr;
  begin
    F.S_addr := inet_addr(PChar(IPFrom.Text));
    T.S_addr := inet_addr(PChar(IPTo.Text));
    Result := (F.S_un_b.s_b1 = T.S_un_b.s_b1) and
              (F.S_un_b.s_b2 = T.S_un_b.s_b2) and
              (F.S_un_b.s_b3 = T.S_un_b.s_b3);
    if Result then
    begin
      AFrom := Integer(F.S_un_b.s_b4);
      ATo := Integer(T.S_un_b.s_b4);
      Prefix := IntToStr(Integer(F.S_un_b.s_b1)) + '.' +
                IntToStr(Integer(F.S_un_b.s_b2)) + '.' +
                IntToStr(Integer(F.S_un_b.s_b3)) + '.';
      ProgressBar1.Max := ATo - AFrom;
      ProgressBar1.Position := 0;
    end
    else
      MessageDlg(RES_ERR_RANGE, mtError, [mbOK], 0);
  end;

begin
  CompFound := 0;
  ThreadCount := 0;
  TreeView1.Items.Clear;
  if ValidRange then
  begin
    Button1.Enabled := False;
    for I := AFrom to ATo do
      with TScanThread.Create(False) do
      begin
        IP := inet_addr(PChar(Prefix + IntToStr(I)));
        FreeOnTerminate := True;
        Resume;
      end;
  end;
end;

// Hier können Positionen und Größe der Boxen bestimmt werden
procedure TForm1.FormCreate(Sender: TObject);
begin
  IPFrom := TIPEdit.Create(gbAddrRange, Rect(Label1.Left+Label1.Width+8, 24, 160, 24));
  IPFrom.Text := '192.168.0.1';
  IPTo := TIPEdit.Create(gbAddrRange, Rect(Label2.Left+Label2.Width+8, 54, 160, 24));
  IPTo.Text := '192.168.0.254';
end;

// Finden der gebauten Boxen
procedure TForm1.SetCompFound(const Value: Integer);
begin
  FCompFound := Value;
  Status.Panels.Items[1].Text := Format(RES_COMPCOUNT, [Value]);
  Application.ProcessMessages;
end;

procedure TForm1.SetThreadCount(const Value: Integer);
begin
  if Value < FThreadCount then
    ProgressBar1.Position := ProgressBar1.Max - Value;
  FThreadCount := Value;
  Status.Panels.Items[0].Text := Format(RES_THREADCOUNT, [Value]);
  if Value = 0 then
  begin
    ProgressBar1.Position := 0;
    Button1.Enabled := True;
  end;
  Application.ProcessMessages;
end;