Delphi公共函数(二)

procedure TPub.ConSaveTreeViewToTextFile(Nodes: TTreeNodes; Filename: string);

var

  F: TextFile;

 

  procedure ProcessNode(Node: TTreeNode; Depth: Integer);

  begin

    while Node <> nil do

    begin

      Writeln(F, IntToStr(Depth) + ' ' + Node.Text);

 

      if Node.HasChildren then

        ProcessNode(Node.GetFirstChild, Depth + 1);

 

      Node := Node.getNextSibling;

    end;

  end;

 

begin

  Assignfile(F, Filename);

  rewrite(F);

 

  ProcessNode(Nodes.GetFirstNode, 1);

 

  CloseFile(F);

end;

 

//以下字符串

function TPub.StrGetToken(const S: string; index: Integer; bTrail: Boolean = False;

  Delimiters: TSysCharSet = DEFAULT_DELIMITERS): string;

var

  I, W, head, tail: Integer;

  bInWord         : Boolean;

begin

  I := 1;

  W := 0;

  bInWord := False;

  head := 1;

  tail := Length(S);

  while (I <= Length(S)) and (W <= index) do

  begin

    if S[I] in Delimiters then

    begin

      if (W = index) and bInWord then tail := I - 1;

      bInWord := False;

    end else

    begin

      if not bInWord then

      begin

        bInWord := True;

        Inc(W);

        if W = index then head := I;

      end;

    end;

 

    Inc(I);

  end;

 

  if bTrail then tail := Length(S);

  if W >= index then Result := Copy(S, head, tail - head + 1)

  else Result := '';

end;

 

function TPub.StrCountWords(S: string; Delimiters: TSysCharSet = DEFAULT_DELIMITERS): Integer;

var

  bInWord: Boolean;

  I      : Integer;

begin

  Result := 0;

  I := 1;

  bInWord := False;

  while I <= Length(S) do

  begin

    if S[I] in Delimiters then bInWord := False

    else

    begin

      if not bInWord then

      begin

        bInWord := True;

        Inc(Result);

      end;

    end;

 

    Inc(I);

  end;

end;

 

function TPub.StrIsContainingCRLF(const S: string): Boolean;

var

  len: Integer;

