使用方法, uses 本单元——>使用如:Pub.MsgBox(''你好，欢迎使用本公用函数！'');ShowMessage(Pub.PathExeDir); //以下源码开始{$DEFINE Delphi6}//D5下不要此句unit PubFuncUnit;interfaceuses Windows, SysUtils, ShellAPI, Messages, Classes, Forms, Controls, ComCtrls,Dialogs, Graphics, Registry, winsock, ComObj, WinInet,FileCtrl{$IFDEF Delphi6},Variants{$EndIf};constDEFAULT_DELIMITERS = ['' '', #9, #10, #13];//空格分隔typeTMyClass = classprivateprocedure CleanDirectoryProc(sFileName: string; var bContinue: Boolean);end;TEnumDirectoryFileProc = procedure (Filename: string; var bContinue: Boolean) of object;typeTPub = classprivateprocedure 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;//文件操作部分起//拷贝一个文件，封装CopyFileprocedure 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;//删除给定路径及以下的所有路径和文件 用WinApiprocedure 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;//取得去掉属性的路径，文件名也作为DIRfunction 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,smbCancelfunction 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上的控件//从文件本中导入,类似LoadfromFileprocedure ConLoadTreeViewFromTextFile(Nodes: TTreeNodes; Filename: string);//存为文本,类似SaveToFileprocedure ConSaveTreeViewToTextFile(Nodes: TTreeNodes; Filename: string);//在控件上写文本procedure ConWriteText(aContr: TControl;sText: string);//控件处理止回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:47:44 得分:0 //字符串处理起//取以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分隔的Strfunction StrCompositeStrings(SL: TStrings; const Delimiter: string): string;//封装TStrings的LoadFromFilefunction StrSafeLoadStrings(SL: TStrings; const Filename: string): Boolean;//封装TStrings的SaveToFileprocedure 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;varPub: TPub;implementationuses ExtCtrls, StdCtrls, TFlatProgressBarUnit;{ TMyClass }Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:48:18 得分:0 constcsfsBold = ''|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);varAttr: Integer;beginAttr := FileGetAttr(sFileName);Attr := (not faReadOnly) and Attr; // Turn off ReadOnly attributeAttr := (not faHidden) and Attr; // Turn off Hidden attributeFileSetAttr(sFileName, Attr);if Attr and faDirectory <> 0 thenRMDir(sFileName)elseSysUtils.DeleteFile(sFileName);end;{ TPub }function TPub.PathWithoutSlash(const Path: string): string;beginif (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;beginResult := Path;if (Length(Result) > 0) and (Result[Length(Result)] <> ''/'') then Result := Result + ''/'';end;function TPub.PathRelativePath(BaseDir, FilePath: string): string;beginResult := FilePath;BaseDir := AnsiUpperCaseFileName(PathWithSlash(BaseDir));FilePath := AnsiUpperCaseFileName(FilePath);if Copy(FilePath, 1, Length(BaseDir)) = BaseDir thenDelete(Result, 1, Length(BaseDir));end;function TPub.MyShellExecute(const sFileName: string; sPara: string= ''''; sAction :string = ''Open'';flag: integer = 1): LongInt;beginResult := 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;varStartupInfo : TStartupInfo;ProcessInformation: TProcessInformation;beginFillChar(StartupInfo, SizeOf(TStartupInfo), 0);with StartupInfo dobegincb := SizeOf(TStartupInfo);dwFlags := STARTF_USESHOWWINDOW;if bShowWindow thenwShowWindow := SW_NORMALelsewShowWindow := 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 thenWaitForSingleObject(ProcessInformation.hProcess, INFINITE);if Assigned(PI) thenMove(ProcessInformation, PI^, SizeOf(ProcessInformation));end;function TPub.PathExtractFileNameNoExt(Filename: string): string;beginResult := Copy(Filename, 1, Length(Filename) - Length(ExtractFileExt(Filename)));end;function TPub.FileGetFileSize(const Filename: string): DWORD;varHfile: THandle;beginHFILE := CreateFile(PChar(Filename), GENERIC_READ, FILE_SHARE_READ, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);if HFILE <> INVALID_HANDLE_VALUE thenbeginResult := GetFileSize(HFILE, nil);CloseHandle(HFILE);end elseResult := 0;end;procedure TPub.FileCopyFile(const sSrcFile, sDstfile: string);beginif AnsiCompareFileName(sSrcFile, sDstFile) <> 0 thenCopyFile(PChar(sSrcFile), PChar(sDstFile), False);end;function TPub.FileGetTemporaryFileName: string;varBuf, Buf1: array[0..255] of Char;beginGetTempPath(255, @Buf);GetTempFileName(@Buf, ''xpd'', 0, @Buf1);Result := StrPas(@Buf1);end;function TruncateTrailNumber(var S: string): Integer;//取得逗号分开的两数，后数据必为合法整数222,333 s := 222 result := 333varI: Integer;beginResult := -1;I := Pos('','', S);if I <> 0 thenbeginResult := StrToIntDef(Copy(S, I + 1, Length(S)), - 1);Delete(S, I, Length(S));end;end;function TruncateTrailIfNotDLL(S: string): string;beginResult := 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;variLastAntiSlash: Integer;function CountAntiSlash: Integer;varI: Integer;beginResult := 0;I := 1;repeatif IsDBCSLeadByte(Ord(Path[I])) thenInc(I, 2)elsebeginif Path[I] = ''/'' thenbeginiLastAntiSlash := I;Inc(Result);end;Inc(I);end;until I > Length(Path);end;function UpOneDirectory: string;beginResult := Copy(Path, 1, iLastAntiSlash); // with slashend;begin// ''c:/windows/system/'' => ''c:/window/''// ''f:/'' => ''f:/''// ''//xshadow/f/fonts'' => ''//xshadow/f/''// ''//xshadow/f/'' => ''//xshadow/f/''Path := PathWithoutSlash(Path);if Length(Path) > 3 thenbeginif (Path[1] = ''/'') and (Path[2] = ''/'') thenbeginif CountAntiSlash > 3 thenResult := UpOneDirectory;end elsebeginif CountAntiSlash > 1 thenResult := UpOneDirectory;end;end else Result := Path;end;Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:48:44 得分:0 function TPub.PathSystemDirFile(const Filename: string): string;varBuf: array[0..255] of Char;beginGetSystemDirectory(@Buf, 255);Result := PathWithSlash(StrPas(@Buf)) + Filename;end;function TPub.PathWindowsDirFile(const Filename: string): string;varBuf: array[0..255] of Char;beginGetWindowsDirectory(@Buf, 255);Result := PathWithSlash(StrPas(@Buf)) + Filename;end;function TPub.PathSystemDriveFile(const Filename: string): string;varBuf: array[0..255] of Char;beginGetSystemDirectory(@Buf, 255);Result := PathWithSlash(ExtractFileDrive(StrPas(@Buf))) + Filename;end;function TPub.PathComparePath(const Path1, Path2: string): Boolean;beginResult := AnsiCompareFileName(PathWithoutSlash(Path1), PathWithoutSlash(Path2)) = 0;end;procedure EnumDirectoryFiles(sDir, SMASK: string; Attr: Integer; EnumDirectoryFileProc: TEnumDirectoryFileProc);varSearchRec: TSearchRec;Status : Integer;bContinue: Boolean;beginsDir := Pub.PathWithSlash(sDir);// traverse child directoriesStatus := FindFirst(sDir + ''*.*'', faDirectory, SearchRec);trywhile Status = 0 dobeginif (SearchRec.name <> ''.'') and (SearchRec.name <> ''..'') thenEnumDirectoryFiles(sDir + SearchRec.name, SMASK, Attr, EnumDirectoryFileProc);Status := FindNext(SearchRec);end;finallySysUtils.FindClose(SearchRec);end;// exam each valid file and invoke the callback funcStatus := FindFirst(sDir + SMASK, faAnyFile, SearchRec);trywhile Status = 0 dobeginif (SearchRec.Attr and Attr <> 0) and (FileExists(sDir + SearchRec.name) or DirectoryExists(sDir + SearchRec.name)) andnot ((SearchRec.Attr and faDirectory <> 0) and ((SearchRec.name = ''.'') or (SearchRec.name = ''..''))) thenbeginbContinue := True;EnumDirectoryFileProc(sDir + SearchRec.name, bContinue);if not bContinue then Break;end;Status := FindNext(SearchRec);end;finallySysUtils.FindClose(SearchRec);end;end;procedure TPub.FileDeleteDirectory(sDir: string);begin//if not MsgYesNoBox(''确信要删除该目录及以下所有文件夹和文件吗？'') then exit;with TMyClass.Create dotryEnumDirectoryFiles(sDir, ''*.*'', faAnyFile, CleanDirectoryProc);finallyFree;end;RMDir(sDir);end;procedure TPub.FileDeleteDirectory(AHandle: THandle;const ADirName: string);varSHFileOpStruct:TSHFileOpStruct;DirName: PChar;BufferSize: Cardinal;begin// 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作BufferSize := length(ADirName) + 2;GetMem(DirName,BufferSize);tryFIllChar(DirName^, BufferSize, 0);StrCopy(DirName,PChar(ADirName));with SHFileOpStruct dobeginWnd := AHandle;WFunc := FO_DELETE;pFrom := DirName;pTO := nil;fFlags := FOF_ALLOWUNDO;fAnyOperationsAborted := false;hNameMappings := nil;lpszProgressTitle := nil;end;if SHFileOperation(SHFileOpStruct) <> 0 thenRaiselastwin32Error;finallyFreeMem(DirName,BufferSize);end;end;procedure TPub.FileDeleteDirectoryToCycle(AHandle: THandle;const ADirName: string);varSHFileOpStruct:TSHFileOpStruct;DirName: PChar;BufferSize: Cardinal;aa: string;begin// 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作if not DirectoryExists(ADirName) thenbeginaa := ADirName;MsgBox(''不存在文件夹“'' + PathGetLeafDir(aa) + ''”,删除失败！'');exit;end;BufferSize := length(ADirName) + 2;GetMem(DirName,BufferSize);tryFIllChar(DirName^, BufferSize, 0);StrCopy(DirName,PChar(ADirName));with SHFileOpStruct dobeginWnd := AHandle;WFunc := FO_DELETE;pFrom := DirName;pTO := nil;fFlags := FOF_ALLOWUNDO;fAnyOperationsAborted:=false;hNameMappings:=nil;lpszProgressTitle:=nil;end;if SHFileOperation(SHFileOpStruct) <> 0 thenRaiselastwin32Error;finallyFreeMem(DirName,BufferSize);end;end;procedure TPub.FileCopyDirectory(sDir, tDir: string; bRecursive: Boolean);varSearchRec: TSearchRec;Status : Integer;beginsDir := PathWithSlash(sDir);tDir := PathWithSlash(tDir);Status := FindFirst(sDir + ''*.*'', faAnyFile, SearchRec);trywhile Status = 0 dobeginif bRecursive and (SearchRec.Attr and faDirectory = faDirectory) thenbeginif (SearchRec.name <> ''.'') and (SearchRec.name <> ''..'') thenFileCopyDirectory(sDir + SearchRec.name, tDir, bRecursive);end else FileCopyFile(sDir + SearchRec.name, tDir + SearchRec.name);Status := FindNext(SearchRec);end;finallySysUtils.FindClose(SearchRec);end;end;function TPub.FileGetUniqueFileName(const Path: string; Filename: string): string;varI : Integer;sExt: string;beginResult := Filename;sExt := ExtractFileExt(Filename);Filename := PathExtractFileNameNoExt(Filename);I := 1;repeatif 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;varBuf: array[0..255] of Char;beginGetSystemDirectory(@Buf, 255);Result := PathWithSlash(StrPas(@Buf));end;function TPub.PathGetWindowsPath: string;varBuf: array[0..255] of Char;beginGetWindowsDirectory(@Buf, 255);Result := PathWithSlash(StrPas(@Buf));end;function TPub.PathGetRootDir(var sPath: string): string;varI: Integer;beginI := AnsiPos(''/'', sPath);if I <> 0 thenResult := Copy(sPath, 1, I)elseResult := sPath;Delete(sPath, 1, Length(Result));Result := PathWithoutSlash(Result);end;function TPub.PathGetLeafDir(var sPath: string): string;beginsPath := PathWithoutSlash(sPath);Result := ExtractFileName(sPath);sPath := ExtractFilePath(sPath);end;Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:49:14 得分:0 //系统部分procedure TPub.MsgBox(const Msg: string);beginApplication.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONINFORMATION);end;procedure TPub.MsgErrBox(const Msg: string);beginApplication.MessageBox(PChar(Msg), PChar(Application.Title), MB_IConERROR);end;function TPub.MsgYesNoBox(const Msg: string): Boolean;beginResult := Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONQUESTION orMB_YESNO or MB_DEFBUTTON1) = IDYES;end;function TPub.MsgYesNoCancelBox(const Msg: string): Integer;beginResult := Application.MessageBox(PChar(Msg),PChar(Application.Title), MB_ICONQUESTION or MB_YESNOCANCEL or MB_DEFBUTTON1)end;procedure TPub.DoBusy(Busy: Boolean);varTimes: Integer;beginTimes := 0;if Busy thenbeginInc(Times);if Times = 1 then Screen.Cursor := crHourGlass;end elsebegindec(Times);if Times = 0 then Screen.Cursor := crDefault;end;end;function GetLastErrorStr: string;varBuf: PChar;beginFormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,nil, GetLastError, LANG_USER_DEFAULT, @Buf, 0, nil);tryResult := StrPas(Buf);finallyLocalFree(HLOCAL(Buf));end;end;procedure TPub.ShowLastError(const Msg: string = ''API Error'');beginMsgBox(Msg + '': '' + GetLastErrorStr);end;procedure TPub.RaiseLastError(const Msg: string = ''API Error'');beginraise Exception.Create(Msg + '': '' + GetLastErrorStr);end;procedure TPub.FreeStringsObjects(SL: TStrings);varI: Integer;beginfor I := 0 to SL.count - 1 doif assigned(SL.objects[I]) thenbeginDispose(pointer(SL.objects[I]));SL.objects[I] := nil;end;end;//以下时间function TPub.TimeT_To_DateTime(TimeT: Longint): TDateTime;varts: TTimeStamp;beginDec(TimeT, 3600 * 8); // still unprecisets.Time := (TimeT mod 86400) * 1000;ts.Date := TimeT div 86400 + 719163;Result := TimeStampToDateTime(ts);end;function TPub.TimeToSecond(const H, M, S: Integer): Integer;beginResult := H * 3600 + M * 60 + S;end;procedure TPub.TimeSecondToTime(const secs: Integer; var H, M, S: Word);beginH := secs div 3600;M := (secs mod 3600) div 60;S := secs mod 60;end;function TPub.TimeSecondToTimeStr(secs: Integer): string;varH, M, S: Word;beginTimeSecondtotime(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);varI: Integer;beginAControl.Enabled := Enable;if AControl is TWinControl thenwith TWinControl(AControl) dobeginfor I := 0 to ControlCount - 1 doConEnableControl(Controls[I], Enable);end;end;procedure TPub.ConEnableChildControls(AControl: TControl; Enable: Boolean);varI: Integer;beginif AControl is TWinControl thenwith TWinControl(AControl) dobeginfor I := 0 to ControlCount - 1 doConEnableControl(Controls[I], Enable);end;end;procedure TPub.ConEnableClassControl(AControl: TControl; Enable: Boolean; ControlClass: TControlClass);varI: Integer;beginif (AControl is ControlClass) then AControl.Enabled := Enable;if AControl is TWinControl thenwith TWinControl(AControl) dobeginfor I := 0 to ControlCount - 1 doConEnableClassControl(Controls[I], Enable, ControlClass);end;end;function ParseRPLNo(var Msg: string): Integer;varS: string;beginS := Pub.StrGetToken(Msg, 1,False );Result := StrToIntDef(S, 0);Msg := Pub.StrGetToken(Msg, 2,True );end;procedure TPub.ConLoadTreeViewFromTextFile(Nodes: TTreeNodes; Filename: string);varF: TextFile;function ProcessNode(Node: TTreeNode; LevelNo: Integer): TTreeNode;varS : string;No: Integer;beginResult := Node;repeatreadln(F, S);No := ParseRPLNo(S);if No > LevelNo thenbeginNode := ProcessNode(Nodes.addchild(Node, S), No);end else if No < LevelNo thenbeginResult := Nodes.Add(Node.Parent, S);Exit;end elseNode := Nodes.Add(Node, S);until EOF(F);end;beginAssignfile(F, Filename);reset(F);ProcessNode(nil, 1);CloseFile(F);end;procedure TPub.ConSaveTreeViewToTextFile(Nodes: TTreeNodes; Filename: string);varF: TextFile;procedure ProcessNode(Node: TTreeNode; Depth: Integer);beginwhile Node <> nil dobeginWriteln(F, IntToStr(Depth) + '' '' + Node.Text);if Node.HasChildren thenProcessNode(Node.GetFirstChild, Depth + 1);Node := Node.getNextSibling;end;end;beginAssignfile(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;varI, W, head, tail: Integer;bInWord : Boolean;beginI := 1;W := 0;bInWord := False;head := 1;tail := Length(S);while (I <= Length(S)) and (W <= index) dobeginif S[I] in Delimiters thenbeginif (W = index) and bInWord then tail := I - 1;bInWord := False;end elsebeginif not bInWord thenbeginbInWord := 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;varbInWord: Boolean;I : Integer;beginResult := 0;I := 1;bInWord := False;while I <= Length(S) dobeginif S[I] in Delimiters then bInWord := Falseelsebeginif not bInWord thenbeginbInWord := True;Inc(Result);end;end;Inc(I);end;end;function TPub.StrIsContainingCRLF(const S: string): Boolean;varlen: Integer;beginlen := Length(S);Result := (len >= 2) and (S[len - 1] = #13) and (S[len] = #10);end;procedure TPub.StrTruncateCRLF(var S: string);varI: Integer;beginI := 1;while I <= Length(S) doif (S[I] = #13) or (S[I] = #10) then Delete(S, I, 1)else Inc(I);end;Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:50:16 得分:0 function TPub.StrReplaceString(var S: string; const Token, NewToken: string; bCaseSensitive: Boolean): Boolean;varI : Integer;sFirstPart: string;beginif bCaseSensitive thenI := AnsiPos(Token, S)elseI := AnsiPos(AnsiUpperCase(Token), AnsiUpperCase(S));if I <> 0 thenbeginsFirstPart := Copy(S, 1, I - 1) + NewToken;S := Copy(S, I + Length(Token), Maxint);end;Result := I <> 0;if Result thenbeginStrReplaceString(S, Token, NewToken, bCaseSensitive);S := sFirstPart + S;end;end;procedure TPub.StrSimple_ReplaceString(var S: string; const Substr: string; index, Count: Integer);beginS := 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;varI: Integer;beginResult := '''';with SL dobeginfor I := 0 to Count - 2 doResult := Result + Strings[I] + Delimiter;if Count > 0 thenResult := Result + Strings[Count - 1];end;end;function TPub.StrSafeLoadStrings(SL: TStrings; const Filename: string): Boolean;beginResult := False;repeattryif not FileExists(Filename) then Exit;SL.LoadFromFile(Filename);Result := True;Break;exceptSleep(500);end;until False;end;procedure TPub.StrSafeSaveStrings(SL: TStrings; const Filename: string);beginForceDirectories(ExtractFilePath(Filename));repeattrySL.SaveToFile(Filename);Break;exceptSleep(500);end;until False;end;//以下字体function TPub.FontToString(Font: TFont; bIncludeColor: Boolean): string;varsStyle: string;beginwith Font dobegin// convert font style to stringsStyle := '''';if (fsBold in Style) thensStyle := sStyle + csfsBold;if (fsItalic in Style) thensStyle := sStyle + csfsItalic;if (fsUnderline in Style) thensStyle := sStyle + csfsUnderline;if (fsStrikeOut in Style) thensStyle := sStyle + csfsStrikeout;if ((Length(sStyle) > 0) and (''|'' = sStyle[1])) thensStyle := Copy(sStyle, 2, Length(sStyle) - 1);Result := Format(''"%s", %d, [%s]'',[name, Size, sStyle]);if bIncludeColor thenResult := Result + Format('', [%s]'',[ColorToString(Color)]);end;end;procedure TPub.StringToFont(sFont: string; Font: TFont;bIncludeColor: Boolean);varP : Integer;sStyle: string; // Expected format:begin // "Arial", 9, [Bold], [clRed]with Font do //try// get font nameP := Pos('','', sFont);name := Copy(sFont, 2, P - 3);Delete(sFont, 1, P);// get font sizeP := Pos('','', sFont);Size := StrToInt(Copy(sFont, 2, P - 2));Delete(sFont, 1, P);// get font styleP := Pos('','', sFont);sStyle := ''|'' + Copy(sFont, 3, P - 4);Delete(sFont, 1, P);// get font colorif bIncludeColor thenColor := StringToColor(Copy(sFont, 3, Length(sFont) - 3));// convert str font style to// font styleStyle := [];if (Pos(csfsBold, sStyle) > 0) thenStyle := Style + [fsBold];if (Pos(csfsItalic, sStyle) > 0) thenStyle := Style + [fsItalic];if (Pos(csfsUnderline, sStyle) > 0) thenStyle := Style + [fsUnderline];if (Pos(csfsStrikeout, sStyle) > 0) thenStyle := Style + [fsStrikeOut];exceptend;end;procedure TPub.ConWriteText(aContr: TControl;sText: string);varc:TCanvas;beginc:=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;Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:51:03 得分:0 procedure TPub.FileCopyDirectory(sDir, tDir: string);varaWaitForm: TForm;RetValue: integer;procedure MyCopy(aDir, sDir: string);varsr: TSearchRec;beginaDir := PathWithSlash(aDir);sDir := PathWithSlash(sDir);if FindFirst(aDir+''*.*'', faAnyFile, sr) = 0 thenbeginrepeatif sr.Attr and faDirectory = faDirectory thenbeginif not DirectoryExists(aDir + sr.Name) then exit;if (sr.Name <> ''.'') and (sr.Name <> ''..'') thenMyCopy(aDir + sr.Name,sDir + sr.Name);end elsebeginif (sr.Name <> ''.'') and (sr.Name <> ''..'') thenbeginForceDirectories(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;beginif DirectoryExists(tDir) thenbeginif Pub.MsgYesNoBox(''已存在该文件夹确信要覆盖吗？'') thenFileDeleteDirectory(tDir)else exit;end;aWaitForm := FormCreateProcessFrm(''正在复制文件，请稍候...'');tryaWaitForm.Show;Application.ProcessMessages;MyCopy(sDir, tDir);finallyConFree(aWaitForm);//先释放Form上的控件aWaitForm.Free;aWaitForm := nil;end;end;procedure MyFileCopyDirectory(sDir, tDir:string;AHandle:Thandle;Flag: integer = 0);varfromdir,todir{,dirname}:pchar;SHFileOpStruct:TSHFileOpStruct;beginGetMem(fromdir,length(sDir)+2);tryGetMem(todir,length(tdir)+2);tryFIllchar(fromdir^,length(sDir)+2,0);FIllchar(todir^,length(tDir)+2,0);strcopy(fromdir,pchar(sDir));strcopy(todir,pchar(tDir));with SHFileOpStruct dobeginwnd := AHandle;if Flag = 1 thenWFunc := FO_MOVEelseWFunc := FO_COPY;//该参数指明shFileOperation函数将执行目录的拷贝pFrom:=fromdir;pTO:=todir;fFlags:=FOF_NOCONFIRMATION OR FOF_RENAMEONCOLLISION;fAnyOperationsAborted:=false;hnamemappings:=nil;lpszprogresstitle:=nil;end;if shFileOperation(SHFileOpStruct)<>0 thenRaiselastwin32Error;finallyFreeMem(todir,length(tDir)+2);end;finallyFreeMem(fromdir,length(sDir)+2);end;end;procedure TPub.FileMoveDirectory(sDir, tDir:string;AHandle:Thandle);varfromdir,todir{,dirname}:pchar;SHFileOpStruct:TSHFileOpStruct;begin// 调用shFileOperation函数可以实现对目录的拷贝、移动、重命名或删除操作if not DirectoryExists(sDir) thenbeginMsgBox(''不存在源路径“'' + sDir + ''”，移动数据失败！'');exit;end;if DirectoryExists(tDir) thenbeginif Pub.MsgYesNoBox(''已存在该文件夹确信要覆盖吗？'') thenFileDeleteDirectory(tDir)else exit;end elseif 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) thenbeginMsgBox(''不存在源路径“'' + sDir + ''”，复制失败！'');exit;end;if DirectoryExists(tDir) thenbeginif Pub.MsgYesNoBox(''已存在该文件夹确信要覆盖吗？'') thenFileDeleteDirectory(tDir)else exit;end elseif not MsgYesNoBox(''不存在目标路径“'' + tDir + ''”，要创建吗？'') then exit;ForceDirectories(tDir);MyFileCopyDirectory(sDir, tDir, AHandle);end;//以下网络function TPub.NetJudgeOnline: boolean;varb: array[0..4] of Byte;beginwith TRegistry.Create dotryRootKey := HKEY_LOCAL_MACHINE;OpenKey(''System/CurrentControlSet/Services/RemoteAccess'',False);ReadBinaryData(''Remote Connection'',b,4);finallyFree;end;if b[0]=0 thenResult := trueelseResult := false;end;{=================================================================功 能: 检测机器是否登入网络参 数: 无返回值: 成功: True 失败: False备 注:版 本:1.0 2002/10/03 09:55:00=================================================================}Function TPub.NetCheckMacAttachNet: Boolean;beginResult := 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;varHostEnt: PHostEnt;Ip: string;addr: pchar;Buffer: array [0..63] of char;GInitData: TWSADATA;beginResult := False;tryWSAStartup(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;finallyWSACleanup;end;end;{=================================================================功 能: 通过Ip返回机器名参 数:IpAddr: 想要得到名字的Ip返回值: 成功: 机器名 失败: ''''备 注:inet_addr function converts a string containing an InternetProtocol dotted address into an in_addr.版 本:1.0 2002/10/02 22:09:00=================================================================}function TPub.NetGetNameByIPAddr(IPAddr : String;var MacName:String): Boolean;varSockAddrIn: TSockAddrIn;HostEnt: PHostEnt;WSAData: TWSAData;beginResult := False;if IpAddr = '''' then exit;tryWSAStartup(2, WSAData);SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);if HostEnt <> nil thenMacName := StrPas(Hostent^.h_name);Result := True;finallyWSACleanup;end;end;Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:52:00 得分:0 {=================================================================功 能: 返回网络中SQLServer列表参 数:List: 需要填充的List返回值: 成功: True,并填充List 失败 False备 注:版 本:1.0 2002/10/02 22:44:00=================================================================}Function TPub.NetGetSQLServerList(var List: Tstringlist): boolean;vari: integer;SQLServer: Variant;ServerList: Variant;beginResult := False;List.Clear;trySQLServer := CreateOleObject(''SQLDMO.Application'');ServerList := SQLServer.ListAvailableSQLServers;for i := 1 to Serverlist.Count dolist.Add (Serverlist.item(i));Result := True;FinallySQLServer := NULL;ServerList := NULL;end;end;{=================================================================功 能: 判断Ip协议有没有安装参 数: 无返回值: 成功: True 失败: False;备 注: 该函数还有问题版 本:1.0 2002/10/02 21:05:00=================================================================}Function TPub.NetIsIPInstalled : boolean;varWSData: TWSAData;ProtoEnt: PProtoEnt;beginResult := True;tryif WSAStartup(2,WSData) = 0 thenbeginProtoEnt := GetProtoByName(''IP'');if ProtoEnt = nil thenResult := Falseend;finallyWSACleanup;end;end;{=================================================================功 能: 返回网络中的共享资源参 数:IpAddr: 机器IpList: 需要填充的List返回值: 成功: True,并填充List 失败: False;备 注:WNetOpenEnum function starts an enumeration of networkresources or existing connections.WNetEnumResource function continues a network-resourceenumeration started by the WNetOpenEnum function.版 本:1.0 2002/10/03 07:30:00=================================================================}Function TPub.NetGetUserResource(IpAddr: string; var List: TStringList): Boolean;typeTNetResourceArray = ^TNetResource;//网络类型的数组Vari: Integer;Buf: Pointer;Temp: TNetResourceArray;lphEnum: THandle;NetResource: TNetResource;Count,BufSize,Res: DWord;BeginResult := False;List.Clear;if copy(Ipaddr,0,2) <> ''//'' thenIpAddr := ''//''+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//列举指定工作组的网络资源beginCount := $FFFFFFFF;//不限资源数目BufSize := 8192;//缓冲区大小设置为8KGetMem(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 dobegin//获取指定计算机中的共享资源名称，+2表示删除"//"，//如//192.168.0.1 => 192.168.0.1List.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=================================================================}Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:52:56 得分:0 Function TPub.NetGetGroupList( var List : TStringList ) : Boolean;typeTNetResourceArray = ^TNetResource;//网络类型的数组VarNetResource: TNetResource;Buf: Pointer;Count,BufSize,Res: DWORD;lphEnum: THandle;p: TNetResourceArray;i,j: SmallInt;NetworkTypeList: TList;BeginResult := 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;//缓冲区大小设置为8KGetMem(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//记录各个网络类型的信息beginNetworkTypeList.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//列举一个网络类型的所有工作组的信息beginCount := $FFFFFFFF;//不限资源数目BufSize := 8192;//缓冲区大小设置为8KGetMem(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//列举各个工作组的信息beginList.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;typeTNetResourceArray = ^TNetResource;//网络类型的数组Vari: Integer;Buf: Pointer;Temp: TNetResourceArray;lphEnum: THandle;NetResource: TNetResource;Count,BufSize,Res: DWord;beginResult := 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//列举指定工作组的网络资源beginCount := $FFFFFFFF;//不限资源数目BufSize := 8192;//缓冲区大小设置为8KGetMem(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=>wangfajunList.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;typeTNetResourceArray = ^TNetResource;//网络类型的数组Varp: TNetResourceArray;Buf: Pointer;i: SmallInt;lphEnum: THandle;NetResource: TNetResource;Count,BufSize,Res: DWORD;beginResult := False;List.Clear;Res := WNetOpenEnum( RESOURCE_GLOBALNET, RESOURCETYPE_DISK,RESOURCEUSAGE_CONTAINER, Nil,lphEnum);if Res <> NO_ERROR then exit;//执行失败Count := $FFFFFFFF;//不限资源数目BufSize := 8192;//缓冲区大小设置为8KGetMem(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//记录各个网络类型的信息beginList.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;varRes: Dword;beginResult := 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=================================================================}Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:53:16 得分:0 Function TPub.NetCheckNet(IpAddr: string): Boolean;typePIPOptionInformation = ^TIPOptionInformation;TIPOptionInformation = packed recordTTL: 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 bufferend;PIcmpEchoReply = ^TIcmpEchoReply;TIcmpEchoReply = packed recordAddress: DWord; // replying addressStatus: DWord; // IP status value (see below)RTT: DWord; // Round Trip Time in millisecondsDataSize: Word; // reply data sizeReserved: Word;Data: Pointer; // pointer to reply data bufferOptions: TIPOptionInformation; // reply optionsend;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;constSize = 32;TimeOut = 1000;varwsadata: TWSAData;Address: DWord; // Address of host to contactHostName, HostIP: String; // Name and dotted IP of host to contactPhe: PHostEnt; // HostEntry buffer for name lookupBufferSize, nPkts: Integer;pReqData, pData: Pointer;pIPE: PIcmpEchoReply; // ICMP Echo reply bufferIPOpt: TIPOptionInformation; // IP Options for packet to sendconstIcmpDLL = ''icmp.dll'';varhICMPlib: HModule;IcmpCreateFile : TIcmpCreateFile;IcmpCloseHandle: TIcmpCloseHandle;IcmpSendEcho: TIcmpSendEcho;hICMP: THandle; // Handle for the ICMP Callsbegin// initialise winsockResult:=True;if WSAStartup(2,wsadata) <> 0 then beginResult:=False;halt;end;// register the icmp.dll stuffhICMPlib := 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 beginResult:=False;halt;end;hICMP := IcmpCreateFile;if hICMP = INVALID_HANDLE_VALUE then beginResult:=False;halt;end;end else beginResult:=False;halt;end;// ------------------------------------------------------------Address := inet_addr(PChar(IpAddr));if (Address = INADDR_NONE) then beginPhe := GetHostByName(PChar(IpAddr));if Phe = Nil then Result:=Falseelse beginAddress := longint(plongint(Phe^.h_addr_list^)^);HostName := Phe^.h_name;HostIP := StrPas(inet_ntoa(TInAddr(Address)));end;endelse beginPhe := GetHostByAddr(@Address, 4, PF_INET);if Phe = Nil then Result:=False;end;if Address = INADDR_NONE thenbeginResult:=False;end;// Get some data buffer space and put something in the packet to sendBufferSize := SizeOf(TICMPEchoReply) + Size;GetMem(pReqData, Size);GetMem(pData, Size);GetMem(pIPE, BufferSize);FillChar(pReqData^, Size, $AA);pIPE^.Data := pData;// Finally Send the packetFillChar(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 buffersFreeMem(pIPE); FreeMem(pData); FreeMem(pReqData);// --------------------------------------------------------------IcmpCloseHandle(hICMP);FreeLibrary(hICMPlib);// free winsockif WSACleanup <> 0 then Result:=False;end;Top 回复人： huojiehai(海天子) ( ) 信誉：121 2003-4-13 22:53:42 得分:0 {=================================================================功 能: 检测计算机是否上网参 数: 无返回值: 成功: 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;vardwConnectionTypes : DWORD;begindwConnectionTypes := INTERNET_CONNECTION_LAN+INTERNET_CONNECTION_MODEM+INTERNET_CONNECTION_PROXY;//Result := InternetGetConnectedState(@dwConnectionTypes, 1);Result := InternetGetConnectedState(@dwConnectionTypes, 0);end;{等待窗口起}procedure TPub.ProcessTimer1Timer(Sender: TObject);varaForm: TForm;pr: TFlatProgressBar;lb: TLabel;aStr: String;beginaForm := 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 thenlb.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 thenpr.Position := 0;end;function TPub.FormCreateProcessFrm(MsgTitle: string): TForm;varPanel1, Panel2: TPanel;Label1, Label2, Label3: TLabel;FlatProgressBar1: TFlatProgressBar;Timer1: TTimer;beginResult := 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);varlp: integer;beginfor lp := aCon.ComponentCount - 1 Downto 0 doaCon.Components[lp].Free;end;function TPub.CheckMailAddress(Text: string): boolean;varIndex: integer;lp: integer;beginResult := 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) doif (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;beginResult := ExtractFilePath(ParamStr(0)) + FileName;end;initializationPub := TPub.Create;finalizationPub.Free;end.
