Delphi公共函数(一)

//摘自Kendy's Blog
{

    使用方法, uses 本单元——>使用如:Pub.MsgBox('你好,欢迎使用本公用函数!');
                                     ShowMessage(Pub.PathExeDir);
}
//////////////////////以下源码开始
{$DEFINE Delphi7}//D5下不要此句
unit PubFuncUnit;

interface

uses Windows, SysUtils, ShellAPI, Messages, Classes, Forms, Controls, ComCtrls,
     Dialogs, Graphics, Registry, winsock, ComObj, WinInet,FileCtrl
     {$IFDEF Delphi7},Variants{$EndIf};
const
  DEFAULT_DELIMITERS = [' ', #9, #10, #13];//空格分隔
type
  TMyClass = class
  private
    procedure CleanDirectoryProc(sFileName: string; var bContinue: Boolean);
  end;
  TEnumDirectoryFileProc = procedure (Filename: string; var bContinue: Boolean) of object;
type
  TPub = class
  private
    procedure ProcessTimer1Timer(Sender: TObject);
  public
    //封装API ShellExecute// 0:隐含窗口,1:显示窗口....其他参考帮助
    function MyShellExecute(const sFileName: string; sPara: string= ''; sAction :string = 'Open';
       flag: integer = 1): LongInt;
    //在进程中运行//如:Pub.Execute('C:/WINNT/system32/net.exe send huo aa',true,true,nil);
    function MyExecute(const Command: string; bWaitExecute: Boolean;
       bShowWindow: Boolean; PI: PProcessInformation): Boolean;

    //文件操作部分起
    //拷贝一个文件,封装CopyFile
    procedure FileCopyFile(const sSrcFile, sDstFile: string);
    //给定路径复制文件到同一目录下 bRecursive:true所有
    procedure FileCopyDirectory(sDir, tDir: string; bRecursive: Boolean);overload;
    //给定路径原样复制文件 ,自编
    procedure FileCopyDirectory(sDir, tDir: string);overload;
    //给定路径原样复制文件 ,用WinAPI ,若原目录下有相同文件则再生成一个
    procedure FileCopyDirectory(sDir, tDir:string;AHandle:Thandle);overload;
    //移动文件夹
    procedure FileMoveDirectory(sDir, tDir:string;AHandle:Thandle);
    //删除给定路径及以下的所有路径和文件
    procedure FileDeleteDirectory(sDir: string);overload;
    //删除给定路径及以下的所有路径和文件 用WinApi
    procedure FileDeleteDirectory(AHandle: THandle;const ADirName: string);overload;
    //删除给定路径及以下的所有路径和文件 到回收站
    procedure FileDeleteDirectoryToCycle(AHandle: THandle;const ADirName: string);
    //取得指定文件的大小
    function  FileGetFileSize(const Filename: string): DWORD;
    //在Path下取得唯一FilenameX文件
    function  FileGetUniqueFileName(const Path: string; Filename: string): string;
    //取得临时文件
    function  FileGetTemporaryFileName: string;

    //取得系统路径
    function PathGetSystemPath: string;
    //取得Windows路径
    function PathGetWindowsPath: string;
    //给定文件名取得在系统目录下的路径,复制时用
    function PathSystemDirFile(const Filename: string): string;
    //给定文件名取得在Windows目录下的路径,复制时用
    function PathWindowsDirFile(const Filename: string): string;
    //给定文件名取得在系统盘下的路径,复制时用
    function PathSystemDriveFile(const Filename: string): string;
    //路径最后有'/'则去'/'
    function PathWithoutSlash(const Path: string): string;
    //路径最后没有'/'则加'/'
    function PathWithSlash(const Path: string): string;
    //取得两路径的不同部分,条件是前半部分相同
    function PathRelativePath(BaseDir, FilePath: string): string;
    //取得去掉属性的路径,文件名也作为DIR
    function PathExtractFileNameNoExt(Filename: string): string;
    //判断两路径是否相等
    function PathComparePath(const Path1, Path2: string): Boolean;
    //取得给定路径的父路径
    function PathParentDirectory(Path: string): string;
    //分割路径,Result=根(如d:)sPath = 除根外的其他部分
    function PathGetRootDir(var sPath: string): string;
    //取得路径最后部分和其他部分 如d:/aa/aa result:=aa  sPath:=d:/aa/
    function PathGetLeafDir(var sPath: string): string;
    //取得当前应用程序的路径
    function PathExeDir(FileName: string = ''): string;
    //文件操作部分止

    //系统处理起
    //提示窗口
    procedure MsgBox(const Msg: string);
    //错误显示窗口
    procedure MsgErrBox(const Msg: string);
    //询问窗口 带'是','否'按钮
    function  MsgYesNoBox(const Msg: string): Boolean;
    //询问窗口 带'是','否,'取消'按钮//返回值smbYes,smbNo,smbCancel
    function  MsgYesNoCancelBox(const Msg: string): Integer;
    //使鼠标变忙和恢复正常
    procedure DoBusy(Busy: Boolean);
    //显示错误信息
    procedure ShowLastError(const Msg: string = 'API Error');
    //发出错误信息
    procedure RaiseLastError(const Msg: string = 'API Error');
    //释放Strings连接的相关资源
    procedure FreeStringsObjects(SL: TStrings);
    //系统处理止

    //时间处理起
    //整数到时间
    function  TimeT_To_DateTime(TimeT: Longint): TDateTime;
    //转化为秒
    function  TimeToSecond(const H, M, S: Integer): Integer;
    //秒转化
    procedure TimeSecondToTime(const secs: Integer; var H, M, S: Word);
    //秒转化
    function  TimeSecondToTimeStr(secs: Integer): string;
    //时间处理止

    //控件处理起
    //设置控件是否能使用
    procedure ConEnableControl(AControl: TControl; Enable: Boolean);
    //设置控件是否能使用,包子控件
    procedure ConEnableChildControls(AControl: TControl; Enable: Boolean);
    procedure ConEnableClassControl(AControl: TControl; Enable: Boolean;
      ControlClass: TControlClass);
    procedure ConFree(aCon: TWinControl);//释放aCon上的控件
    //从文件本中导入,类似LoadfromFile
    procedure ConLoadTreeViewFromTextFile(Nodes: TTreeNodes; Filename: string);
    //存为文本,类似SaveToFile
    procedure ConSaveTreeViewToTextFile(Nodes: TTreeNodes; Filename: string);
    //在控件上写文本
    procedure ConWriteText(aContr: TControl;sText: string);
    //控件处理止


//字符串处理起
    //取以Delimiters分隔的字符串 bTrail如果为True则把第index个后的也取出来
    function  StrGetToken(const S: string; index: Integer;
       bTrail: Boolean = False;
       Delimiters: TSysCharSet = DEFAULT_DELIMITERS): string;
    //取以Delimiters分隔的字符串的个数
    function  StrCountWords(S: string; Delimiters: TSysCharSet =
       DEFAULT_DELIMITERS): Integer;
    //用NewToken替换S中所有Token bCaseSensitive:=true大小写敏感
    function  StrReplaceString(var S: string; const Token,
       NewToken: string; bCaseSensitive: Boolean): Boolean;
    //从第Index个起以Substr替换Count个字符
    procedure StrSimple_ReplaceString(var S: string;
       const  Substr: string; index, Count: Integer);
    //去掉S中的回车返行符
    procedure StrTruncateCRLF(var S: string);
    //判定S是否以回车返行符结束
    function  StrIsContainingCRLF(const S: string): Boolean;
    //把SL中的各项数据转化为以Delimiter分隔的Str
    function  StrCompositeStrings(SL: TStrings; const Delimiter: string): string;
    //封装TStrings的LoadFromFile
    function  StrSafeLoadStrings(SL: TStrings; const Filename: string): Boolean;
    //封装TStrings的SaveToFile
    procedure StrSafeSaveStrings(SL: TStrings; const Filename: string);
    //字符串处理止

    //字体处理起
    procedure StringToFont(sFont: string; Font: TFont; bIncludeColor: Boolean = True);
    function FontToString(Font: TFont; bIncludeColor: Boolean = True): string;
    //字体处理止

    //网络起
    //判定是否在线
    function NetJudgeOnline:boolean;
    //得到本机的局域网Ip地址
    Function NetGetLocalIp(var LocalIp:string): Boolean;
    //通过Ip返回机器名
    Function NetGetNameByIPAddr(IPAddr: string; var MacName: string): Boolean ;
    //获取网络中SQLServer列表
    Function NetGetSQLServerList(var List: Tstringlist): Boolean;
    //获取网络中的所有网络类型
    Function NetGetNetList(var List: Tstringlist): Boolean;
    //获取网络中的工作组
    Function NetGetGroupList(var List: TStringList): Boolean;
    //获取工作组中所有计算机
    Function NetGetUsers(GroupName: string; var List: TStringList): Boolean;
    //获取网络中的资源
    Function NetGetUserResource(IpAddr: string; var List: TStringList): Boolean;
    //映射网络驱动器
    Function NetAddConnection(NetPath: Pchar; PassWord: Pchar;LocalPath: Pchar): Boolean;
    //检测网络状态
    Function NetCheckNet(IpAddr:string): Boolean;
    //检测机器是否登入网络
    Function NetCheckMacAttachNet: Boolean;
    //判断Ip协议有没有安装   这个函数有问题
    Function NetIsIPInstalled : boolean;
    //检测机器是否上网
    Function NetInternetConnected: Boolean;
    //网络止

    //窗口起
    function FormCreateProcessFrm(MsgTitle: string):TForm;
    //窗口止

    //EMail起
    function CheckMailAddress(Text: string): boolean;
    //EMail止
  end;

  var
    Pub: TPub;

implementation
uses ExtCtrls, StdCtrls, TFlatProgressBarUnit;
{ TMyClass }

 

 

const
  csfsBold      = '|Bold';
  csfsItalic    = '|Italic';
  csfsUnderline = '|Underline';
  csfsStrikeout = '|Strikeout';
  C_Err_GetLocalIp       = '获取本地ip失败';
  C_Err_GetNameByIpAddr  = '获取主机名失败';
  C_Err_GetSQLServerList = '获取SQLServer服务器失败';
  C_Err_GetUserResource  = '获取共享资失败';
  C_Err_GetGroupList     = '获取所有工作组失败';
  C_Err_GetGroupUsers    = '获取工作组中所有计算机失败';
  C_Err_GetNetList       = '获取所有网络类型失败';
  C_Err_CheckNet         = '网络不通';
  C_Err_CheckAttachNet   = '未登入网络';
  C_Err_InternetConnected ='没有上网';
  C_Txt_CheckNetSuccess  = '网络畅通';
  C_Txt_CheckAttachNetSuccess = '已登入网络';
  C_Txt_InternetConnected ='上网了';

procedure TMyClass.CleanDirectoryProc(sFileName: string; var bContinue: Boolean);
var
  Attr: Integer;
begin
  Attr := FileGetAttr(sFileName);
  Attr := (not faReadOnly) and Attr; // Turn off ReadOnly attribute
  Attr := (not faHidden) and Attr;   // Turn off Hidden attribute
  FileSetAttr(sFileName, Attr);

  if Attr and faDirectory <> 0 then
    RMDir(sFileName)
  else
    SysUtils.DeleteFile(sFileName);
end;

{ TPub }

function TPub.PathWithoutSlash(const Path: string): string;
begin
  if (Length(Path) > 0) and (Path[Length(Path)] = '/') then Result := Copy(Path, 1, Length(Path) - 1)
  else Result := Path;
end;

function TPub.PathWithSlash(const Path: string): string;
begin
  Result := Path;
  if (Length(Result) > 0) and (Result[Length(Result)] <> '/') then Result := Result + '/';
end;

function TPub.PathRelativePath(BaseDir, FilePath: string): string;
begin
  Result := FilePath;
  BaseDir := AnsiUpperCaseFileName(PathWithSlash(BaseDir));
  FilePath := AnsiUpperCaseFileName(FilePath);
  if Copy(FilePath, 1, Length(BaseDir)) = BaseDir then
    Delete(Result, 1, Length(BaseDir));
end;

function TPub.MyShellExecute(const sFileName: string; sPara: string= ''; sAction :string = 'Open';
       flag: integer = 1): LongInt;
begin
  Result := ShellExecute(Application.Handle, PChar(sAction), PChar(sFileName), PChar(sPara), PChar(''), flag);// > 32;
  if Result < 33 then RaiseLastError('ShellExecute');
end;

function TPub.MyExecute(const Command: string; bWaitExecute: Boolean; bShowWindow: Boolean; PI: PProcessInformation): Boolean;
var
  StartupInfo       : TStartupInfo;
  ProcessInformation: TProcessInformation;
begin
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    if bShowWindow then
      wShowWindow := SW_NORMAL
    else
      wShowWindow := SW_HIDE;
  end;

  Result := CreateProcess(nil, PChar(Command),
    nil, nil, True, NORMAL_PRIORITY_CLASS, nil, nil,
    StartupInfo, ProcessInformation);

  if not Result then Exit;

  if bWaitExecute then
    WaitForSingleObject(ProcessInformation.hProcess, INFINITE);

  if Assigned(PI) then
    Move(ProcessInformation, PI^, SizeOf(ProcessInformation));
end;

function TPub.PathExtractFileNameNoExt(Filename: string): string;
begin
  Result := Copy(Filename, 1, Length(Filename) - Length(ExtractFileExt(Filename)));
end;

function TPub.FileGetFileSize(const Filename: string): DWORD;
var
  HFILE: THandle;
begin
  HFILE := CreateFile(PChar(Filename), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if HFILE <> INVALID_HANDLE_VALUE then
  begin
    Result := GetFileSize(HFILE, nil);
    CloseHandle(HFILE);
  end else
    Result := 0;
end;

procedure TPub.FileCopyFile(const sSrcFile, sDstFile: string);
begin
  if AnsiCompareFileName(sSrcFile, sDstFile) <> 0 then
    CopyFile(PChar(sSrcFile), PChar(sDstFile), False);
end;


function TPub.FileGetTemporaryFileName: string;
var
  Buf, Buf1: array[0..255] of Char;
begin
  GetTempPath(255, @Buf);
  GetTempFileName(@Buf, 'xpd', 0, @Buf1);
  Result := StrPas(@Buf1);
end;

function TruncateTrailNumber(var S: string): Integer;//取得逗号分开的两数,后数据必为合法整数222,333 s := 222 result := 333
var
  I: Integer;
begin
  Result := -1;

  I := Pos(',', S);
  if I <> 0 then
  begin
    Result := StrToIntDef(Copy(S, I + 1, Length(S)), - 1);
    Delete(S, I, Length(S));
  end;
end;

function TruncateTrailIfNotDLL(S: string): string;
begin
  Result := S;
  TruncateTrailNumber(S);

  if (CompareText(ExtractFileExt(S), '.DLL') <> 0) and
    (CompareText(ExtractFileExt(S), '.ICL') <> 0) and
    (CompareText(ExtractFileExt(S), '.EXE') <> 0) then Result := S;
end;

function TPub.PathParentDirectory(Path: string): string;
var
  iLastAntiSlash: Integer;

  function CountAntiSlash: Integer;
  var
    I: Integer;
  begin
    Result := 0;
    I := 1;
    repeat
      if IsDBCSLeadByte(Ord(Path[I])) then
        Inc(I, 2)
      else
      begin
        if Path[I] = '/' then
        begin
          iLastAntiSlash := I;
          Inc(Result);
        end;
        Inc(I);
      end;
    until I > Length(Path);
  end;

  function UpOneDirectory: string;
  begin
    Result := Copy(Path, 1, iLastAntiSlash); // with slash
  end;

begin
  // 'c:/windows/system/' => 'c:/window/'
  // 'f:/' => 'f:/'
  // '//xshadow/f/fonts' => '//xshadow/f/'
  // '//xshadow/f/' => '//xshadow/f/'
  Path := PathWithoutSlash(Path);

  if Length(Path) > 3 then
  begin
    if (Path[1] = '/') and (Path[2] = '/') then
    begin
      if CountAntiSlash > 3 then
        Result := UpOneDirectory;
    end else
    begin
      if CountAntiSlash > 1 then
        Result := UpOneDirectory;
    end;
  end else Result := Path;
end;

 


function TPub.PathSystemDirFile(const Filename: string): string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf)) + Filename;
end;

