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;