begin

  len := Length(S);

  Result := (len >= 2) and (S[len - 1] = #13) and (S[len] = #10);

end;

 

procedure TPub.StrTruncateCRLF(var S: string);

var

  I: Integer;

begin

  I := 1;

  while I <= Length(S) do

    if (S[I] = #13) or (S[I] = #10) then Delete(S, I, 1)

    else Inc(I);

end;

 

 

 

 

function TPub.StrReplaceString(var S: string; const Token, NewToken: string; bCaseSensitive: Boolean): Boolean;

var

  I         : Integer;

  sFirstPart: string;

begin

  if bCaseSensitive then

    I := AnsiPos(Token, S)

  else

    I := AnsiPos(AnsiUpperCase(Token), AnsiUpperCase(S));

 

  if I <> 0 then

  begin

    sFirstPart := Copy(S, 1, I - 1) + NewToken;

    S := Copy(S, I + Length(Token), Maxint);

  end;

 

  Result := I <> 0;

  if Result then

  begin

    StrReplaceString(S, Token, NewToken, bCaseSensitive);

    S := sFirstPart + S;

  end;

end;

 

procedure TPub.StrSimple_ReplaceString(var S: string; const Substr: string; index, Count: Integer);

begin

  S := Format('%s%s%s',[Copy(S, 1, index - 1), Substr, Copy(S, index + Count, Maxint)]);

end;

 

function TPub.StrCompositeStrings(SL: TStrings; const Delimiter: string): string;

var

  I: Integer;

begin

  Result := '';

 

  with SL do

  begin

    for I := 0 to Count - 2 do

      Result := Result + Strings[I] + Delimiter;

    if Count > 0 then

      Result := Result + Strings[Count - 1];

  end;

end;

 

function TPub.StrSafeLoadStrings(SL: TStrings; const Filename: string): Boolean;

begin

  Result := False;

  repeat

    try

      if not FileExists(Filename) then Exit;

      SL.LoadFromFile(Filename);

      Result := True;

      Break;

    except

      Sleep(500);

    end;

  until False;

end;

 

procedure TPub.StrSafeSaveStrings(SL: TStrings; const Filename: string);

begin

  ForceDirectories(ExtractFilePath(Filename));

  repeat

    try

      SL.SaveToFile(Filename);

      Break;

    except

      Sleep(500);

    end;

  until False;

end;

//以下字体

function TPub.FontToString(Font: TFont; bIncludeColor: Boolean): string;

var

  sStyle: string;

begin

  with Font do

  begin

    // convert font style to string

    sStyle := '';

   

    if (fsBold in Style) then

      sStyle := sStyle + csfsBold;

   

    if (fsItalic in Style) then

      sStyle := sStyle + csfsItalic;

   

    if (fsUnderline in Style) then

      sStyle := sStyle + csfsUnderline;

   

    if (fsStrikeOut in Style) then

      sStyle := sStyle + csfsStrikeout;

   

    if ((Length(sStyle) > 0) and ('|' = sStyle[1])) then

      sStyle := Copy(sStyle, 2, Length(sStyle) - 1);

   

    Result := Format('"%s", %d, [%s]',[name, Size, sStyle]);

    if bIncludeColor then

      Result := Result + Format(', [%s]',[ColorToString(Color)]);

  end;

end;

 

procedure TPub.StringToFont(sFont: string; Font: TFont;

  bIncludeColor: Boolean);

var

  P     : Integer;

  sStyle: string;                                  // Expected format:

begin                                              //   "Arial", 9, [Bold], [clRed]

  with Font do                                     //

    try

      // get font name

      P := Pos(',', sFont);

      name := Copy(sFont, 2, P - 3);

      Delete(sFont, 1, P);

 

      // get font size

      P := Pos(',', sFont);

      Size := StrToInt(Copy(sFont, 2, P - 2));

      Delete(sFont, 1, P);

 

      // get font style

      P := Pos(',', sFont);

      sStyle := '|' + Copy(sFont, 3, P - 4);

      Delete(sFont, 1, P);

 

      // get font color

      if bIncludeColor then

        Color := StringToColor(Copy(sFont, 3, Length(sFont) - 3));

 

      // convert str font style to

      // font style

      Style := [];

 

      if (Pos(csfsBold, sStyle) > 0) then

        Style := Style + [fsBold];

 

      if (Pos(csfsItalic, sStyle) > 0) then

        Style := Style + [fsItalic];

 

      if (Pos(csfsUnderline, sStyle) > 0) then

        Style := Style + [fsUnderline];

 

      if (Pos(csfsStrikeout, sStyle) > 0) then

        Style := Style + [fsStrikeOut];

    except

    end;

end;

 

procedure TPub.ConWriteText(aContr: TControl;sText: string);

var

  c:TCanvas;

begin

  c:=TControlCanvas.Create;

  TControlCanvas(c).Control := aContr;

  c.Font.Size := 12;// Brush.Style:=bsClear;

  c.Font.Color := clBlue;

  //c.Pen.Color:=clBlue;

  c.TextOut(1,1,sText);// Rectangle(5,5,15,15);

  c.Free;

end;

 

 

procedure TPub.FileCopyDirectory(sDir, tDir: string);

var

  aWaitForm: TForm;

  RetValue: integer;

  procedure MyCopy(aDir, sDir: string);

  var

    sr: TSearchRec;

  begin

    aDir := PathWithSlash(aDir);

    sDir := PathWithSlash(sDir);

    if FindFirst(aDir+'*.*', faAnyFile, sr) = 0 then

    begin

      repeat

        if sr.Attr and faDirectory = faDirectory then

        begin

          if not DirectoryExists(aDir + sr.Name) then exit;

          if (sr.Name <> '.') and (sr.Name <> '..') then

            MyCopy(aDir + sr.Name,sDir + sr.Name);

        end else

        begin

          if (sr.Name <> '.') and (sr.Name <> '..') then

          begin

            ForceDirectories(sDir);

            Application.ProcessMessages;

            aWaitForm.Caption := '正在复制' + aDir + sr.Name;

            Application.ProcessMessages;

            FileCopyFile(aDir + sr.Name,sDir + sr.Name);//在线程中执行

            //MyThread1.sPath := aDir + sr.Name;

            //MyThread1.tPath := sDir + sr.Name;

            //MyThread1.flag := true;

            Application.ProcessMessages;

          end;

        end;

      until FindNext(sr) <> 0;

      FindClose(sr);

    end;

  end;

begin

  if DirectoryExists(tDir) then

  begin

    if  Pub.MsgYesNoBox('已存在该文件夹确信要覆盖吗?') then

      FileDeleteDirectory(tDir)

    else exit;

  end;

  aWaitForm := FormCreateProcessFrm('正在复制文件,请稍候...');

  try

    aWaitForm.Show;

    Application.ProcessMessages;

    MyCopy(sDir, tDir);

  finally

    ConFree(aWaitForm);//先释放Form上的控件

    aWaitForm.Free;

    aWaitForm := nil;

  end;

end;

procedure MyFileCopyDirectory(sDir, tDir:string;AHandle:Thandle;Flag: integer = 0);

var

  fromdir,todir{,dirname}:pchar;

  SHFileOpStruct:TSHFileOpStruct;

begin

  GetMem(fromdir,length(sDir)+2);

  try

    GetMem(todir,length(tdir)+2);

    try

      FIllchar(fromdir^,length(sDir)+2,0);

      FIllchar(todir^,length(tDir)+2,0);

      strcopy(fromdir,pchar(sDir));

      strcopy(todir,pchar(tDir));

      with SHFileOpStruct  do

      begin

        wnd := AHandle;

        if Flag = 1 then

          WFunc := FO_MOVE

        else

          WFunc := FO_COPY;

        //该参数指明shFileOperation函数将执行目录的拷贝

        pFrom:=fromdir;

        pTO:=todir;

        fFlags:=FOF_NOCONFIRMATION OR FOF_RENAMEONCOLLISION;

        fAnyOperationsAborted:=false;

        hnamemappings:=nil;

        lpszprogresstitle:=nil;

      end;

      if shFileOperation(SHFileOpStruct)<>0 then

        Raiselastwin32Error;

    finally

      FreeMem(todir,length(tDir)+2);

    end;

  finally

    FreeMem(fromdir,length(sDir)+2);

  end;

end;

procedure TPub.FileMoveDirectory(sDir, tDir:string;AHandle:Thandle);

var

  fromdir,todir{,dirname}:pchar;

  SHFileOpStruct:TSHFileOpStruct;

begin

  // 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作

  if not DirectoryExists(sDir) then

  begin

    MsgBox('不存在源路径“' + sDir + '”,移动数据失败!');

    exit;

  end;

  if DirectoryExists(tDir) then

  begin

    if  Pub.MsgYesNoBox('已存在该文件夹确信要覆盖吗?') then

      FileDeleteDirectory(tDir)

    else exit;

  end else

  if not MsgYesNoBox('不存在目标路径“' + tDir + '”,要创建吗?') then exit;

 

  ForceDirectories(tDir);

  MyFileCopyDirectory(sDir, tDir, AHandle, 1);

end;

 

procedure TPub.FileCopyDirectory(sDir, tDir:string;AHandle:Thandle);

begin

  // 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作

  if not DirectoryExists(sDir) then

  begin

    MsgBox('不存在源路径“' + sDir + '”,复制失败!');

    exit;

  end;

  if DirectoryExists(tDir) then

  begin

    if  Pub.MsgYesNoBox('已存在该文件夹确信要覆盖吗?') then

      FileDeleteDirectory(tDir)

    else exit;

  end else

  if not MsgYesNoBox('不存在目标路径“' + tDir + '”,要创建吗?') then exit;

  ForceDirectories(tDir);

  MyFileCopyDirectory(sDir, tDir, AHandle);

end;

//以下网络

 

function TPub.NetJudgeOnline: boolean;

var

  b: array[0..4] of Byte;

begin

  with TRegistry.Create do

  try

    RootKey := HKEY_LOCAL_MACHINE;

    OpenKey('System/CurrentControlSet/Services/RemoteAccess',False);

    ReadBinaryData('Remote Connection',b,4);

  finally

    Free;

  end;

  if b[0]=0 then

    Result := true

  else

    Result := false;

end;

 

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

    : 检测机器是否登入网络

    :

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

  备 注:

  版 本:

     1.0  2002/10/03 09:55:00

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

Function TPub.NetCheckMacAttachNet: Boolean;

begin

  Result := False;

  if GetSystemMetrics(SM_NETWORK) <> 0 then  //所有连入网的

    Result := True;

end;

 

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

    : 返回本机的局域网Ip地址

    :

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

  备 注:

  版 本:

     1.0  2002/10/02 21:05:00

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

function TPub.NetGetLocalIP(var LocalIp: string): Boolean;

var

    HostEnt: PHostEnt;

    Ip: string;

    addr: pchar;

    Buffer: array [0..63] of char;

    GInitData: TWSADATA;

begin

  Result := False;

  try

    WSAStartup(2, GInitData);

    GetHostName(Buffer, SizeOf(Buffer));

    HostEnt := GetHostByName(buffer);

    if HostEnt = nil then Exit;

    addr := HostEnt^.h_addr_list^;

    ip := Format('%d.%d.%d.%d', [byte(addr [0]),

          byte (addr [1]), byte (addr [2]), byte (addr [3])]);

    LocalIp := Ip;

    Result := True;

  finally

    WSACleanup;

  end;

end;

 

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

    : 通过Ip返回机器名

   :

          IpAddr: 想要得到名字的Ip

  返回值: 成功:  机器名   失败:  ''

  备 注:

    inet_addr function converts a string containing an Internet

    Protocol dotted address into an in_addr.

  版 本:

    1.0  2002/10/02 22:09:00

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

function TPub.NetGetNameByIPAddr(IPAddr : String;var MacName:String): Boolean;

var

  SockAddrIn: TSockAddrIn;

  HostEnt: PHostEnt;

  WSAData: TWSAData;

begin

  Result := False;

  if IpAddr = '' then exit;

  try

    WSAStartup(2, WSAData);

    SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));

    HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);

    if HostEnt <> nil then

      MacName := StrPas(Hostent^.h_name);

    Result := True;

  finally

    WSACleanup;

  end;