function TPub.PathWindowsDirFile(const Filename: string): string;
var
  Buf: array[0..255] of Char;
begin
  GetWindowsDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf)) + Filename;
end;

function TPub.PathSystemDriveFile(const Filename: string): string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  Result := PathWithSlash(ExtractFileDrive(StrPas(@Buf))) + Filename;
end;

function TPub.PathComparePath(const Path1, Path2: string): Boolean;
begin
  Result := AnsiCompareFileName(PathWithoutSlash(Path1), PathWithoutSlash(Path2)) = 0;
end;
procedure EnumDirectoryFiles(sDir, SMASK: string; Attr: Integer; EnumDirectoryFileProc: TEnumDirectoryFileProc);
var
  SearchRec: TSearchRec;
  Status   : Integer;
  bContinue: Boolean;
begin
  sDir := Pub.PathWithSlash(sDir);

  // traverse child directories
  Status := FindFirst(sDir + '*.*', faDirectory, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
        EnumDirectoryFiles(sDir + SearchRec.name, SMASK, Attr, EnumDirectoryFileProc);

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;

  // exam each valid file and invoke the callback func
  Status := FindFirst(sDir + SMASK, faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.Attr and Attr <> 0) and (FileExists(sDir + SearchRec.name) or DirectoryExists(sDir + SearchRec.name)) and
        not ((SearchRec.Attr and faDirectory <> 0) and ((SearchRec.name = '.') or (SearchRec.name = '..'))) then
      begin
        bContinue := True;
        EnumDirectoryFileProc(sDir + SearchRec.name, bContinue);
        if not bContinue then Break;
      end;

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

procedure TPub.FileDeleteDirectory(sDir: string);
begin
  //if not MsgYesNoBox('确信要删除该目录及以下所有文件夹和文件吗?') then exit;
  with TMyClass.Create do
    try
      EnumDirectoryFiles(sDir, '*.*', faAnyFile, CleanDirectoryProc);
    finally
      Free;
    end;
  RMDir(sDir);
end;

procedure TPub.FileDeleteDirectory(AHandle: THandle;const ADirName: string);
var
  SHFileOpStruct:TSHFileOpStruct;
  DirName: PChar;
  BufferSize: Cardinal;
begin
  // 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作
  BufferSize := length(ADirName) + 2;
  GetMem(DirName,BufferSize);
  try
    FIllChar(DirName^, BufferSize, 0);
    StrCopy(DirName,PChar(ADirName));
    with SHFileOpStruct  do
    begin
      Wnd := AHandle;
      WFunc := FO_DELETE;
      pFrom := DirName;
      pTO := nil;
      fFlags := FOF_ALLOWUNDO;

      fAnyOperationsAborted := false;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
    if SHFileOperation(SHFileOpStruct) <> 0 then
      Raiselastwin32Error;
  finally
    FreeMem(DirName,BufferSize);
  end;
end;

procedure TPub.FileDeleteDirectoryToCycle(AHandle: THandle;const ADirName: string);
var
  SHFileOpStruct:TSHFileOpStruct;
  DirName: PChar;
  BufferSize: Cardinal;
  aa: string;
begin
  // 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作
  if not DirectoryExists(ADirName) then
  begin
    aa := ADirName;
    MsgBox('不存在文件夹“' + PathGetLeafDir(aa) + '”,删除失败!');
    exit;
  end;
  BufferSize := length(ADirName) + 2;
  GetMem(DirName,BufferSize);
  try
    FIllChar(DirName^, BufferSize, 0);
    StrCopy(DirName,PChar(ADirName));
    with SHFileOpStruct  do
    begin
      Wnd := AHandle;
      WFunc := FO_DELETE;
      pFrom := DirName;
      pTO := nil;
      fFlags := FOF_ALLOWUNDO;

      fAnyOperationsAborted:=false;
      hNameMappings:=nil;
      lpszProgressTitle:=nil;
    end;
    if SHFileOperation(SHFileOpStruct) <> 0 then
      Raiselastwin32Error;
  finally
    FreeMem(DirName,BufferSize);
  end;
end;

procedure TPub.FileCopyDirectory(sDir, tDir: string; bRecursive: Boolean);
var
  SearchRec: TSearchRec;
  Status   : Integer;
begin
  sDir := PathWithSlash(sDir);
  tDir := PathWithSlash(tDir);

  Status := FindFirst(sDir + '*.*', faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if bRecursive and (SearchRec.Attr and faDirectory = faDirectory) then
      begin
        if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
          FileCopyDirectory(sDir + SearchRec.name, tDir, bRecursive);
      end else FileCopyFile(sDir + SearchRec.name, tDir + SearchRec.name);

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

function TPub.FileGetUniqueFileName(const Path: string; Filename: string): string;
var
  I   : Integer;
  sExt: string;
begin
  Result := Filename;

  sExt := ExtractFileExt(Filename);
  Filename := PathExtractFileNameNoExt(Filename);

  I := 1;
  repeat
    if not FileExists(PathWithSlash(Path) + Result) then Break;

    Result := Filename + IntToStr(I) + sExt;
    Inc(I);
  until False;

  Result := PathWithSlash(Path) + Filename + sExt;
end;


function TPub.PathGetSystemPath: string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf));
end;

