收集整理的Delphi强大函数

{*******************************************************} { }

{ Delphi公用函数单元 } { }

{ 版权所有 (C) 2008 勇者工作室 } { }

{*******************************************************} unit YzDelphiFunc; interface uses

ComCtrls, Forms, Windows, Classes, SysUtils, ComObj, ActiveX, ShlObj, Messages, Graphics, Registry, Dialogs, Controls, uProcess, uCpuUsage, StrUtils, CommCtrl, jpeg, WinInet, ShellAPI, SHFolder, ADODB, WinSock; { 保存日志文件 }

procedure YzWriteLogFile(Msg: String); { 延时函数,单位为毫秒 }

procedure YzDelayTime(MSecs: Longint); { 判断字符串是否为数字 }

function YzStrIsNum(Str: string):boolean; { 判断文件是否正在使用 }

function YzIsFileInUse(fName: string): boolean; { 删除字符串列表中的空字符串 }

procedure YzDelEmptyChar(AList: TStringList); { 删除文件列表中的\文件 } procedure YzDelThumbsFile(AList: TStrings); { 返回一个整数指定位数的带\字符串 }

function YzIntToZeroStr(Value, ALength: Integer): string;

{ 取日期年份分量 }

function YzGetYear(Date: TDate): Integer; { 取日期月份分量 }

function YzGetMonth(Date: TDate): Integer; { 取日期天数分量 }

function YzGetDay(Date: TDate): Integer; { 取时间小时分量 }

function YzGetHour(Time: TTime): Integer; { 取时间分钟分量 }

function YzGetMinute(Time: TTime): Integer; { 取时间秒钟分量 }

function YzGetSecond(Time: TTime): Integer; { 返回时间分量字符串 }

function YzGetTimeStr(ATime: TTime;AFlag: string): string; { 返回日期时间字符串 }

function YzGetDateTimeStr(ATime: TTime;ADate: TDate): string; { 获取计算机名称 }

function YzGetComputerName(): string; { 通过窗体子串查找窗体 }

procedure YzFindSpecWindow(ASubTitle: string); { 判断进程CPU占用率 }

procedure YzJudgeCPU(ProcessName: string;CPUUsage: Single); { 分割字符串 }

procedure YzSeparateTerms(Source: string;Separator: Char;Terms: TStringList); { 切换页面控件的活动页面 }

procedure YzGotoNewPage(AOwerPage: TPageControl;ANewPage: TTabSheet);

{ 设置页面控件标签的可见性 }

procedure YzSetTableVisible(PageControl: TPageControl;ShowFlag: Boolean); { 根据产品名称获取产品编号 }

function YzGetLevelCode(AName:string;ProductList: TStringList): string; { 取文件的主文件名 }

function YzGetMainFileName(AFileName: string): string; { 按下一个键 }

procedure YzPressOneKey(AByteCode: Byte);overload; { 按下一个指定次数的键 }

procedure YzPressOneKey(AByteCode: Byte;ATimes: Integer);overload; { 按下二个键 }

procedure YzPressTwoKeys(AFirstByteCode, ASecByteCode: Byte); { 按下三个键 }

procedure YzPressThreeKeys(AFirstByteCode, ASecByteCode, AThirdByteCode: Byte); { 创建桌面快捷方式 }

procedure YzCreateShortCut(const sPath: string; sShortCutName: WideString); { 删除桌面快捷方式 }

procedure YzDeleteShortCut(sShortCutName: WideString); { 通过光标位置进行鼠标左键单击 }

procedure YzMouseLeftClick(X, Y: Integer);overload; { 鼠标左键双击 }

procedure YzMouseDoubleClick(X, Y: Integer); { 通过窗口句柄进行鼠标左键单击 }

procedure YzMouseLeftClick(lpClassName, lpWindowName: PAnsiChar);overload; { 通过光标位置查找窗口句柄 }

function YzWindowFromPoint(X, Y: Integer): THandle;

{ 等待窗口在指定时间后出现 }

function YzWaitWindowExist(lpClassName, lpWindowName: PAnsiChar; ASecond: Integer = 0): THandle;overload; { 通光标位置,窗口类名与标题查找窗口是否存在 }

function YzWaitWindowExist(X, Y: Integer;AClassName, AWinName: string; ASecond: Integer = 0):THandle; overload; { 等待指定窗口消失 }

procedure YzWaitWindowClose(lpClassName, lpWindowName: PAnsiChar; ASecond: Integer = 0);

{ 通过窗口句柄设置文本框控件文本 }

