Delphi公共函数 (三)

Delphi公共函数 (三)

{=================================================================

  功  能: 列举工作组中所有的计算机

  参  数:

          List: 需要填充的List

  返回值: 成功:  True,并填充List 失败: False;

  备  注:

  版  本:

     1.0  2002/10/03 08:00:00

=================================================================}

Function TPub.NetGetUsers(GroupName: string; var List: TStringList): Boolean;

type

  TNetResourceArray = ^TNetResource;//网络类型的数组

Var

  i: Integer;

  Buf: Pointer;

  Temp: TNetResourceArray;

  lphEnum: THandle;

  NetResource: TNetResource;

  Count,BufSize,Res: DWord;

begin

  Result := False;

  List.Clear;

  FillChar(NetResource, SizeOf(NetResource), 0);//初始化网络层次信息

  NetResource.lpRemoteName := @GroupName[1];//指定工作组名称

  NetResource.dwDisplayType := RESOURCEDISPLAYTYPE_SERVER;//类型为服务器（工作组）

  NetResource.dwUsage := RESOURCEUSAGE_CONTAINER;

  NetResource.dwScope := RESOURCETYPE_DISK;//列举文件资源信息

  //获取指定工作组的网络资源句柄

  Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

                        RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

  if Res <> NO_ERROR then Exit; //执行失败

  while True do//列举指定工作组的网络资源

  begin

    Count := $FFFFFFFF;//不限资源数目

    BufSize := 8192;//缓冲区大小设置为8K

    GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

    //获取计算机名称

    Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);

    if Res = ERROR_NO_MORE_ITEMS then break;//资源列举完毕

    if (Res <> NO_ERROR) then Exit;//执行失败

    Temp := TNetResourceArray(Buf);

    for i := 0 to Count - 1 do//列举工作组的计算机名称

    begin

      //获取工作组的计算机名称，+2表示删除"//"，如//wangfajun=>wangfajun

      List.Add(Temp^.lpRemoteName + 2);

      inc(Temp);

    end;

  end;

  Res := WNetCloseEnum(lphEnum);//关闭一次列举

  if Res <> NO_ERROR then exit;//执行失败

  Result := True;

  FreeMem(Buf);

end;

 

{=================================================================

  功  能: 列举所有网络类型

  参  数:

          List: 需要填充的List

  返回值: 成功:  True,并填充List 失败: False;

  备 注:

  版 本:

     1.0  2002/10/03 08:54:00

=================================================================}

Function TPub.NetGetNetList(var List: Tstringlist): Boolean;

type

  TNetResourceArray = ^TNetResource;//网络类型的数组

Var

  p: TNetResourceArray;

  Buf: Pointer;

  i: SmallInt;

  lphEnum: THandle;

  NetResource: TNetResource;

  Count,BufSize,Res: DWORD;

begin

  Result := False;

  List.Clear;

  Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

                      RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

  if Res <> NO_ERROR then exit;//执行失败

  Count := $FFFFFFFF;//不限资源数目

  BufSize := 8192;//缓冲区大小设置为8K

  GetMem(Buf, BufSize);//申请内存，用于获取工作组信息

  Res := WNetEnumResource(lphEnum, Count, Pointer(Buf), BufSize);//获取网络类型信息

      //资源列举完毕                    //执行失败

  if ( Res = ERROR_NO_MORE_ITEMS ) or (Res <> NO_ERROR ) then Exit;

  P := TNetResourceArray(Buf);

  for i := 0 to Count - 1 do//记录各个网络类型的信息

  begin

    List.Add(p^.lpRemoteName);

    Inc(P);

  end;

  Res := WNetCloseEnum(lphEnum);   //关闭一次列举

  if Res <> NO_ERROR then exit;   //执行失败

  Result := True;

  FreeMem(Buf);  //释放内存

end;

{=================================================================

  功  能: 映射网络驱动器

  参  数:

          NetPath: 想要映射的网络路径

          Password: 访问密码

          Localpath 本地路径

  返回值: 成功:  True  失败: False;

  备 注:

  版 本:

     1.0  2002/10/03 09:24:00

=================================================================}

Function TPub.NetAddConnection(NetPath: Pchar; PassWord: Pchar

                          ;LocalPath: Pchar): Boolean;

var

  Res: Dword;

