公用函数(博客用户)
使用方法, uses 本单元——>使用如:Pub.MsgBox('你好，欢迎使用本公用函数！');
ShowMessage(Pub.PathExeDir);
//////////////////////以下源码开始
{$DEFINE Delphi6}//D5下不要此句
unit PubFuncUnit;
interface
uses Windows, SysUtils, ShellAPI, Messages, Classes, Forms, Controls, ComCtrls,
Dialogs, Graphics, Registry, winsock, ComObj, WinInet,FileCtrl
{$IFDEF Delphi6},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;
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;
{=================================================================
功 能: 列举工作组中所有的计算机
参 数:
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 DELPHI6}
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.
ShowMessage(Pub.PathExeDir);
//////////////////////以下源码开始
{$DEFINE Delphi6}//D5下不要此句
unit PubFuncUnit;
interface
uses Windows, SysUtils, ShellAPI, Messages, Classes, Forms, Controls, ComCtrls,
Dialogs, Graphics, Registry, winsock, ComObj, WinInet,FileCtrl
{$IFDEF Delphi6},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;
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;
{=================================================================
功 能: 列举工作组中所有的计算机
参 数:
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 DELPHI6}
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.