procedure YzSetEditText(lpClassName, lpWindowName: PAnsiChar; AText: string);overload;

{ 通过光标位置设置文本框控件文本 }

procedure YzSetEditText(X, Y: Integer;AText: string);overload; { 获取Window操作系统语言 }

function YzGetWindowsLanguageStr: String; { 清空动态数组 }

procedure YzDynArraySetZero(var A); { 动态设置屏幕分辨率 }

function YzDynamicResolution(X, Y: WORD): Boolean; { 检测系统屏幕分辨率 }

function YzCheckDisplayInfo(X, Y: Integer): Boolean; type

TFontedControl = class(TControl) public

property Font; end;

TFontMapping = record SWidth : Integer;

SHeight: Integer; FName: string; FSize: Integer; end;

procedure YzFixForm(AForm: TForm); procedure YzSetFontMapping; {---------------------------------------------------

以下是关于获取系统软件卸载的信息的类型声明和函数 ----------------------------------------------------} type

TUninstallInfo = array of record RegProgramName: string; ProgramName : string; UninstallPath : string; Publisher : string; PublisherURL : string; Version : string; HelpLink : string; UpdateInfoURL : string; RegCompany : string; RegOwner : string; end;

{ GetUninstallInfo 返回系统软件卸载的信息 } function YzGetUninstallInfo : TUninstallInfo; { 检测Java安装信息 }

function YzCheckJavaInfo(AUninstallInfo: TUninstallInfo;CheckJava6 : Boolean = False): Boolean;

{ 窗口自适应屏幕大小 }

procedure YzAdjustForm(Form: TForm;const OrgWidth, OrgHeight: integer); { 设置窗口为当前窗体 }

procedure YzBringMyAppToFront(AppHandle: THandle);

dwCSize := MAX_COMPUTERNAME_LENGTH + 1; Result := '';

GetMem(pcComputer, dwCSize); try

if Windows.GetComputerName(pcComputer, dwCSize) then Result := pcComputer; finally

FreeMem(pcComputer); end; end;

{ 判断进程CPU占用率 }

procedure YzJudgeCPU(ProcessName: string;CPUUsage: Single); var

cnt: PCPUUsageData; usage: Single; begin

cnt := wsCreateUsageCounter(FindProcess(ProcessName)); while True do begin

usage := wsGetCpuUsage(cnt); if usage <= CPUUsage then begin

wsDestroyUsageCounter(cnt); YzDelayTime(2000); Break; end;

YzDelayTime(10);

Application.ProcessMessages; end; end;

{ 分割字符串 }

procedure YzSeparateTerms(Source: string;Separator: Char;Terms: TStringList); var

TmpStr: string;

PO: integer; begin

Terms.Clear;

if Length(Source) = 0 then Exit; { 长度为0则退出 } PO := Pos(Separator, Source); if PO = 0 then begin

Terms.Add(Source); Exit; end;

while PO <> 0 do begin

TmpStr := Copy(Source, 1, PO - 1);{ 复制字符 } Terms.Add(TmpStr); { 添加到列表 } Delete(Source, 1, PO); { 删除字符和分割符 } PO := Pos(Separator, Source); { 查找分割符 } end;

if Length(Source) > 0 then

Terms.Add(Source); { 添加剩下的条目 } end;

{ 切换页面控件的活动页面 }

procedure YzGotoNewPage(AOwerPage: TPageControl;ANewPage: TTabSheet); begin

if AOwerPage.ActivePage <> ANewPage then AOwerPage.ActivePage := ANewPage; end;

{ 设置页面控件标签的可见性 }

procedure YzSetTableVisible(PageControl: TPageControl;ShowFlag: Boolean); var I: Integer; begin

for I := 0 to PageControl.PageCount -1 do PageControl.Pages[I].TabVisible := ShowFlag; end;

{ 根据产品名称获取产品编号 }

function YZGetLevelCode(AName:string;ProductList: TStringList): string; var I: Integer; TmpStr: string; begin Result := '';

if ProductList.Count <= 0 then Exit; for I := 0 to ProductList.Count-1 do begin

TmpStr := ProductList.Strings[I];

if AName = Copy(TmpStr,1, Pos('_', TmpStr)-1) then begin

Result := Copy(TmpStr, Pos('_', TmpStr)+1, 10); Break; end; end; end;

{ 取文件的主文件名 }

function YzGetMainFileName(AFileName:string): string; var

TmpStr: string; begin

if AFileName = '' then Exit;

TmpStr := ExtractFileName(AFileName); Result := Copy(TmpStr, 1, Pos('.', TmpStr) - 1); end;