function TPub.PathGetWindowsPath: string;
var
  Buf: array[0..255] of Char;
begin
  GetWindowsDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf));
end;

function TPub.PathGetRootDir(var sPath: string): string;
var
  I: Integer;
begin
  I := AnsiPos('/', sPath);
  if I <> 0 then
    Result := Copy(sPath, 1, I)
  else
    Result := sPath;

  Delete(sPath, 1, Length(Result));
  Result := PathWithoutSlash(Result);
end;

function TPub.PathGetLeafDir(var sPath: string): string;
begin
  sPath := PathWithoutSlash(sPath);
  Result := ExtractFileName(sPath);
  sPath := ExtractFilePath(sPath);
end;

 


//系统部分
procedure TPub.MsgBox(const Msg: string);
begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONINFORMATION);
end;

procedure TPub.MsgErrBox(const Msg: string);
begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONERROR);
end;

function TPub.MsgYesNoBox(const Msg: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONQUESTION or
    MB_YESNO or MB_DEFBUTTON1) = IDYES;
end;

function TPub.MsgYesNoCancelBox(const Msg: string): Integer;
begin
  Result := Application.MessageBox(PChar(Msg),
    PChar(Application.Title), MB_ICONQUESTION or MB_YESNOCANCEL or MB_DEFBUTTON1)