begin

  Result := False;

  Res := WNetAddConnection(NetPath,Password,LocalPath);

  if Res <> No_Error then exit;

  Result := True;

end;

 

{=================================================================

  功  能:  检测网络状态

  参  数:

          IpAddr: 被测试网络上主机的IP地址或名称，建议使用Ip

  返回值: 成功:  True  失败: False;

  备 注:

  版 本:

     1.0  2002/10/03 09:40:00

=================================================================}

 

 

 

 

Function TPub.NetCheckNet(IpAddr: string): Boolean;

type

  PIPOptionInformation = ^TIPOptionInformation;

  TIPOptionInformation = packed record

     TTL:         Byte;      // Time To Live (used for traceroute)

     TOS:         Byte;      // Type Of Service (usually 0)

     Flags:       Byte;      // IP header flags (usually 0)

     OptionsSize: Byte;      // Size of options data (usually 0, max 40)

     OptionsData: PChar;     // Options data buffer

  end;

 

  PIcmpEchoReply = ^TIcmpEchoReply;

  TIcmpEchoReply = packed record

     Address:       DWord;                // replying address

     Status:        DWord;                // IP status value (see below)

     RTT:           DWord;                // Round Trip Time in milliseconds

     DataSize:      Word;                 // reply data size

     Reserved:      Word;

     Data:          Pointer;              // pointer to reply data buffer

     Options:       TIPOptionInformation; // reply options

  end;

 

  TIcmpCreateFile = function: THandle; stdcall;

  TIcmpCloseHandle = function(IcmpHandle: THandle): Boolean; stdcall;

  TIcmpSendEcho = function(

     IcmpHandle:          THandle;

     DestinationAddress:  DWord;

     RequestData:         Pointer;

     RequestSize:         Word;

     RequestOptions:      PIPOptionInformation;

     ReplyBuffer:         Pointer;

     ReplySize:           DWord;

     Timeout:             DWord

  ): DWord; stdcall;

 

const

  Size = 32;

  TimeOut = 1000;

var

  wsadata: TWSAData;

  Address: DWord;                     // Address of host to contact

  HostName, HostIP: String;           // Name and dotted IP of host to contact

  Phe: PHostEnt;                      // HostEntry buffer for name lookup

  BufferSize, nPkts: Integer;

  pReqData, pData: Pointer;

  pIPE: PIcmpEchoReply;               // ICMP Echo reply buffer

  IPOpt: TIPOptionInformation;        // IP Options for packet to send

const

  IcmpDLL = 'icmp.dll';

var

  hICMPlib: HModule;

  IcmpCreateFile : TIcmpCreateFile;

  IcmpCloseHandle: TIcmpCloseHandle;

  IcmpSendEcho:    TIcmpSendEcho;

  hICMP: THandle;                     // Handle for the ICMP Calls

begin

  // initialise winsock

  Result:=True;

  if WSAStartup(2,wsadata) <> 0 then begin

     Result:=False;

     halt;

  end;

  // register the icmp.dll stuff

  hICMPlib := loadlibrary(icmpDLL);

  if hICMPlib <> null then begin

    @ICMPCreateFile := GetProcAddress(hICMPlib, 'IcmpCreateFile');

    @IcmpCloseHandle:= GetProcAddress(hICMPlib, 'IcmpCloseHandle');

    @IcmpSendEcho:= GetProcAddress(hICMPlib, 'IcmpSendEcho');

    if (@ICMPCreateFile = Nil) or (@IcmpCloseHandle = Nil) or (@IcmpSendEcho = Nil) then begin

        Result:=False;

        halt;

    end;

    hICMP := IcmpCreateFile;

    if hICMP = INVALID_HANDLE_VALUE then begin

      Result:=False;

      halt;

    end;

  end else begin

    Result:=False;

    halt;

  end;

