很楠不爱3

这个屌丝很懒，什么也没留下！

热门标签

Delphi公共函数（一）_delphi 调用公共函数

作者：很楠不爱3 | 2024-03-14 12:12:50

踩

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;