end;

procedure TPub.DoBusy(Busy: Boolean);
var
  Times: Integer;
begin
  Times := 0;
  if Busy then
  begin
    Inc(Times);
    if Times = 1 then Screen.Cursor := crHourGlass;
  end else
  begin
    dec(Times);
    if Times = 0 then Screen.Cursor := crDefault;
  end;
end;

function GetLastErrorStr: string;
var
  Buf: PChar;
begin
  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
    nil, GetLastError, LANG_USER_DEFAULT, @Buf, 0, nil);
  try
    Result := StrPas(Buf);
  finally
    LocalFree(HLOCAL(Buf));
  end;
end;

procedure TPub.ShowLastError(const Msg: string = 'API Error');
begin
  MsgBox(Msg + ': ' + GetLastErrorStr);
end;

procedure TPub.RaiseLastError(const Msg: string = 'API Error');
begin
  raise Exception.Create(Msg + ': ' + GetLastErrorStr);
end;

procedure TPub.FreeStringsObjects(SL: TStrings);
var
  I: Integer;
begin
  for I := 0 to SL.count - 1 do
    if assigned(SL.objects[I]) then
    begin
      Dispose(pointer(SL.objects[I]));
      SL.objects[I] := nil;
    end;
end;
//以下时间
function TPub.TimeT_To_DateTime(TimeT: Longint): TDateTime;
var
  ts: TTimeStamp;
begin
  Dec(TimeT, 3600 * 8);    // still unprecise
  ts.Time := (TimeT mod 86400) * 1000;
  ts.Date := TimeT div 86400 + 719163;
  Result := TimeStampToDateTime(ts);
end;

function TPub.TimeToSecond(const H, M, S: Integer): Integer;
begin
  Result := H * 3600 + M * 60 + S;
end;

procedure TPub.TimeSecondToTime(const secs: Integer; var H, M, S: Word);
begin
  H := secs div 3600;
  M := (secs mod 3600) div 60;
  S := secs mod 60;
end;

function TPub.TimeSecondToTimeStr(secs: Integer): string;
var
  H, M, S: Word;
begin
 TimeSecondtotime(secs, h, m, s);

 result := '';
 if h <> 0 then Result := result + format('%-.2d  ', [h]);
 if m <> 0 then Result := result + format('%-.2d だ ', [m]);
 if s <> 0 then Result := result + format('%-.2d  ', [s]);
end;

//以下控件
procedure TPub.ConEnableControl(AControl: TControl; Enable: Boolean);
var
  I: Integer;
begin
  AControl.Enabled := Enable;
  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      for I := 0 to ControlCount - 1 do
        ConEnableControl(Controls[I], Enable);
    end;
end;

procedure TPub.ConEnableChildControls(AControl: TControl; Enable: Boolean);
var
  I: Integer;
begin
  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      for I := 0 to ControlCount - 1 do
        ConEnableControl(Controls[I], Enable);
    end;
end;

procedure TPub.ConEnableClassControl(AControl: TControl; Enable: Boolean; ControlClass: TControlClass);
var
  I: Integer;
begin
  if (AControl is ControlClass) then AControl.Enabled := Enable;

  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      for I := 0 to ControlCount - 1 do
        ConEnableClassControl(Controls[I], Enable, ControlClass);
    end;
end;

function ParseRPLNo(var Msg: string): Integer;
var
  S: string;
begin
  S := Pub.StrGetToken(Msg, 1,False );
  Result := StrToIntDef(S, 0);
  Msg := Pub.StrGetToken(Msg, 2,True );
end;

procedure TPub.ConLoadTreeViewFromTextFile(Nodes: TTreeNodes; Filename: string);
var
  F: TextFile;

  function ProcessNode(Node: TTreeNode; LevelNo: Integer): TTreeNode;
  var
    S : string;
    No: Integer;
  begin
    Result := Node;
    repeat
      readln(F, S);
      No := ParseRPLNo(S);
      if No > LevelNo then
      begin
        Node := ProcessNode(Nodes.addchild(Node, S), No);
      end else if No < LevelNo then
      begin
        Result := Nodes.Add(Node.Parent, S);
        Exit;
      end else
        Node := Nodes.Add(Node, S);

    until EOF(F);
  end;

begin
  Assignfile(F, Filename);
  reset(F);

  ProcessNode(nil, 1);

  CloseFile(F);
end;


    使用方法, uses 本单元——>使用如:Pub.MsgBox('你好,欢迎使用本公用函数!');
                                     ShowMessage(Pub.PathExeDir);
}
//////////////////////以下源码开始
{$DEFINE Delphi7}//D5下不要此句
unit PubFuncUnit;

interface