end;

 

 

 

 

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

    : 返回网络中SQLServer列表

    :

          List: 需要填充的List

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

  备 注:

  版 本:

    1.0  2002/10/02 22:44:00

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

Function TPub.NetGetSQLServerList(var List: Tstringlist): boolean;

var

   i: integer;

   SQLServer: Variant;

   ServerList: Variant;

begin

  Result := False;

  List.Clear;

  try

    SQLServer := CreateOleObject('SQLDMO.Application');

    ServerList := SQLServer.ListAvailableSQLServers;

    for i := 1 to Serverlist.Count do

      list.Add (Serverlist.item(i));

    Result := True;

  Finally

    SQLServer := NULL;

    ServerList := NULL;

  end;

end;

 

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

    : 判断Ip协议有没有安装

    :

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

  备 注:   该函数还有问题

  版 本:

     1.0  2002/10/02 21:05:00

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

Function TPub.NetIsIPInstalled : boolean;

var

  WSData: TWSAData;

  ProtoEnt: PProtoEnt;

begin

  Result := True;

  try

    if WSAStartup(2,WSData) = 0 then

    begin

      ProtoEnt := GetProtoByName('IP');

      if ProtoEnt = nil then

        Result := False

    end;

  finally

    WSACleanup;

  end;

end;

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

    : 返回网络中的共享资源

    :

          IpAddr: 机器Ip

          List: 需要填充的List

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

  备 注:

     WNetOpenEnum function starts an enumeration of network

     resources or existing connections.

     WNetEnumResource function continues a network-resource

     enumeration started by the WNetOpenEnum function.

  版 本:

     1.0  2002/10/03 07:30:00

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