// ------------------------------------------------------------

  Address := inet_addr(PChar(IpAddr));

  if (Address = INADDR_NONE) then begin

    Phe := GetHostByName(PChar(IpAddr));

    if Phe = Nil then Result:=False

    else begin

      Address := longint(plongint(Phe^.h_addr_list^)^);

      HostName := Phe^.h_name;

      HostIP := StrPas(inet_ntoa(TInAddr(Address)));

    end;

  end

  else begin

    Phe := GetHostByAddr(@Address, 4, PF_INET);

    if Phe = Nil then Result:=False;

  end;

 

  if Address = INADDR_NONE then

  begin

     Result:=False;

  end;

  // Get some data buffer space and put something in the packet to send

  BufferSize := SizeOf(TICMPEchoReply) + Size;

  GetMem(pReqData, Size);

  GetMem(pData, Size);

  GetMem(pIPE, BufferSize);

  FillChar(pReqData^, Size, $AA);

  pIPE^.Data := pData;

 

    // Finally Send the packet

  FillChar(IPOpt, SizeOf(IPOpt), 0);

  IPOpt.TTL := 64;

  NPkts := IcmpSendEcho(hICMP, Address, pReqData, Size,

                        @IPOpt, pIPE, BufferSize, TimeOut);

  if NPkts = 0 then Result:=False;

 

  // Free those buffers

  FreeMem(pIPE); FreeMem(pData); FreeMem(pReqData);

 

// --------------------------------------------------------------

  IcmpCloseHandle(hICMP);

  FreeLibrary(hICMPlib);

  // free winsock

  if WSACleanup <> 0 then Result:=False;

end;

 

 

 

 

 

{=================================================================

  功  能:  检测计算机是否上网

  参  数:  无

  返回值:  成功:  True  失败: False;

  备 注:   uses Wininet

  版 本:

     1.0  2002/10/07 13:33:00

=================================================================}

function TPub.NetInternetConnected: Boolean;

const

  // local system uses a modem to connect to the Internet.

  INTERNET_CONNECTION_MODEM      = 1;

  // local system uses a local area network to connect to the Internet.

  INTERNET_CONNECTION_LAN        = 2;

  // local system uses a proxy server to connect to the Internet.

  INTERNET_CONNECTION_PROXY      = 4;

  // local system's modem is busy with a non-Internet connection.

  INTERNET_CONNECTION_MODEM_BUSY = 8;

var

  dwConnectionTypes : DWORD;

begin

  dwConnectionTypes := INTERNET_CONNECTION_LAN+INTERNET_CONNECTION_MODEM

    +INTERNET_CONNECTION_PROXY;

  //Result := InternetGetConnectedState(@dwConnectionTypes, 1);

  Result := InternetGetConnectedState(@dwConnectionTypes, 0);

end;

 

{等待窗口起}

procedure TPub.ProcessTimer1Timer(Sender: TObject);

var

  aForm: TForm;

  pr: TFlatProgressBar;

  lb: TLabel;

  aStr: String;

begin

  aForm := TForm(TControl(Sender).Owner);

  TLabel(aForm.FindComponent('Label3')).Caption := TimeToStr(Now);

  lb := TLabel(aForm.FindComponent('Label2'));

  lb.Caption := aForm.Caption;

  aStr := lb.Caption;

  if length(aStr) > 50 then

    lb.Caption := Copy(aStr, 1, 20) + '...' + Copy(aStr, Length(aStr) - 30, 31);

  lb.Left := aForm.Width div 2 - lb.Width div 2;

  pr := TFlatProgressBar(aForm.FindComponent('FlatProgressBar1'));

  if pr = nil then exit;

  pr.StepIt;

  if pr.Position = 100 then

  pr.Position := 0;

end;

 

function TPub.FormCreateProcessFrm(MsgTitle: string): TForm;

var

  Panel1, Panel2: TPanel;

  Label1, Label2, Label3: TLabel;

  FlatProgressBar1: TFlatProgressBar;

  Timer1: TTimer;