uses Windows, SysUtils, ShellAPI, Messages, Classes, Forms, Controls, ComCtrls,
     Dialogs, Graphics, Registry, winsock, ComObj, WinInet,FileCtrl
     {$IFDEF Delphi7},Variants{$EndIf};
const
  DEFAULT_DELIMITERS = [' ', #9, #10, #13];//空格分隔
type
  TMyClass = class
  private
    procedure CleanDirectoryProc(sFileName: string; var bContinue: Boolean);
  end;
  TEnumDirectoryFileProc = procedure (Filename: string; var bContinue: Boolean) of object;
type
  TPub = class
  private
    procedure ProcessTimer1Timer(Sender: TObject);
  public
    //封装API ShellExecute// 0:隐含窗口,1:显示窗口....其他参考帮助
    function MyShellExecute(const sFileName: string; sPara: string= ''; sAction :string = 'Open';
       flag: integer = 1): LongInt;
    //在进程中运行//如:Pub.Execute('C:/WINNT/system32/net.exe send huo aa',true,true,nil);
    function MyExecute(const Command: string; bWaitExecute: Boolean;
       bShowWindow: Boolean; PI: PProcessInformation): Boolean;

    //文件操作部分起
    //拷贝一个文件,封装CopyFile
    procedure FileCopyFile(const sSrcFile, sDstFile: string);
    //给定路径复制文件到同一目录下 bRecursive:true所有
    procedure FileCopyDirectory(sDir, tDir: string; bRecursive: Boolean);overload;
    //给定路径原样复制文件 ,自编
    procedure FileCopyDirectory(sDir, tDir: string);overload;
    //给定路径原样复制文件 ,用WinAPI ,若原目录下有相同文件则再生成一个
    procedure FileCopyDirectory(sDir, tDir:string;AHandle:Thandle);overload;
    //移动文件夹
    procedure FileMoveDirectory(sDir, tDir:string;AHandle:Thandle);
    //删除给定路径及以下的所有路径和文件
    procedure FileDeleteDirectory(sDir: string);overload;
    //删除给定路径及以下的所有路径和文件 用WinApi
    procedure FileDeleteDirectory(AHandle: THandle;const ADirName: string);overload;
    //删除给定路径及以下的所有路径和文件 到回收站
    procedure FileDeleteDirectoryToCycle(AHandle: THandle;const ADirName: string);
    //取得指定文件的大小
    function  FileGetFileSize(const Filename: string): DWORD;
    //在Path下取得唯一FilenameX文件
    function  FileGetUniqueFileName(const Path: string; Filename: string): string;
    //取得临时文件
    function  FileGetTemporaryFileName: string;

    //取得系统路径
    function PathGetSystemPath: string;
    //取得Windows路径
    function PathGetWindowsPath: string;
    //给定文件名取得在系统目录下的路径,复制时用
    function PathSystemDirFile(const Filename: string): string;
    //给定文件名取得在Windows目录下的路径,复制时用
    function PathWindowsDirFile(const Filename: string): string;
    //给定文件名取得在系统盘下的路径,复制时用
    function PathSystemDriveFile(const Filename: string): string;
    //路径最后有'/'则去'/'
    function PathWithoutSlash(const Path: string): string;
    //路径最后没有'/'则加'/'
    function PathWithSlash(const Path: string): string;
    //取得两路径的不同部分,条件是前半部分相同
    function PathRelativePath(BaseDir, FilePath: string): string;
    //取得去掉属性的路径,文件名也作为DIR
    function PathExtractFileNameNoExt(Filename: string): string;
    //判断两路径是否相等
    function PathComparePath(const Path1, Path2: string): Boolean;
    //取得给定路径的父路径
    function PathParentDirectory(Path: string): string;
    //分割路径,Result=根(如d:)sPath = 除根外的其他部分
    function PathGetRootDir(var sPath: string): string;
    //取得路径最后部分和其他部分 如d:/aa/aa result:=aa  sPath:=d:/aa/
    function PathGetLeafDir(var sPath: string): string;
    //取得当前应用程序的路径
    function PathExeDir(FileName: string = ''): string;
    //文件操作部分止

    //系统处理起
    //提示窗口
    procedure MsgBox(const Msg: string);
    //错误显示窗口
    procedure MsgErrBox(const Msg: string);
    //询问窗口 带'是','否'按钮
    function  MsgYesNoBox(const Msg: string): Boolean;
    //询问窗口 带'是','否,'取消'按钮//返回值smbYes,smbNo,smbCancel
    function  MsgYesNoCancelBox(const Msg: string): Integer;
    //使鼠标变忙和恢复正常
    procedure DoBusy(Busy: Boolean);
    //显示错误信息
    procedure ShowLastError(const Msg: string = 'API Error');
    //发出错误信息
    procedure RaiseLastError(const Msg: string = 'API Error');
    //释放Strings连接的相关资源
    procedure FreeStringsObjects(SL: TStrings);
    //系统处理止

    //时间处理起
    //整数到时间
    function  TimeT_To_DateTime(TimeT: Longint): TDateTime;
    //转化为秒
    function  TimeToSecond(const H, M, S: Integer): Integer;
    //秒转化
    procedure TimeSecondToTime(const secs: Integer; var H, M, S: Word);
    //秒转化
    function  TimeSecondToTimeStr(secs: Integer): string;
    //时间处理止

    //控件处理起
    //设置控件是否能使用
    procedure ConEnableControl(AControl: TControl; Enable: Boolean);
    //设置控件是否能使用,包子控件
    procedure ConEnableChildControls(AControl: TControl; Enable: Boolean);
    procedure ConEnableClassControl(AControl: TControl; Enable: Boolean;
      ControlClass: TControlClass);
    procedure ConFree(aCon: TWinControl);//释放aCon上的控件
    //从文件本中导入,类似LoadfromFile
    procedure ConLoadTreeViewFromTextFile(Nodes: TTreeNodes; Filename: string);
    //存为文本,类似SaveToFile
    procedure ConSaveTreeViewToTextFile(Nodes: TTreeNodes; Filename: string);
    //在控件上写文本
    procedure ConWriteText(aContr: TControl;sText: string);
    //控件处理止


//字符串处理起
    //取以Delimiters分隔的字符串 bTrail如果为True则把第index个后的也取出来
    function  StrGetToken(const S: string; index: Integer;
       bTrail: Boolean = False;
       Delimiters: TSysCharSet = DEFAULT_DELIMITERS): string;
    //取以Delimiters分隔的字符串的个数
    function  StrCountWords(S: string; Delimiters: TSysCharSet =
       DEFAULT_DELIMITERS): Integer;
    //用NewToken替换S中所有Token bCaseSensitive:=true大小写敏感
    function  StrReplaceString(var S: string; const Token,
       NewToken: string; bCaseSensitive: Boolean): Boolean;
    //从第Index个起以Substr替换Count个字符
    procedure StrSimple_ReplaceString(var S: string;
       const  Substr: string; index, Count: Integer);
    //去掉S中的回车返行符
    procedure StrTruncateCRLF(var S: string);
    //判定S是否以回车返行符结束
    function  StrIsContainingCRLF(const S: string): Boolean;
    //把SL中的各项数据转化为以Delimiter分隔的Str
    function  StrCompositeStrings(SL: TStrings; const Delimiter: string): string;
    //封装TStrings的LoadFromFile
    function  StrSafeLoadStrings(SL: TStrings; const Filename: string): Boolean;
    //封装TStrings的SaveToFile
    procedure StrSafeSaveStrings(SL: TStrings; const Filename: string);
    //字符串处理止

    //字体处理起
    procedure StringToFont(sFont: string; Font: TFont; bIncludeColor: Boolean = True);
    function FontToString(Font: TFont; bIncludeColor: Boolean = True): string;
    //字体处理止

    //网络起
    //判定是否在线
    function NetJudgeOnline:boolean;
    //得到本机的局域网Ip地址
    Function NetGetLocalIp(var LocalIp:string): Boolean;
    //通过Ip返回机器名
    Function NetGetNameByIPAddr(IPAddr: string; var MacName: string): Boolean ;
    //获取网络中SQLServer列表
    Function NetGetSQLServerList(var List: Tstringlist): Boolean;
    //获取网络中的所有网络类型
    Function NetGetNetList(var List: Tstringlist): Boolean;
    //获取网络中的工作组
    Function NetGetGroupList(var List: TStringList): Boolean;
    //获取工作组中所有计算机
    Function NetGetUsers(GroupName: string; var List: TStringList): Boolean;
    //获取网络中的资源
    Function NetGetUserResource(IpAddr: string; var List: TStringList): Boolean;
    //映射网络驱动器
    Function NetAddConnection(NetPath: Pchar; PassWord: Pchar;LocalPath: Pchar): Boolean;
    //检测网络状态
    Function NetCheckNet(IpAddr:string): Boolean;
    //检测机器是否登入网络
    Function NetCheckMacAttachNet: Boolean;
    //判断Ip协议有没有安装   这个函数有问题
    Function NetIsIPInstalled : boolean;
    //检测机器是否上网
    Function NetInternetConnected: Boolean;
    //网络止

    //窗口起
    function FormCreateProcessFrm(MsgTitle: string):TForm;
    //窗口止

    //EMail起
    function CheckMailAddress(Text: string): boolean;
    //EMail止
  end;

  var
    Pub: TPub;

implementation
uses ExtCtrls, StdCtrls, TFlatProgressBarUnit;
{ TMyClass }

 

 

const
  csfsBold      = '|Bold';
  csfsItalic    = '|Italic';
  csfsUnderline = '|Underline';
  csfsStrikeout = '|Strikeout';
  C_Err_GetLocalIp       = '获取本地ip失败';
  C_Err_GetNameByIpAddr  = '获取主机名失败';
  C_Err_GetSQLServerList = '获取SQLServer服务器失败';
  C_Err_GetUserResource  = '获取共享资失败';
  C_Err_GetGroupList     = '获取所有工作组失败';
  C_Err_GetGroupUsers    = '获取工作组中所有计算机失败';
  C_Err_GetNetList       = '获取所有网络类型失败';
  C_Err_CheckNet         = '网络不通';
  C_Err_CheckAttachNet   = '未登入网络';
  C_Err_InternetConnected ='没有上网';
  C_Txt_CheckNetSuccess  = '网络畅通';
  C_Txt_CheckAttachNetSuccess = '已登入网络';
  C_Txt_InternetConnected ='上网了';

procedure TMyClass.CleanDirectoryProc(sFileName: string; var bContinue: Boolean);
var
  Attr: Integer;
begin
  Attr := FileGetAttr(sFileName);
  Attr := (not faReadOnly) and Attr; // Turn off ReadOnly attribute
  Attr := (not faHidden) and Attr;   // Turn off Hidden attribute
  FileSetAttr(sFileName, Attr);

  if Attr and faDirectory <> 0 then
    RMDir(sFileName)
  else
    SysUtils.DeleteFile(sFileName);
end;

{ TPub }

function TPub.PathWithoutSlash(const Path: string): string;
begin
  if (Length(Path) > 0) and (Path[Length(Path)] = '/') then Result := Copy(Path, 1, Length(Path) - 1)
  else Result := Path;
end;

function TPub.PathWithSlash(const Path: string): string;
begin
  Result := Path;
  if (Length(Result) > 0) and (Result[Length(Result)] <> '/') then Result := Result + '/';
end;

function TPub.PathRelativePath(BaseDir, FilePath: string): string;
begin
  Result := FilePath;
  BaseDir := AnsiUpperCaseFileName(PathWithSlash(BaseDir));
  FilePath := AnsiUpperCaseFileName(FilePath);
  if Copy(FilePath, 1, Length(BaseDir)) = BaseDir then
    Delete(Result, 1, Length(BaseDir));
end;

function TPub.MyShellExecute(const sFileName: string; sPara: string= ''; sAction :string = 'Open';
       flag: integer = 1): LongInt;
begin
  Result := ShellExecute(Application.Handle, PChar(sAction), PChar(sFileName), PChar(sPara), PChar(''), flag);// > 32;
  if Result < 33 then RaiseLastError('ShellExecute');
end;

function TPub.MyExecute(const Command: string; bWaitExecute: Boolean; bShowWindow: Boolean; PI: PProcessInformation): Boolean;
var
  StartupInfo       : TStartupInfo;
  ProcessInformation: TProcessInformation;
begin
  FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  with StartupInfo do
  begin
    cb := SizeOf(TStartupInfo);
    dwFlags := STARTF_USESHOWWINDOW;
    if bShowWindow then
      wShowWindow := SW_NORMAL
    else
      wShowWindow := SW_HIDE;
  end;

  Result := CreateProcess(nil, PChar(Command),
    nil, nil, True, NORMAL_PRIORITY_CLASS, nil, nil,
    StartupInfo, ProcessInformation);

  if not Result then Exit;

  if bWaitExecute then
    WaitForSingleObject(ProcessInformation.hProcess, INFINITE);

  if Assigned(PI) then
    Move(ProcessInformation, PI^, SizeOf(ProcessInformation));
end;

function TPub.PathExtractFileNameNoExt(Filename: string): string;
begin
  Result := Copy(Filename, 1, Length(Filename) - Length(ExtractFileExt(Filename)));
end;

function TPub.FileGetFileSize(const Filename: string): DWORD;
var
  HFILE: THandle;
begin
  HFILE := CreateFile(PChar(Filename), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
  if HFILE <> INVALID_HANDLE_VALUE then
  begin
    Result := GetFileSize(HFILE, nil);
    CloseHandle(HFILE);
  end else
    Result := 0;
end;

procedure TPub.FileCopyFile(const sSrcFile, sDstFile: string);
begin
  if AnsiCompareFileName(sSrcFile, sDstFile) <> 0 then
    CopyFile(PChar(sSrcFile), PChar(sDstFile), False);
end;


function TPub.FileGetTemporaryFileName: string;
var
  Buf, Buf1: array[0..255] of Char;
begin
  GetTempPath(255, @Buf);
  GetTempFileName(@Buf, 'xpd', 0, @Buf1);
  Result := StrPas(@Buf1);
end;

function TruncateTrailNumber(var S: string): Integer;//取得逗号分开的两数,后数据必为合法整数222,333 s := 222 result := 333
var
  I: Integer;
begin
  Result := -1;

  I := Pos(',', S);
  if I <> 0 then
  begin
    Result := StrToIntDef(Copy(S, I + 1, Length(S)), - 1);
    Delete(S, I, Length(S));
  end;
end;

function TruncateTrailIfNotDLL(S: string): string;
begin
  Result := S;
  TruncateTrailNumber(S);

  if (CompareText(ExtractFileExt(S), '.DLL') <> 0) and
    (CompareText(ExtractFileExt(S), '.ICL') <> 0) and
    (CompareText(ExtractFileExt(S), '.EXE') <> 0) then Result := S;
end;

function TPub.PathParentDirectory(Path: string): string;
var
  iLastAntiSlash: Integer;

  function CountAntiSlash: Integer;
  var
    I: Integer;
  begin
    Result := 0;
    I := 1;
    repeat
      if IsDBCSLeadByte(Ord(Path[I])) then
        Inc(I, 2)
      else
      begin
        if Path[I] = '/' then
        begin
          iLastAntiSlash := I;
          Inc(Result);
        end;
        Inc(I);
      end;
    until I > Length(Path);
  end;

  function UpOneDirectory: string;
  begin
    Result := Copy(Path, 1, iLastAntiSlash); // with slash
  end;

begin
  // 'c:/windows/system/' => 'c:/window/'
  // 'f:/' => 'f:/'
  // '//xshadow/f/fonts' => '//xshadow/f/'
  // '//xshadow/f/' => '//xshadow/f/'
  Path := PathWithoutSlash(Path);

  if Length(Path) > 3 then
  begin
    if (Path[1] = '/') and (Path[2] = '/') then
    begin
      if CountAntiSlash > 3 then
        Result := UpOneDirectory;
    end else
    begin
      if CountAntiSlash > 1 then
        Result := UpOneDirectory;
    end;
  end else Result := Path;
end;

 


function TPub.PathSystemDirFile(const Filename: string): string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf)) + Filename;
end;