{ 按下一个键 }

procedure YzPressOneKey(AByteCode: Byte); begin

keybd_event(AByteCode, 0, 0, 0); YzDelayTime(100);

keybd_event(AByteCode, 0, KEYEVENTF_KEYUP, 0);

YzDelayTime(400); end;

{ 按下一个指定次数的键 }

procedure YzPressOneKey(AByteCode: Byte;ATimes: Integer);overload; var I: Integer; begin

for I := 1 to ATimes do begin

keybd_event(AByteCode, 0, 0, 0); YzDelayTime(10);

keybd_event(AByteCode, 0, KEYEVENTF_KEYUP, 0); YzDelayTime(150); end; end;

{ 按下二个键 }

procedure YzPressTwoKeys(AFirstByteCode, ASecByteCode: Byte); begin

keybd_event(AFirstByteCode, 0, 0, 0); keybd_event(ASecByteCode, 0, 0, 0); YzDelayTime(100);

keybd_event(ASecByteCode, 0, KEYEVENTF_KEYUP, 0); keybd_event(AFirstByteCode, 0, KEYEVENTF_KEYUP, 0); YzDelayTime(400); end;

{ 按下三个键 }

procedure YzPressThreeKeys(AFirstByteCode, ASecByteCode, AThirdByteCode: Byte); begin

keybd_event(AFirstByteCode, 0, 0, 0); keybd_event(ASecByteCode, 0, 0, 0); keybd_event(AThirdByteCode, 0, 0, 0); YzDelayTime(100);

keybd_event(AThirdByteCode, 0, KEYEVENTF_KEYUP, 0);

keybd_event(ASecByteCode, 0, KEYEVENTF_KEYUP, 0); keybd_event(AFirstByteCode, 0, KEYEVENTF_KEYUP, 0); YzDelayTime(400); end;

{ 创建桌面快捷方式 }

procedure YzCreateShortCut(const sPath: string; sShortCutName: WideString); var

tmpObject: IUnknown; tmpSLink: IShellLink; tmpPFile: IPersistFile; PIDL: PItemIDList;

StartupDirectory: array[0..MAX_PATH] of Char; StartupFilename: String; LinkFilename: WideString; begin

StartupFilename := sPath;

tmpObject := CreateComObject(CLSID_ShellLink); { 创建建立快捷方式的外壳扩展 } tmpSLink := tmpObject as IShellLink; { 取得接口 }

tmpPFile := tmpObject as IPersistFile; { 用来储存*.lnk文件的接口 } tmpSLink.SetPath(pChar(StartupFilename)); { 设定notepad.exe所在路径 } tmpSLink.SetWorkingDirectory(pChar(ExtractFilePath(StartupFilename))); {设定工作目录 }

SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, PIDL); { 获得桌面的Itemidlist }

SHGetPathFromIDList(PIDL, StartupDirectory); { 获得桌面路径 } sShortCutName := '/' + sShortCutName + '.lnk'; LinkFilename := StartupDirectory + sShortCutName;

tmpPFile.Save(pWChar(LinkFilename), FALSE); { 保存*.lnk文件 } end;

{ 删除桌面快捷方式 }

procedure YzDeleteShortCut(sShortCutName: WideString); var

PIDL : PItemIDList;

StartupDirectory: array[0..MAX_PATH] of Char;

end; end;

{ 获取程序可执行文件名 } function YzGetExeFName: string; begin

Result := ExtractFileName(Application.ExeName); end;

{ 目录浏览对话框函数 }

function YzBrowseFolder(AOwer: TWinControl;ATitle: string):string; var

Info: TBrowseInfo; Dir: array[0..260] of char; ItemId: PItemIDList; begin with Info do begin

hwndOwner := AOwer.Handle; pidlRoot := nil; pszDisplayName := nil; lpszTitle := PChar(ATitle); ulFlags := 0; lpfn := nil; lParam := 0; iImage := 0; end;

ItemId := SHBrowseForFolder(Info); SHGetPathFromIDList(ItemId,@Dir); Result := string(Dir); end;

{ 重启计算机 }

function YzShutDownSystem(AFlag: Integer):BOOL; var

hProcess,hAccessToken: THandle;

LUID_AND_ATTRIBUTES: TLUIDAndAttributes; TOKEN_PRIVILEGES: TTokenPrivileges; BufferIsNull: DWORD; Const

SE_SHUTDOWN_NAME='SeShutdownPrivilege'; begin

hProcess:=GetCurrentProcess();

