公用函数(博客用户)

使用方法, 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.