function TPub.PathWindowsDirFile(const Filename: string): string;
var
  Buf: array[0..255] of Char;
begin
  GetWindowsDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf)) + Filename;
end;

function TPub.PathSystemDriveFile(const Filename: string): string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  Result := PathWithSlash(ExtractFileDrive(StrPas(@Buf))) + Filename;
end;

function TPub.PathComparePath(const Path1, Path2: string): Boolean;
begin
  Result := AnsiCompareFileName(PathWithoutSlash(Path1), PathWithoutSlash(Path2)) = 0;
end;
procedure EnumDirectoryFiles(sDir, SMASK: string; Attr: Integer; EnumDirectoryFileProc: TEnumDirectoryFileProc);
var
  SearchRec: TSearchRec;
  Status   : Integer;
  bContinue: Boolean;
begin
  sDir := Pub.PathWithSlash(sDir);

  // traverse child directories
  Status := FindFirst(sDir + '*.*', faDirectory, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
        EnumDirectoryFiles(sDir + SearchRec.name, SMASK, Attr, EnumDirectoryFileProc);

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;

  // exam each valid file and invoke the callback func
  Status := FindFirst(sDir + SMASK, faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if (SearchRec.Attr and Attr <> 0) and (FileExists(sDir + SearchRec.name) or DirectoryExists(sDir + SearchRec.name)) and
        not ((SearchRec.Attr and faDirectory <> 0) and ((SearchRec.name = '.') or (SearchRec.name = '..'))) then
      begin
        bContinue := True;
        EnumDirectoryFileProc(sDir + SearchRec.name, bContinue);
        if not bContinue then Break;
      end;

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

procedure TPub.FileDeleteDirectory(sDir: string);
begin
  //if not MsgYesNoBox('确信要删除该目录及以下所有文件夹和文件吗?') then exit;
  with TMyClass.Create do
    try
      EnumDirectoryFiles(sDir, '*.*', faAnyFile, CleanDirectoryProc);
    finally
      Free;
    end;
  RMDir(sDir);
end;

procedure TPub.FileDeleteDirectory(AHandle: THandle;const ADirName: string);
var
  SHFileOpStruct:TSHFileOpStruct;
  DirName: PChar;
  BufferSize: Cardinal;
begin
  // 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作
  BufferSize := length(ADirName) + 2;
  GetMem(DirName,BufferSize);
  try
    FIllChar(DirName^, BufferSize, 0);
    StrCopy(DirName,PChar(ADirName));
    with SHFileOpStruct  do
    begin
      Wnd := AHandle;
      WFunc := FO_DELETE;
      pFrom := DirName;
      pTO := nil;
      fFlags := FOF_ALLOWUNDO;

      fAnyOperationsAborted := false;
      hNameMappings := nil;
      lpszProgressTitle := nil;
    end;
    if SHFileOperation(SHFileOpStruct) <> 0 then
      Raiselastwin32Error;
  finally
    FreeMem(DirName,BufferSize);
  end;
end;

procedure TPub.FileDeleteDirectoryToCycle(AHandle: THandle;const ADirName: string);
var
  SHFileOpStruct:TSHFileOpStruct;
  DirName: PChar;
  BufferSize: Cardinal;
  aa: string;
begin
  // 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作
  if not DirectoryExists(ADirName) then
  begin
    aa := ADirName;
    MsgBox('不存在文件夹“' + PathGetLeafDir(aa) + '”,删除失败!');
    exit;
  end;
  BufferSize := length(ADirName) + 2;
  GetMem(DirName,BufferSize);
  try
    FIllChar(DirName^, BufferSize, 0);
    StrCopy(DirName,PChar(ADirName));
    with SHFileOpStruct  do
    begin
      Wnd := AHandle;
      WFunc := FO_DELETE;
      pFrom := DirName;
      pTO := nil;
      fFlags := FOF_ALLOWUNDO;

      fAnyOperationsAborted:=false;
      hNameMappings:=nil;
      lpszProgressTitle:=nil;
    end;
    if SHFileOperation(SHFileOpStruct) <> 0 then
      Raiselastwin32Error;
  finally
    FreeMem(DirName,BufferSize);
  end;
end;

procedure TPub.FileCopyDirectory(sDir, tDir: string; bRecursive: Boolean);
var
  SearchRec: TSearchRec;
  Status   : Integer;
begin
  sDir := PathWithSlash(sDir);
  tDir := PathWithSlash(tDir);

  Status := FindFirst(sDir + '*.*', faAnyFile, SearchRec);
  try
    while Status = 0 do
    begin
      if bRecursive and (SearchRec.Attr and faDirectory = faDirectory) then
      begin
        if (SearchRec.name <> '.') and (SearchRec.name <> '..') then
          FileCopyDirectory(sDir + SearchRec.name, tDir, bRecursive);
      end else FileCopyFile(sDir + SearchRec.name, tDir + SearchRec.name);

      Status := FindNext(SearchRec);
    end;
  finally
    SysUtils.FindClose(SearchRec);
  end;
end;

function TPub.FileGetUniqueFileName(const Path: string; Filename: string): string;
var
  I   : Integer;
  sExt: string;
begin
  Result := Filename;

  sExt := ExtractFileExt(Filename);
  Filename := PathExtractFileNameNoExt(Filename);

  I := 1;
  repeat
    if not FileExists(PathWithSlash(Path) + Result) then Break;

    Result := Filename + IntToStr(I) + sExt;
    Inc(I);
  until False;

  Result := PathWithSlash(Path) + Filename + sExt;
end;


function TPub.PathGetSystemPath: string;
var
  Buf: array[0..255] of Char;
begin
  GetSystemDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf));