OpenProcessToken(hprocess, TOKEN_ADJUST_PRIVILEGES+TOKEN_QUERY, hAccessToken);

LookupPrivilegeValue(Nil, SE_SHUTDOWN_NAME, LUID_AND_ATTRIBUTES.Luid); LUID_AND_ATTRIBUTES.Attributes := SE_PRIVILEGE_ENABLED; TOKEN_PRIVILEGES.PrivilegeCount := 1;

TOKEN_PRIVILEGES.Privileges[0] := LUID_AND_ATTRIBUTES; BufferIsNull := 0;

AdjustTokenPrivileges(hAccessToken, False, TOKEN_PRIVILEGES, sizeof( TOKEN_PRIVILEGES) ,Nil, BufferIsNull); Result := ExitWindowsEx(AFlag, 0); end;

{ 程序运行后删除自身 } procedure YzDeleteSelf; var

hModule: THandle;

buff: array[0..255] of Char; hKernel32: THandle;

pExitProcess, pDeleteFileA, pUnmapViewOfFile: Pointer; begin

hModule := GetModuleHandle(nil);

GetModuleFileName(hModule, buff, sizeof(buff)); CloseHandle(THandle(4));

hKernel32 := GetModuleHandle('KERNEL32');

pExitProcess := GetProcAddress(hKernel32, 'ExitProcess');

pDeleteFileA := GetProcAddress(hKernel32, 'DeleteFileA');

pUnmapViewOfFile := GetProcAddress(hKernel32, 'UnmapViewOfFile'); asm

LEA EAX, buff PUSH 0 PUSH 0 PUSH EAX PUSH pExitProcess PUSH hModule PUSH pDeleteFileA PUSH pUnmapViewOfFile RET end; end; { 程序重启 }

procedure YzAppRestart; var

AppName : PChar; begin

AppName := PChar(Application.ExeName) ;

ShellExecute(Application.Handle,'open', AppName, nil, nil, SW_SHOWNORMAL); KillByPID(GetCurrentProcessId); end;

{ 压缩Access数据库 }

function YzCompactAccessDB(const AFileName, APassWord: string): Boolean; var

SPath, FConStr, TmpConStr: string; SFile: array[0..254] of Char; STempFileName: string; JE: OleVariant;

function GetTempDir: string; var

Buffer: array[0..MAX_PATH] of Char;

begin

ZeroMemory(@Buffer, MAX_PATH); GetTempPath(MAX_PATH, Buffer);

Result := IncludeTrailingBackslash(StrPas(Buffer)); end; begin

Result := False;

SPath := GetTempDir; { 取得Windows的Temp路径 } { 取得Temp文件名,Windows将自动建立0字节文件 } GetTempFileName(PChar(SPath), '~ACP', 0, SFile); STempFileName := SFile;

{ 删除Windows建立的0字节文件 } if not DeleteFile(STempFileName) then Exit; try

JE := CreateOleObject('JRO.JetEngine'); { 压缩数据库 }

FConStr := 'Provider=Microsoft.Jet.OLEDB.4.0;' + 'Data Source=' + AFileName + ';Jet OLEDB:DataBase PassWord=' + APassWord;

TmpConStr := 'Provider=Microsoft.Jet.OLEDB.4.0;' + 'Data Source=' + STempFileName

+ ';Jet OLEDB:DataBase PassWord=' + APassWord; JE.CompactDatabase(FConStr, TmpConStr); { 覆盖源数据库文件 }

Result := CopyFile(PChar(STempFileName), PChar(AFileName), False); { 删除临时文件 }

DeleteFile(STempFileName); except

Application.MessageBox('压缩数据库失败！', '提示', MB_OK + MB_ICONINFORMATION); end; end;

{ 标题:获取其他进程中TreeView的文本 }

function YzTreeNodeGetNext(mHandle: THandle; mTreeItem: HTreeItem): HTreeItem; var

vParentID: HTreeItem; begin Result := nil;

if (mHandle <> 0) and (mTreeItem <> nil) then begin

Result := TreeView_GetChild(mHandle, mTreeItem); if Result = nil then

Result := TreeView_GetNextSibling(mHandle, mTreeItem); vParentID := mTreeItem;

while (Result = nil) and (vParentID <> nil) do begin

vParentID := TreeView_GetParent(mHandle, vParentID); Result := TreeView_GetNextSibling(mHandle, vParentID); end; end;

end; { TreeNodeGetNext }

function YzTreeNodeGetLevel(mHandle: THandle; mTreeItem: HTreeItem): Integer; var

vParentID: HTreeItem; begin Result := -1;