begin

  Result := TForm.Create(Application);

  Result.Left := 192;

  Result.Top := 185;

  Result.BorderStyle := bsNone;

  Result.ClientHeight := 105;

  Result.ClientWidth := 392;

  Result.Color := $00D9FFD9;

  {$IFDEF delphi7}

  Result.Color := clMoneyGreen;

  {$ENDIF}

  Result.Font.Charset := GB2312_CHARSET;

  Result.Font.Color := clBlue;

  Result.Font.Height := -16;

  Result.Font.Name := '宋体';

  Result.Font.Style := [];

  Result.OldCreateOrder := False;

  Result.Position := poDesktopCenter;

  Result.PixelsPerInch := 96;

 

  {上面的控件}

  Panel1 := TPanel.Create(Result);

  Panel1.Align := alClient;

  Panel1.ParentColor := True;

  Panel1.TabOrder := 0;

  Panel1.Parent := Result;

  Panel1.Caption := '';

 

  Panel2 := TPanel.Create(Result);

  Panel2.Name := 'Panel2';

  Panel2.Align := alClient;

  Panel2.BevelOuter := bvLowered;

  Panel2.ParentColor := True;

  Panel2.TabOrder := 0;

  Panel2.Parent := Panel1;

  Panel2.Caption := '';

 

  Label2 := TLabel.Create(Result);

  Label2.Name := 'Label2';

  Label2.Alignment := taCenter;

  Label2.Left := 136;

  Label2.Top := 37;

  Label2.Width := 7;

  Label2.Height := 14;

  Label2.Font.Charset := GB2312_CHARSET;

  Label2.Font.Color := clOlive;

  Label2.Font.Height := -14;

  Label2.Font.Name := '宋体';

  Label2.Font.Style := [];

  Label2.ParentFont := False;

  Label2.Parent := Panel2;

  Label2.Caption := '';

 

  Label1 := TLabel.Create(Result);

  Label1.Name := 'Label1';

  Label1.Left := 104;

  Label1.Top := 15;

  Label1.Width := 152;

  Label1.Height := 16;

  Label1.Caption := MsgTitle;//'正在处理，请稍候...';

  Label1.Transparent := True;

  Label1.Parent := Panel2;

 

  FlatProgressBar1 := TFlatProgressBar.Create(Result);

  FlatProgressBar1.Parent := Panel2;

  FlatProgressBar1.Name := 'FlatProgressBar1';

  FlatProgressBar1.Left := 16;

  FlatProgressBar1.Top := 58;

  FlatProgressBar1.Width := 363;

  FlatProgressBar1.Height := 23;

  FlatProgressBar1.Color := 15532031;

  FlatProgressBar1.ColorElement := clPurple;

  FlatProgressBar1.ColorBorder := clGreen;

  FlatProgressBar1.ParentColor := False;

  FlatProgressBar1.Min := 0;

  FlatProgressBar1.Max := 100;

  FlatProgressBar1.Position := 5;

  FlatProgressBar1.Step := 5;

 

  Label3 := TLabel.Create(Result);

  Label3.Name := 'Label3';

  Label3.Left := 311;

  Label3.Top := 85;

  Label3.Width := 7;

  Label3.Height := 14;

  Label3.Font.Charset := GB2312_CHARSET;

  Label3.Font.Color := clRed;

  Label3.Font.Height := -14;

  Label3.Font.Name := '宋体';

  Label3.Font.Style := [];

  Label3.ParentFont := False;

  Label3.Parent := Panel2;

  Label3.Caption := '';

 

  Timer1 := TTimer.Create(Result);

  Timer1.Interval := 100;

  Timer1.OnTimer := ProcessTimer1Timer;

end;

{等待窗口止}

 

procedure TPub.ConFree(aCon: TWinControl);

var

  lp: integer;

begin

  for lp := aCon.ComponentCount - 1 Downto 0 do

    aCon.Components[lp].Free;

end;

 

function TPub.CheckMailAddress(Text: string): boolean;

var

  Index: integer;

  lp: integer;

begin

  Result := false;

  if ((length(trim(Text)) > 20) or (Pos('.', Text) < 4))

    or (Pos('.HTM', UpperCase(Text)) > 0) or (Pos('.HTML', UpperCase(Text)) > 0)

    or (Pos('.ASP', UpperCase(Text)) > 0) or (Pos('.JSP', UpperCase(Text)) > 0) then exit;

  for lp := 1 to length(Text) do

    if (Ord(Text[lp]) > $80) and (Text[lp] <> '@') then exit;

  if (Pos('.', Text) < Pos('@', Text) + 1) then exit;

  Index := Pos('@', Text);

  if (Index < 2) or (Index >= Length(Text))  then exit;

  Result := true;

end;

 

function TPub.PathExeDir(FileName: string): string;

begin

  Result := ExtractFilePath(ParamStr(0)) + FileName;

end;

 

initialization

  Pub := TPub.Create;

 

finalization

  Pub.Free;

 

end.