end;

function TPub.PathGetWindowsPath: string;
var
  Buf: array[0..255] of Char;
begin
  GetWindowsDirectory(@Buf, 255);
  Result := PathWithSlash(StrPas(@Buf));
end;

function TPub.PathGetRootDir(var sPath: string): string;
var
  I: Integer;
begin
  I := AnsiPos('/', sPath);
  if I <> 0 then
    Result := Copy(sPath, 1, I)
  else
    Result := sPath;

  Delete(sPath, 1, Length(Result));
  Result := PathWithoutSlash(Result);
end;

function TPub.PathGetLeafDir(var sPath: string): string;
begin
  sPath := PathWithoutSlash(sPath);
  Result := ExtractFileName(sPath);
  sPath := ExtractFilePath(sPath);
end;

 


//系统部分
procedure TPub.MsgBox(const Msg: string);
begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONINFORMATION);
end;

procedure TPub.MsgErrBox(const Msg: string);
begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONERROR);
end;

function TPub.MsgYesNoBox(const Msg: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONQUESTION or
    MB_YESNO or MB_DEFBUTTON1) = IDYES;
end;

function TPub.MsgYesNoCancelBox(const Msg: string): Integer;
begin
  Result := Application.MessageBox(PChar(Msg),
    PChar(Application.Title), MB_ICONQUESTION or MB_YESNOCANCEL or MB_DEFBUTTON1)