if (mHandle <> 0) and (mTreeItem <> nil) then begin

vParentID := mTreeItem; repeat Inc(Result);

vParentID := TreeView_GetParent(mHandle, vParentID); until vParentID = nil; end;

end; { TreeNodeGetLevel }

begin

with TRegistry.Create do begin

S := TStringlist.Create; J := 0; try

RootKey:= HKEY_LOCAL_MACHINE; OpenKeyReadOnly(Key); GetKeyNames(S);

Setlength(Result, S.Count); for I:= 0 to S.Count - 1 do begin

If OpenKeyReadOnly(Key + S[I]) then

If ValueExists('DisplayName') and ValueExists('UninstallString') then begin

Result[J].RegProgramName:= S[I];

Result[J].ProgramName:= ReadString('DisplayName'); Result[J].UninstallPath:= ReadString('UninstallString'); If ValueExists('Publisher') then

Result[J].Publisher:= ReadString('Publisher'); If ValueExists('URLInfoAbout') then

Result[J].PublisherURL:= ReadString('URLInfoAbout'); If ValueExists('DisplayVersion') then

Result[J].Version:= ReadString('DisplayVersion'); If ValueExists('HelpLink') then

Result[J].HelpLink:= ReadString('HelpLink'); If ValueExists('URLUpdateInfo') then

Result[J].UpdateInfoURL:= ReadString('URLUpdateInfo'); If ValueExists('RegCompany') then

Result[J].RegCompany:= ReadString('RegCompany'); If ValueExists('RegOwner') then

Result[J].RegOwner:= ReadString('RegOwner'); Inc(J); end; end;

finally Free; S.Free;

SetLength(Result, J); end; end; end;

{ 检测Java安装信息 }

function YzCheckJavaInfo(AUninstallInfo: TUninstallInfo;CheckJava6 : Boolean = False): Boolean; var I: Integer;

Java6Exist: Boolean; AUninstall: TUninstallInfo; AProgramList: TStringList; AJavaVersion, AFilePath: string; begin

Result := True; Java6Exist := False;

AJavaVersion := 'J2SE Runtime Environment 5.0 Update 14'; AUninstall := YzGetUninstallInfo; AProgramList := TStringList.Create;

for I := Low(AUninstall) to High(AUninstall) do begin

if Pos('J2SE', AUninstall[I].ProgramName) <> 0 then AProgramList.Add(AUninstall[I].ProgramName); if Pos('Java(TM)', AUninstall[I].ProgramName) <> 0 then Java6Exist := True; end;

if Java6Exist then begin

if CheckJava6 then begin

MessageBox(Application.Handle, '系统检测到您机器上安装了Java6以上的版本，' + '如果影响到系统的正常运行请先将其卸载再重新启动系统！', '提示',

MB_OK + MB_ICONINFORMATION + MB_TOPMOST); Result := False; end; end

else if AProgramList.Count = 0 then begin

MessageBox(Application.Handle, '系统检测到您机器上没有安装Java运行环境，' + '请点击 \确定\安装Java运行环境后再重新运行程序！', '提示', MB_OK + MB_ICONINFORMATION + MB_TOPMOST); AFilePath := ExtractFilePath(ParamStr(0)) + 'java' + '/' + 'jre-1_5_0_14-windows-i586-p.exe';

if FileExists(AFilePath) then WinExec(PChar(AFilePath), SW_SHOWNORMAL) else

MessageBox(Application.Handle, '找不到Java安装文件，请您手动安装！', '提示', MB_OK + MB_ICONINFORMATION + MB_TOPMOST); Result := False; end;

AProgramList.Free; end;

{------------------------------------------------------------- 功能: 窗口自适应屏幕大小 参数: Form: 需要调整的Form OrgWidth：开发时屏幕的宽度 OrgHeight：开发时屏幕的高度

--------------------------------------------------------------}

procedure YzAdjustForm(Form: TForm;const OrgWidth, OrgHeight: integer); begin

with Form do begin

if (Screen.width <> OrgWidth) then begin

Scaled := True;

Height := longint(Height) * longint(Screen.height) div OrgHeight; Width := longint(Width) * longint(Screen.Width) div OrgWidth;

ScaleBy(Screen.Width, OrgWidth); end; end; end;

{ 设置窗口为当前窗体 }

procedure YzBringMyAppToFront(AppHandle: THandle); var

Th1, Th2: Cardinal; begin

Th1 := GetCurrentThreadId;

Th2 := GetWindowThreadProcessId(GetForegroundWindow, NIL); AttachThreadInput(Th2, Th1, TRUE); try