Function TPub.NetGetUserResource(IpAddr: 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;

  if copy(Ipaddr,0,2) <> '//' then

    IpAddr := '//'+IpAddr;   //填充Ip地址信息

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

  NetResource.lpRemoteName := @IpAddr[1];//指定计算机名称

  //获取指定计算机的网络资源句柄

  Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_ANY,

                      RESOURCEUSAGE_CONNECTABLE, @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表示删除"//"

       ////192.168.0.1 => 192.168.0.1

       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:00:00

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

 

 

 

 

Function TPub.NetGetGroupList( var List : TStringList ) : Boolean;

type

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

Var

  NetResource: TNetResource;

  Buf: Pointer;

  Count,BufSize,Res: DWORD;

  lphEnum: THandle;

  p: TNetResourceArray;

  i,j: SmallInt;

  NetworkTypeList: TList;

Begin

  Result := False;

  NetworkTypeList := TList.Create;

  List.Clear;

  //获取整个网络中的文件资源的句柄,lphEnum为返回名柄

  Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

                       RESOURCEUSAGE_CONTAINER, Nil,lphEnum);

  if Res <> NO_ERROR then exit;//Raise Exception(Res);//执行失败

  //获取整个网络中的网络类型信息

  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

    NetworkTypeList.Add(p);

    Inc(P);

  end;

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

  if Res <> NO_ERROR then exit;

  for j := 0 to NetworkTypeList.Count-1 do //列出各个网络类型中的所有工作组名称

  begin//列出一个网络类型中的所有工作组名称

    NetResource := TNetResource(NetworkTypeList.Items[J]^);//网络类型信息

    //获取某个网络类型的文件资源的句柄,NetResource为网络类型信息,lphEnum为返回名柄

    Res := WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_DISK,

                        RESOURCEUSAGE_CONTAINER, @NetResource,lphEnum);

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

    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 ) or (Res <> NO_ERROR)  then break;

      P := TNetResourceArray(Buf);

      for i := 0 to Count - 1 do//列举各个工作组的信息

      begin

        List.Add( StrPAS( P^.lpRemoteName ));//取得一个工作组的名称

        Inc(P);

      end;

    end;

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

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

  end;

  Result := True;

  FreeMem(Buf);

  NetworkTypeList.Destroy;

End;

阅读更多
想对作者说点什么?

博主推荐

换一批

没有更多推荐了,返回首页