end;

procedure TPub.DoBusy(Busy: Boolean);
var
  Times: Integer;
begin
  Times := 0;
  if Busy then
  begin
    Inc(Times);
    if Times = 1 then Screen.Cursor := crHourGlass;
  end else
  begin
    dec(Times);
    if Times = 0 then Screen.Cursor := crDefault;
  end;
end;

function GetLastErrorStr: string;
var
  Buf: PChar;
begin
  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
    nil, GetLastError, LANG_USER_DEFAULT, @Buf, 0, nil);
  try
    Result := StrPas(Buf);
  finally
    LocalFree(HLOCAL(Buf));
  end;
end;

procedure TPub.ShowLastError(const Msg: string = 'API Error');
begin
  MsgBox(Msg + ': ' + GetLastErrorStr);
end;

procedure TPub.RaiseLastError(const Msg: string = 'API Error');
begin
  raise Exception.Create(Msg + ': ' + GetLastErrorStr);
end;

procedure TPub.FreeStringsObjects(SL: TStrings);
var
  I: Integer;
begin
  for I := 0 to SL.count - 1 do
    if assigned(SL.objects[I]) then
    begin
      Dispose(pointer(SL.objects[I]));
      SL.objects[I] := nil;
    end;
end;
//以下时间
function TPub.TimeT_To_DateTime(TimeT: Longint): TDateTime;
var
  ts: TTimeStamp;
begin
  Dec(TimeT, 3600 * 8);    // still unprecise
  ts.Time := (TimeT mod 86400) * 1000;
  ts.Date := TimeT div 86400 + 719163;
  Result := TimeStampToDateTime(ts);
end;

function TPub.TimeToSecond(const H, M, S: Integer): Integer;
begin
  Result := H * 3600 + M * 60 + S;
end;

procedure TPub.TimeSecondToTime(const secs: Integer; var H, M, S: Word);
begin
  H := secs div 3600;
  M := (secs mod 3600) div 60;
  S := secs mod 60;
end;

function TPub.TimeSecondToTimeStr(secs: Integer): string;
var
  H, M, S: Word;
begin
 TimeSecondtotime(secs, h, m, s);

 result := '';
 if h <> 0 then Result := result + format('%-.2d  ', [h]);
 if m <> 0 then Result := result + format('%-.2d だ ', [m]);
 if s <> 0 then Result := result + format('%-.2d  ', [s]);
end;

//以下控件
procedure TPub.ConEnableControl(AControl: TControl; Enable: Boolean);
var
  I: Integer;
begin
  AControl.Enabled := Enable;
  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      for I := 0 to ControlCount - 1 do
        ConEnableControl(Controls[I], Enable);
    end;
end;

procedure TPub.ConEnableChildControls(AControl: TControl; Enable: Boolean);
var
  I: Integer;
begin
  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      for I := 0 to ControlCount - 1 do
        ConEnableControl(Controls[I], Enable);
    end;
end;

procedure TPub.ConEnableClassControl(AControl: TControl; Enable: Boolean; ControlClass: TControlClass);
var
  I: Integer;
begin
  if (AControl is ControlClass) then AControl.Enabled := Enable;

  if AControl is TWinControl then
    with TWinControl(AControl) do
    begin
      for I := 0 to ControlCount - 1 do
        ConEnableClassControl(Controls[I], Enable, ControlClass);
    end;
end;

function ParseRPLNo(var Msg: string): Integer;
var
  S: string;
begin
  S := Pub.StrGetToken(Msg, 1,False );
  Result := StrToIntDef(S, 0);
  Msg := Pub.StrGetToken(Msg, 2,True );
end;

procedure TPub.ConLoadTreeViewFromTextFile(Nodes: TTreeNodes; Filename: string);
var
  F: TextFile;

  function ProcessNode(Node: TTreeNode; LevelNo: Integer): TTreeNode;
  var
    S : string;
    No: Integer;
  begin
    Result := Node;
    repeat
      readln(F, S);
      No := ParseRPLNo(S);
      if No > LevelNo then
      begin
        Node := ProcessNode(Nodes.addchild(Node, S), No);
      end else if No < LevelNo then
      begin
        Result := Nodes.Add(Node.Parent, S);
        Exit;
      end else
        Node := Nodes.Add(Node, S);

    until EOF(F);
  end;

begin
  Assignfile(F, Filename);
  reset(F);

  ProcessNode(nil, 1);

  CloseFile(F);
end;

阅读更多
个人分类: Delphi编程
想对作者说点什么? 我来说一句

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

关闭
关闭
关闭