SetForegroundWindow(AppHandle); finally

AttachThreadInput(Th2, Th1, TRUE); end; end;

{ 获取文件夹文件数量 }

function YzGetDirFiles(Dir: string;SubDir: Boolean): LongInt; var

SearchRec: TSearchRec; Founded: integer; begin Result := 0;

if Dir[length(Dir)] <> '/' then Dir := Dir + '/';

Founded := FindFirst(Dir + '*.*', faAnyFile, SearchRec); while Founded = 0 do begin Inc(Result);

if (SearchRec.Attr and faDirectory > 0) and (SearchRec.Name[1] <> '.') and (SubDir = True) then

Inc(Result, YzGetDirFiles(Dir + SearchRec.Name, True)); Founded := FindNext(SearchRec);

end;

FindClose(SearchRec); end;

{ 算术舍入法的四舍五入取整函数 }

function YzRoundEx (const Value: Real): LongInt; var x: Real; begin

x := Value - Trunc(Value); if x >= 0.5 then

Result := Trunc(Value) + 1 else Result := Trunc(Value); end;

{ 获取文件大小(KB) }

function YzGetFileSize(const FileName: String): LongInt; var

SearchRec: TSearchRec; begin

if FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec) = 0 then Result := SearchRec.Size else

Result := -1;

Result := YzRoundEx(Result / 1024); end;

{ 获取文件大小(字节) }

function YzGetFileSize_Byte(const FileName: String): LongInt; var

SearchRec: TSearchRec; begin

if FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec) = 0 then Result := SearchRec.Size else

Result := -1; end;

{ 获取文件夹大小 }

function YzGetDirSize(Dir: string;SubDir: Boolean): LongInt; var

SearchRec: TSearchRec; Founded: integer; begin Result := 0;

if Dir[length(Dir)] <> '/' then Dir := Dir + '/';

Founded := FindFirst(Dir + '*.*', faAnyFile, SearchRec); while Founded = 0 do begin

Inc(Result, SearchRec.size);

if (SearchRec.Attr and faDirectory > 0) and (SearchRec.Name[1] <> '.') and (SubDir = True) then

Inc(Result, YzGetDirSize(Dir + SearchRec.Name, True)); Founded := FindNext(SearchRec); end;

FindClose(SearchRec);

Result := YzRoundEx(Result / 1024); end;

{------------------------------------------------------------- 功能: 弹出选择目录对话框 参数: const iMode: 选择模式 const sInfo: 对话框提示信息

返回值: 如果取消取返回为空，否则返回选中的路径 --------------------------------------------------------------}

function YzSelectDir(const iMode: integer;const sInfo: string): string; var

Info: TBrowseInfo; IDList: pItemIDList; Buffer: PChar; begin

Result:='';

Buffer := StrAlloc(MAX_PATH); with Info do begin

hwndOwner := application.mainform.Handle; { 目录对话框所属的窗口句柄 } pidlRoot := nil; { 起始位置，缺省为我的电脑 } pszDisplayName := Buffer; { 用于存放选择目录的指针 } lpszTitle := PChar(sInfo);

{ 此处表示显示目录和文件，如果只显示目录则将后一个去掉即可 } if iMode = 1 then

ulFlags := BIF_RETURNONLYFSDIRS or BIF_BROWSEINCLUDEFILES else

ulFlags := BIF_RETURNONLYFSDIRS;

lpfn := nil; { 指定回调函数指针 } lParam := 0; { 传递给回调函数参数 } IDList := SHBrowseForFolder(Info); { 读取目录信息 } end;

if IDList <> nil then begin

SHGetPathFromIDList(IDList, Buffer); { 将目录信息转化为路径字符串 } Result := strpas(Buffer); end;

StrDispose(buffer); end;

{ 获取指定路径下文件夹的个数 }

procedure YzListFolders(const Path: String; const ShowPath: Boolean;var List: TStrings); var

SRec: TSearchRec; begin

if not Assigned(List) then List:= TStringList.Create; FindFirst(Path + '*.*', faDirectory, SRec); if ShowPath then

List.Add(Path + SRec.Name) else

List.Add(SRec.Name);

while FindNext(SRec) = 0 do if ShowPath then

List.Add(Path + SRec.Name) else

List.Add(SRec.Name); FindClose(SRec); end;

{ 禁用窗器控件的所有子控件 }

procedure YzSetSubCtlState(AOwer: TWinControl;AState: Boolean); var I: Integer; begin

for I := 0 to AOwer.ControlCount - 1 do AOwer.Controls[I].Enabled := AState; end;

{ 模拟键盘按键操作(处理字节码) } procedure YzFKeyent(byteCard: byte); var

vkkey: integer; begin

vkkey := VkKeyScan(chr(byteCard)); if (chr(byteCard) in ['A'..'Z']) then begin

keybd_event(VK_SHIFT, 0, 0, 0); keybd_event(byte(byteCard), 0, 0, 0); keybd_event(VK_SHIFT, 0, 2, 0); end

else if chr(byteCard) in ['!', '@', '#', '$', '%', '^', '&', '*', '(', ')', '_', '+', '|', '{', '}', ':', '\ begin

keybd_event(VK_SHIFT, 0, 0, 0); keybd_event(byte(vkkey), 0, 0, 0); keybd_event(VK_SHIFT, 0, 2, 0); end

else { if byteCard in [8,13,27,32] } begin

keybd_event(byte(vkkey), 0, 0, 0); end; end;

{ 模拟键盘按键(处理字符) }

procedure YzFKeyent(strCard: string); var str: string; strLength: integer; I: integer; byteSend: byte; begin

str := strCard;

strLength := length(str); for I := 1 to strLength do begin

byteSend := byte(str[I]); YzFKeyent(byteSend); end; end;

{ 锁定窗口位置 }

procedure YzLockWindow(ClassName,WinName: PChar;poX,poY: Integer); var

CurWindow: THandle; _wndRect: TRect; begin

CurWindow := 0; while True do begin

CurWindow := FindWindow(ClassName,WinName); if CurWindow <> 0 then Break; YzDelayTime(10);

Application.ProcessMessages;

end;

GetWindowRect(CurWindow,_wndRect);

if ( _wndRect.Left <> poX) or ( _wndRect.Top <> poY) then begin

MoveWindow(CurWindow, poX, poY,

(_wndRect.Right-_wndRect.Left), (_wndRect.Bottom-_wndRect.Top), TRUE); end;

YzDelayTime(1000); end; {

注册一个DLL形式或OCX形式的OLE/COM控件 参数strOleFileName为一个DLL或OCX文件名， 参数OleAction表示注册操作类型，1表示注册，0表示卸载 返回值True表示操作执行成功，False表示操作执行失败 }

function YzRegisterOleFile (strOleFileName: STRING;OleAction: Byte): BOOLEAN; const

RegisterOle = 1; { 注册 } UnRegisterOle = 0; { 卸载 } type

TOleRegisterFunction = function: HResult; { 注册或卸载函数的原型 } var

hLibraryHandle: THandle; { 由LoadLibrary返回的DLL或OCX句柄 }

hFunctionAddress: TFarProc; { DLL或OCX中的函数句柄，由GetProcAddress返回 } RegFunction: TOleRegisterFunction; { 注册或卸载函数指针 } begin

Result := FALSE;

{ 打开OLE/DCOM文件，返回的DLL或OCX句柄 } hLibraryHandle := LoadLibrary(PCHAR(strOleFileName)); if (hLibraryHandle > 0) then { DLL或OCX句柄正确 } try

{ 返回注册或卸载函数的指针 }

if (OleAction = RegisterOle) then { 返回注册函数的指针 }

hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllRegisterServer')) { 返回卸载函数的指针 } else

hFunctionAddress := GetProcAddress(hLibraryHandle, pchar('DllUnregisterServer')); if (hFunctionAddress <> NIL) then { 注册或卸载函数存在 } begin

{ 获取操作函数的指针 }

RegFunction := TOleRegisterFunction(hFunctionAddress); { 执行注册或卸载操作，返回值>=0表示执行成功 } if RegFunction >= 0 then Result := true; end; finally

{ 关闭已打开的OLE/DCOM文件 } FreeLibrary(hLibraryHandle); end; end;

function YzListViewColumnCount(mHandle: THandle): Integer; begin

Result := Header_GetItemCount(ListView_GetHeader(mHandle)); end; { ListViewColumnCount }

function YzGetListViewText(mHandle: THandle; mStrings: TStrings): Boolean; var

vColumnCount: Integer; vItemCount: Integer; I, J: Integer;

vBuffer: array[0..255] of Char; vProcessId: DWORD; vProcess: THandle; vPointer: Pointer;

vNumberOfBytesRead: Cardinal; S: string; vItem: TLVItem;

begin

Result := False;

if not Assigned(mStrings) then Exit;

vColumnCount := YzListViewColumnCount(mHandle); if vColumnCount <= 0 then Exit;

vItemCount := ListView_GetItemCount(mHandle); GetWindowThreadProcessId(mHandle, @vProcessId);

vProcess := OpenProcess(PROCESS_VM_OPERATION or PROCESS_VM_READ or PROCESS_VM_WRITE, False, vProcessId);

vPointer := VirtualAllocEx(vProcess, nil, 4096, MEM_RESERVE or MEM_COMMIT, PAGE_READWRITE); mStrings.BeginUpdate; try

mStrings.Clear;

for I := 0 to vItemCount - 1 do begin S := '';

for J := 0 to vColumnCount - 1 do begin with vItem do begin

mask := LVIF_TEXT; iItem := I; iSubItem := J;

cchTextMax := SizeOf(vBuffer);

pszText := Pointer(Cardinal(vPointer) + SizeOf(TLVItem)); end;

WriteProcessMemory(vProcess, vPointer, @vItem, SizeOf(TLVItem), vNumberOfBytesRead);

SendMessage(mHandle, LVM_GETITEM, I, lparam(vPointer));

ReadProcessMemory(vProcess, Pointer(Cardinal(vPointer) + SizeOf(TLVItem)), @vBuffer[0], SizeOf(vBuffer), vNumberOfBytesRead); S := S + #9 + vBuffer; end;

Delete(S, 1, 1);

mStrings.Add(S); end; finally

VirtualFreeEx(vProcess, vPointer, 0, MEM_RELEASE); CloseHandle(vProcess); mStrings.EndUpdate; end;

Result := True; end; { GetListViewText } { 删除目录树 }

function YzDeleteDirectoryTree(Path: string): boolean; var

SearchRec: TSearchRec; SFI: string; begin

Result := False;

if (Path = '') or (not DirectoryExists(Path)) then exit; if Path[length(Path)] <> '/' then Path := Path + '/'; SFI := Path + '*.*';

if FindFirst(SFI, faAnyFile, SearchRec) = 0 then begin repeat begin

if (SearchRec.Name = '.') or (SearchRec.Name = '..') then Continue;

if (SearchRec.Attr and faDirectory <> 0) then begin

if not YzDeleteDirectoryTree(Path + SearchRec.name) then Result := FALSE; end else begin

FileSetAttr(Path + SearchRec.Name, 128); DeleteFile(Path + SearchRec.Name); end; end

until FindNext(SearchRec) <> 0; FindClose(SearchRec); end;

FileSetAttr(Path, 0); if RemoveDir(Path) then Result := TRUE else

Result := FALSE; end;

{ Jpg格式转换为bmp格式 }

function JpgToBmp(Jpg: TJpegImage): TBitmap; begin Result := nil; if Assigned(Jpg) then begin

Result := TBitmap.Create; Jpg.DIBNeeded; Result.Assign(Jpg); end; end;

{ 设置程序自启动函数 }

function YzSetAutoRun(AFilePath: string;AFlag: Boolean): boolean; var

AMainFName: string; Reg: TRegistry; begin

Result := true;

AMainFName := YzGetMainFileName(AFilePath); Reg := TRegistry.Create;

Reg.RootKey := HKEY_LOCAL_MACHINE; try

Reg.OpenKey('SOFTWARE/Microsoft/Windows/CurrentVersion/Run', True); if AFlag = False then { 取消自启动 } Reg.DeleteValue(AMainFName)

else { 设置自启动 }

Reg.WriteString(AMainFName, '\ except

Result := False; end;

Reg.CloseKey; Reg.Free; end;

{ 检测URL地址是否有效 }

function YzCheckUrl(url: string): Boolean; var

hSession, hfile, hRequest: HINTERNET; dwindex, dwcodelen: dword; dwcode: array[1..20] of Char; res: PChar; begin

Result := False; try

if Pos('http://',LowerCase(url)) = 0 then url := 'http://' + url; { Open an internet session }

hSession:=InternetOpen('InetURL:/1.0',INTERNET_OPEN_TYPE_PRECONFIG,nil,nil, 0);

if Assigned(hsession) then begin

hfile := InternetOpenUrl(hsession, PChar(url), nil, 0,INTERNET_FLAG_RELOAD, 0); dwIndex := 0; dwCodeLen := 10;

HttpQueryInfo(hfile,HTTP_QUERY_STATUS_CODE,@dwcode,dwcodeLen,dwIndex);

res := PChar(@dwcode);

Result := (res = '200') or (res = '302');

if Assigned(hfile) then InternetCloseHandle(hfile); InternetCloseHandle(hsession); end; except

本文来源：https://www.bwwdw.com/article/fq2v.html