CnPack开发包基础库
2024-05-18 01:51:47
unit CnCommon;
{* |<PRE>
================================================================================
* 软件名称：开发包基础库
* 单元名称：公共运行基础库单元
* 单元作者：CnPack开发组
* 备 注：该单元定义了组件包的基础类库
* 开发平台：PWin98SE + Delphi 5.0
* 兼容测试：PWin9X/2000/XP + Delphi 5/6
* 本 地 化：该单元中的字符串均符合本地化处理方式
* 单元标识：$Id: CnCommon.pas,v 1.42 2006/09/27 23:05:45 passion Exp $
* 修改记录：
* 2005.08.02 by shenloqi
* 增加了SameCharCounts，CharCounts ，RelativePath函数，重写了
* GetRelativePath函数
* 2005.07.08 by shenloqi
* 修改了GetRelativePath函数，修改了FileMatchesExts函数，增加了
* 一系列通配符支持的函数：FileNameMatch，MatchExt，MatchFileName，
* FileExtsToStrings，FileMasksToStrings，FileMatchesMasks
* 2005.05.03 by hubdog
* 增加ExploreFile函数
* 2004.09.18 by Shenloqi
* 为Delphi5增加了BoolToStr函数
* 2004.05.21 by Icebird
* 修改了函数GetLine, IsInt, IsFloat, CnDateToStr, MyDateToStr
* 2003.10.29 by Shenloqi
* 新增四个函数CheckWinXP,DllGetVersion,GetSelText,UnQuotedStr
* 2002.08.12 V1.1
* 新增一个函数 CheckAppRunning by 周劲羽
* 2002.04.09 V1.0
* 整理单元，重设版本号
* 2002.03.17 V0.02
* 新增部分函数，并部分修改
* 2002.01.30 V0.01
* 创建单元（整理而来）
================================================================================
|</PRE>}interface{$I CnPack.inc}usesWindows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,ComCtrls, Math,
{$IFDEF COMPILER6_UP}StrUtils, Variants, Types,
{$ENDIF}FileCtrl, ShellAPI, CommDlg, MMSystem, StdCtrls, TLHelp32, ActiveX, ShlObj,CnConsts, CnIni, CnIniStrUtils, CheckLst, IniFiles, MultiMon, TypInfo;//------------------------------------------------------------------------------
// 公共类型定义
//------------------------------------------------------------------------------typePRGBColor = ^TRGBColor;TRGBColor = packed recordb, g, r: Byte;end;PRGBArray = ^TRGBArray;TRGBArray = array[0..65535] of TRGBColor;const
{$IFNDEF COMPILER6_UP}sLineBreak = {$IFDEF LINUX} #10 {$ENDIF} {$IFDEF MSWINDOWS} #13#10 {$ENDIF};
{$ENDIF}Alpha = ['A'..'Z', 'a'..'z', '_'];AlphaNumeric = Alpha + ['0'..'9'];//------------------------------------------------------------------------------
// 扩展的文件目录操作函数
//------------------------------------------------------------------------------procedure ExploreDir(APath: string);
{* 在资源管理器中打开指定目录 }procedure ExploreFile(AFile: string);
{* 在资源管理器中打开指定文件 }function ForceDirectories(Dir: string): Boolean;
{* 递归创建多级子目录}function MoveFile(const sName, dName: string): Boolean;
{* 移动文件、目录，参数为源、目标名}function DeleteToRecycleBin(const FileName: string): Boolean;
{* 删除文件到回收站}procedure FileProperties(const FName: string);
{* 打开文件属性窗口}function OpenDialog(var FileName: string; Title: string; Filter: string;Ext: string): Boolean;
{* 打开文件框}function GetDirectory(const Caption: string; var Dir: string;ShowNewButton: Boolean = True): Boolean;
{* 显示选择文件夹对话框，支持设置默认文件夹}function FormatPath(APath: string; Width: Integer): string;
{* 缩短显示不下的长路径名}procedure DrawCompactPath(Hdc: HDC; Rect: TRect; Str: string);
{* 通过 DrawText 来画缩略路径}function SameCharCounts(s1, s2: string): Integer;
{* 两个字符串的前面的相同字符数}
function CharCounts(Str: PChar; Chr: Char): Integer;
{* 在字符串中某字符出现的次数}
function GetRelativePath(ATo, AFrom: string;const PathStr: string = '\'; const ParentStr: string = '..';const CurrentStr: string = '.'; const UseCurrentDir: Boolean = False): string;
{* 取两个目录的相对路径}{$IFNDEF BCB}
function PathRelativePathToA(pszPath: PAnsiChar; pszFrom: PAnsiChar; dwAttrFrom: DWORD;pszTo: PAnsiChar; dwAttrTo: DWORD): BOOL; stdcall;
function PathRelativePathToW(pszPath: PWideChar; pszFrom: PWideChar; dwAttrFrom: DWORD;pszTo: PWideChar; dwAttrTo: DWORD): BOOL; stdcall;
function PathRelativePathTo(pszPath: PChar; pszFrom: PChar; dwAttrFrom: DWORD;pszTo: PChar; dwAttrTo: DWORD): BOOL; stdcall;function RelativePath(const AFrom, ATo: string; FromIsDir, ToIsDir: Boolean): string;
{* 使用Windows API取两个目录的相对路径}
{$ENDIF}function LinkPath(const Head, Tail: string): string;
{* 连接两个路径，Head - 首路径，可以是 C:\Test、\\Test\C\Abc、http://www.abc.com/dir/ 等格式Tail - 尾路径，可以是 ..\Test、Abc\Temp、\Test、/web/lib 等格式或绝对地址格式 }procedure RunFile(const FName: string; Handle: THandle = 0;const Param: string = '');
{* 运行一个文件}procedure OpenUrl(const Url: string);
{* 打开一个链接}procedure MailTo(const Addr: string; const Subject: string = '');
{* 发送邮件}function WinExecute(FileName: string; Visibility: Integer = SW_NORMAL): Boolean;
{* 运行一个文件并立即返回 }function WinExecAndWait32(FileName: string; Visibility: Integer = SW_NORMAL;ProcessMsg: Boolean = False): Integer;
{* 运行一个文件并等待其结束}function WinExecWithPipe(const CmdLine, Dir: string; slOutput: TStrings;var dwExitCode: Cardinal): Boolean; overload;
function WinExecWithPipe(const CmdLine, Dir: string; var Output: string;var dwExitCode: Cardinal): Boolean; overload;
{* 用管道方式在 Dir 目录执行 CmdLine，Output 返回输出信息，dwExitCode 返回退出码。如果成功返回 True }function AppPath: string;
{* 应用程序路径}function ModulePath: string;
{* 当前执行模块所在的路径 }function GetProgramFilesDir: string;
{* 取Program Files目录}function GetWindowsDir: string;
{* 取Windows目录}function GetWindowsTempPath: string;
{* 取临时文件路径}function CnGetTempFileName(const Ext: string): string;
{* 返回一个临时文件名 }function GetSystemDir: string;
{* 取系统目录}function ShortNameToLongName(const FileName: string): string;
{* 短文件名转长文件名}function LongNameToShortName(const FileName: string): string;
{* 长文件名转短文件名}function GetTrueFileName(const FileName: string): string;
{* 取得真实长文件名，包含大小写}function FindExecFile(const AName: string; var AFullName: string): Boolean;
{* 查找可执行文件的完整路径 }function GetSpecialFolderLocation(const Folder: Integer): string;
{* 取得系统特殊文件夹位置，Folder 使用在 ShlObj 中定义的标识，如 CSIDL_DESKTOP }function AddDirSuffix(const Dir: string): string;
{* 目录尾加'\'修正}function MakePath(const Dir: string): string;
{* 目录尾加'\'修正}function MakeDir(const Path: string): string;
{* 路径尾去掉 '\'}function GetUnixPath(const Path: string): string;
{* 路径中的 '\' 转成 '/'}function GetWinPath(const Path: string): string;
{* 路径中的 '/' 转成 '\'}function FileNameMatch(Pattern, FileName: PChar): Integer;
{* 文件名是否与通配符匹配，返回值为0表示匹配，其他为不匹配}function MatchExt(const S, Ext: string): Boolean;
{* 文件名是否与扩展名通配符匹配}function MatchFileName(const S, FN: string): Boolean;
{* 文件名是否与通配符匹配}procedure FileExtsToStrings(const FileExts: string; ExtList: TStrings; CaseSensitive: Boolean);
{* 转换扩展名通配符字符串为通配符列表}function FileMatchesExts(const FileName, FileExts: string; CaseSensitive: Boolean): Boolean; overload;
function FileMatchesExts(const FileName: string; ExtList: TStrings): Boolean; overload;
{* 文件名是否匹配扩展名通配符}procedure FileMasksToStrings(const FileMasks: string; MaskList: TStrings; CaseSensitive: Boolean);
{* 转换文件通配符字符串为通配符列表}function FileMatchesMasks(const FileName, FileMasks: string; CaseSensitive: Boolean): Boolean; overload;
function FileMatchesMasks(const FileName: string; MaskList: TStrings): Boolean; overload;
{* 文件名是否匹配通配符}function FileMatchesExts(const FileName, FileExts: string): Boolean; overload;
{* 文件名与扩展名列表比较。FileExts是如'.pas;.dfm;.inc'这样的字符串}function IsFileInUse(const FName: string): Boolean;
{* 判断文件是否正在使用}function IsAscii(FileName: string): Boolean;
{* 判断文件是否为 Ascii 文件}function IsValidFileName(const Name: string): Boolean;
{* 判断文件是否是有效的文件名}function GetValidFileName(const Name: string): string;
{* 返回有效的文件名 }function SetFileDate(const FileName: string; CreationTime, LastWriteTime, LastAccessTime:TFileTime): Boolean;
{* 设置文件时间}function GetFileDate(const FileName: string; var CreationTime, LastWriteTime, LastAccessTime:TFileTime): Boolean;
{* 取文件时间}function FileTimeToDateTime(const FileTime: TFileTime): TDateTime;
{* 文件时间转本地日期时间}function DateTimeToFileTime(const DateTime: TDateTime): TFileTime;
{* 本地日期时间转文件时间}function GetFileIcon(const FileName: string; var Icon: TIcon): Boolean;
{* 取得与文件相关的图标，成功则返回True}function CreateBakFile(const FileName, Ext: string): Boolean;
{* 创建备份文件}function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
{* 文件时间转本地时间}function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
{* 本地时间转文件时间}function DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;
{* UTC 时间转本地时间}
function LocalDateTimeToDateTime(DateTime: TDateTime): TDateTime;
{* 本地时间转 UTC 时间}{$IFDEF COMPILER5}
typeTValueRelationship = -1..1;function CompareValue(const A, B: Int64): TValueRelationship;function AnsiStartsText(const ASubText, AText: string): Boolean;
{* AText 是否以 ASubText 开头 }function AnsiReplaceText(const AText, AFromText, AToText: string): string;
{$ENDIF}{$IFNDEF COMPILER7_UP}
function AnsiContainsText(const AText, ASubText: string): Boolean;
{* AText 是否包含 ASubText }
{$ENDIF}function CompareTextPos(const ASubText, AText1, AText2: string): TValueRelationship;
{* 比较 SubText 在两个字符串中出现的位置的大小，如果相等则比较字符串本身，忽略大小写 }function Deltree(Dir: string; DelRoot: Boolean = True;DelEmptyDirOnly: Boolean = False): Boolean;
{* 删除整个目录, DelRoot 表示是否删除目录本身}procedure DelEmptyTree(Dir: string; DelRoot: Boolean = True);
{* 删除整个目录中的空目录, DelRoot 表示是否删除目录本身}function GetDirFiles(Dir: string): Integer;
{* 取文件夹文件数}typeTFindCallBack = procedure(const FileName: string; const Info: TSearchRec;var Abort: Boolean) of object;
{* 查找指定目录下文件的回调函数}TDirCallBack = procedure(const SubDir: string) of object;
{* 查找指定目录时进入子目录回调函数}function FindFile(const Path: string; const FileName: string = '*.*';Proc: TFindCallBack = nil; DirProc: TDirCallBack = nil; bSub: Boolean = True;bMsg: Boolean = True): Boolean;
{* 查找指定目录下文件，返回是否被中断 }function OpenWith(const FileName: string): Integer;
{* 显示文件打开方式对话框}function CheckAppRunning(const FileName: string; var Running: Boolean): Boolean;
{* 检查指定的应用程序是否正在运行|<PRE>const FileName: string - 应用程序文件名，不带路径，如果不带扩展名，默认为".EXE"，大小写无所谓。如 Notepad.EXEvar Running: Boolean - 返回该应用程序是否运行，运行为 TrueResult: Boolean - 如果查找成功返回为 True，否则为 False|</PRE>}typeTVersionNumber = packed record{* 文件版本号}Minor: Word;Major: Word;Build: Word;Release: Word;end;function GetFileVersionNumber(const FileName: string): TVersionNumber;
{* 取文件版本号}function GetFileVersionStr(const FileName: string): string;
{* 取文件版本字符串}function GetFileInfo(const FileName: string; var FileSize: Int64;var FileTime: TDateTime): Boolean;
{* 取文件信息}function GetFileSize(const FileName: string): Int64;
{* 取文件长度}function GetFileDateTime(const FileName: string): TDateTime;
{* 取文件Delphi格式日期时间}function LoadStringFromFile(const FileName: string): string;
{* 将文件读为字符串}function SaveStringToFile(const S, FileName: string): Boolean;
{* 保存字符串到为文件}//------------------------------------------------------------------------------
// 环境变量相关
//------------------------------------------------------------------------------function DelEnvironmentVar(const Name: string): Boolean;
{* 删除当前进程中的环境变量 }function ExpandEnvironmentVar(var Value: string): Boolean;
{* 扩展当前进程中的环境变量 }function GetEnvironmentVar(const Name: string; var Value: string;Expand: Boolean): Boolean;
{* 返回当前进程中的环境变量 }function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
{* 返回当前进程中的环境变量列表 }function SetEnvironmentVar(const Name, Value: string): Boolean;
{* 设置当前进程中的环境变量 }//------------------------------------------------------------------------------
// 扩展的字符串操作函数
//------------------------------------------------------------------------------function InStr(const sShort: string; const sLong: string): Boolean;
{* 判断s1是否包含在s2中}function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
{* 扩展整数转字符串函数}function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
{* 带分隔符的整数－字符转换}function IsFloat(const s: String): Boolean;
{* 判断字符串是否可转换成浮点型}function IsInt(const s: String): Boolean;
{* 判断字符串是否可转换成整型}function IsDateTime(const s: string): Boolean;
{* 判断字符串是否可转换成 DateTime }function IsValidEmail(const s: string): Boolean;
{* 判断是否有效的邮件地址 }function StrSpToInt(Value: String; Sp: Char = ','): Int64;
{* 去掉字符串中的分隔符－字符转换}function ByteToBin(Value: Byte): string;
{* 字节转二进制串}function StrRight(Str: string; Len: Integer): string;
{* 返回字符串右边的字符}function StrLeft(Str: string; Len: Integer): string;
{* 返回字符串左边的字符}function GetLine(C: Char; Len: Integer): string;
{* 返回字符串行}function GetTextFileLineCount(FileName: String): Integer;
{* 返回文本文件的行数}function Spc(Len: Integer): string;
{* 返回空格串}procedure SwapStr(var s1, s2: string);
{* 交换字串}procedure SeparateStrAndNum(const AInStr: string; var AOutStr: string;var AOutNum: Integer);
{* 分割"非数字+数字"格式的字符串中的非数字和数字}function UnQuotedStr(const str: string; const ch: Char;const sep: string = ''): string;
{* 去除被引用的字符串的引用}function CharPosWithCounter(const Sub: Char; const AStr: String;Counter: Integer = 1): Integer;
{* 查找字符串中出现的第 Counter 次的字符的位置 }function CountCharInStr(const Sub: Char; const AStr: string): Integer;
{* 查找字符串中字符的出现次数}function IsValidIdentChar(C: Char; First: Boolean = False): Boolean;
{* 判断字符是否有效标识符字符，First 表示是否为首字符}{$IFDEF COMPILER5}
function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;
{* Delphi5没有实现布尔型转换为字符串，类似于Delphi6,7的实现}
{$ENDIF COMPILER5}function LinesToStr(const Lines: string): string;
{* 多行文本转单行（换行符转'\n'）}function StrToLines(const Str: string): string;
{* 单行文本转多行（'\n'转换行符）}function MyDateToStr(Date: TDate): string;
{* 日期转字符串，使用 yyyy.mm.dd 格式}function RegReadStringDef(const RootKey: HKEY; const Key, Name, Def: string): string;
{* 取注册表键值}procedure ReadStringsFromIni(Ini: TCustomIniFile; const Section: string; Strings: TStrings);
{* 从 INI 中读取字符串列表}procedure WriteStringsToIni(Ini: TCustomIniFile; const Section: string; Strings: TStrings);
{* 写字符串列表到 INI 文件中}function VersionToStr(Version: DWORD): string;
{* 版本号转成字符串，如 $01020000 --> '1.2.0.0' }function StrToVersion(s: string): DWORD;
{* 字符串转成版本号，如 '1.2.0.0' --> $01020000，如果格式不正确，返回 $01000000 }function CnDateToStr(Date: TDateTime): string;
{* 转换日期为 yyyy.mm.dd 格式字符串 }function CnStrToDate(const S: string): TDateTime;
{* 将 yyyy.mm.dd 格式字符串转换为日期 }function DateTimeToFlatStr(const DateTime: TDateTime): string;
{* 日期时间转 '20030203132345' 式样的 14 位数字字符串}function FlatStrToDateTime(const Section: string; var DateTime: TDateTime): Boolean;
{* '20030203132345' 式样的 14 位数字字符串转日期时间}function StrToRegRoot(const s: string): HKEY;
{* 字符串转注册表根键，支持 'HKEY_CURRENT_USER' 'HKCR' 长短两种格式}function RegRootToStr(Key: HKEY; ShortFormat: Boolean = True): string;
{* 注册表根键转字符串，可选 'HKEY_CURRENT_USER' 'HKCR' 长短两种格式}function ExtractSubstr(const S: string; var Pos: Integer;const Delims: TSysCharSet): string;
{* 从字符串中根据指定的分隔符分离出子串|<PRE>const S: string - 源字符串var Pos: Integer - 输入查找的起始位置，输出查找完成的结束位置const Delims: TSysCharSet - 分隔符集合Result: string - 返回子串|</PRE>}function WildcardCompare(const FileWildcard, FileName: string; const IgnoreCase:Boolean = True): Boolean;
{* 文件名通配符比较}function ScanCodeToAscii(Code: Word): Char;
{* 根据当前键盘布局将键盘扫描码转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用由于不调用 ToAscii，故可支持使用 Accent Character 的键盘布局 }function IsDeadKey(Key: Word): Boolean;
{* 返回一个虚拟键是否 Dead key}function VirtualKeyToAscii(Key: Word): Char;
{* 根据当前键盘状态将虚拟键转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用可能会导致 Accent Character 不正确}function VK_ScanCodeToAscii(VKey: Word; Code: Word): Char;
{* 根据当前的键盘布局将虚拟键和扫描码转换成 ASCII 字符。通过虚拟键来处理小键盘，扫描码处理大键盘，支持 Accent Character 的键盘布局 }function GetShiftState: TShiftState;
{* 返回当前的按键状态，暂不支持 ssDouble 状态 }function IsShiftDown: Boolean;
{* 判断当前 Shift 是否按下 }function IsAltDown: Boolean;
{* 判断当前 Alt 是否按下 }function IsCtrlDown: Boolean;
{* 判断当前 Ctrl 是否按下 }function IsInsertDown: Boolean;
{* 判断当前 Insert 是否按下 }function IsCapsLockDown: Boolean;
{* 判断当前 Caps Lock 是否按下 }function IsNumLockDown: Boolean;
{* 判断当前 NumLock 是否按下 }function IsScrollLockDown: Boolean;
{* 判断当前 Scroll Lock 是否按下 }function RemoveClassPrefix(const ClassName: string): string;
{* 删除类名前缀 T}function CnAuthorEmailToStr(Author, Email: string): string;
{* 用分号分隔的作者、邮箱字符串转换为输出格式，例如：|<PRE>Author = 'Tom;Jack;Bill'Email = 'tom@email.com;jack@email.com;Bill@email.net'Result = 'Tom(tom@email.com)' + #13#10 +'Jack(jack@email.com)' + #13#10 +'Bill(bill@email.net)|</PRE>}//------------------------------------------------------------------------------
// 扩展的对话框函数
//------------------------------------------------------------------------------procedure InfoDlg(Mess: string; Caption: string = ''; Flags: Integer= MB_OK + MB_ICONINFORMATION);
{* 显示提示窗口}function InfoOk(Mess: string; Caption: string = ''): Boolean;
{* 显示提示确认窗口}procedure ErrorDlg(Mess: string; Caption: string = '');
{* 显示错误窗口}procedure WarningDlg(Mess: string; Caption: string = '');
{* 显示警告窗口}function QueryDlg(Mess: string; DefaultNo: Boolean = False;Caption: string = ''): Boolean;
{* 显示查询是否窗口}constcsDefComboBoxSection = 'History';function CnInputQuery(const ACaption, APrompt: string;var Value: string; Ini: TCustomIniFile = nil;const Section: string = csDefComboBoxSection): Boolean;
{* 输入对话框}function CnInputBox(const ACaption, APrompt, ADefault: string;Ini: TCustomIniFile = nil; const Section: string = csDefComboBoxSection): string;
{* 输入对话框}//------------------------------------------------------------------------------
// 扩展日期时间操作函数
//------------------------------------------------------------------------------function GetYear(Date: TDate): Integer;
{* 取日期年份分量}
function GetMonth(Date: TDate): Integer;
{* 取日期月份分量}
function GetDay(Date: TDate): Integer;
{* 取日期天数分量}
function GetHour(Time: TTime): Integer;
{* 取时间小时分量}
function GetMinute(Time: TTime): Integer;
{* 取时间分钟分量}
function GetSecond(Time: TTime): Integer;
{* 取时间秒分量}
function GetMSecond(Time: TTime): Integer;
{* 取时间毫秒分量}//------------------------------------------------------------------------------
// 位操作函数
//------------------------------------------------------------------------------
typeTByteBit = 0..7;{* Byte类型位数范围}TWordBit = 0..15;{* Word类型位数范围}TDWordBit = 0..31;{* DWord类型位数范围}procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;
{* 设置二进制位}
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload;
{* 设置二进制位}
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload;
{* 设置二进制位}function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload;
{* 取二进制位}
function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload;
{* 取二进制位}
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload;
{* 取二进制位}//------------------------------------------------------------------------------
// 系统功能函数
//------------------------------------------------------------------------------
typePDLLVERSIONINFO = ^TDLLVERSIONINFO;TDLLVERSIONINFO = packed recordcbSize: DWORD;dwMajorVersion: DWORD;dwMinorVersion: DWORD;dwBuildNumber: DWORD;dwPlatformId: DWORD;end;PDLLVERSIONINFO2 = ^TDLLVERSIONINFO2;TDLLVERSIONINFO2 = packed recordinfo1: TDLLVERSIONINFO;dwFlags: DWORD;ullVersion: ULARGE_INTEGER;end;procedure MoveMouseIntoControl(AWinControl: TControl);
{* 移动鼠标到控件}procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10);
{* 将 ComboBox 的文本内容增加到下拉列表中}function DynamicResolution(x, y: WORD): Boolean;
{* 动态设置分辨率}procedure StayOnTop(Handle: HWND; OnTop: Boolean);
{* 窗口最上方显示}procedure SetHidden(Hide: Boolean);
{* 设置程序是否出现在任务栏}procedure SetTaskBarVisible(Visible: Boolean);
{* 设置任务栏是否可见}procedure SetDesktopVisible(Visible: Boolean);
{* 设置桌面是否可见}function ForceForegroundWindow(HWND: HWND): Boolean;
{* 强制让一个窗口显示在前台}function GetWorkRect(const Form: TCustomForm = nil): TRect;
{* 取桌面区域}procedure BeginWait;
{* 显示等待光标}procedure EndWait;
{* 结束等待光标}function CheckWindows9598: Boolean;
{* 检测是否Win95/98平台}function CheckWinXP: Boolean;
{* 检测是否WinXP以上平台}function DllGetVersion(const dllname: string;var DVI: TDLLVERSIONINFO2): Boolean;
{* 获得Dll的版本信息}function GetOSString: string;
{* 返回操作系统标识串}function GetComputeNameStr : string;
{* 得到本机名}function GetLocalUserName: string;
{* 得到本机用户名}function GetRegisteredCompany: string;
{* 得到公司名}function GetRegisteredOwner: string;
{* 得到注册用户名}//------------------------------------------------------------------------------
// 其它过程
//------------------------------------------------------------------------------function GetControlScreenRect(AControl: TControl): TRect;
{* 返回控件在屏幕上的坐标区域 }procedure SetControlScreenRect(AControl: TControl; ARect: TRect);
{* 设置控件在屏幕上的坐标区域 }procedure ListboxHorizontalScrollbar(Listbox: TCustomListBox);
{* 为 Listbox 增加水平滚动条}function TrimInt(Value, Min, Max: Integer): Integer;
{* 输出限制在Min..Max之间}function CompareInt(V1, V2: Integer; Desc: Boolean = False): Integer;
{* 比较两个整数，V1 > V2 返回 1，V1 < V2 返回 -1，V1 = V2 返回 0如果 Desc 为 True，返回结果反向 }function IntToByte(Value: Integer): Byte;
{* 输出限制在0..255之间}function InBound(Value: Integer; V1, V2: Integer): Boolean;
{* 判断整数Value是否在V1和V2之间}function SameMethod(Method1, Method2: TMethod): Boolean;
{* 比较两个方法地址是否相等}function HalfFind(List: TList; P: Pointer; SCompare: TListSortCompare): Integer;
{* 二分法在排序列表中查找}typeTFindRange = recordtgFirst: Integer;tgLast: Integer;end;function HalfFindEx(List: TList; P: Pointer; SCompare: TListSortCompare): TFindRange;
{* 二分法在排序列表中查找，支持重复记录，返回一个范围值}procedure CnSwap(var A, B: Byte); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Integer); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Single); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Double); overload;
{* 交换两个数}function RectEqu(Rect1, Rect2: TRect): Boolean;
{* 比较两个Rect是否相等}procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
{* 分解一个TRect为左上角坐标x, y和宽度Width、高度Height}function EnSize(cx, cy: Integer): TSize;
{* 返回一个TSize类型}function RectWidth(Rect: TRect): Integer;
{* 计算TRect的宽度}function RectHeight(Rect: TRect): Integer;
{* 计算TRect的高度}procedure Delay(const uDelay: DWORD);
{* 延时}procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
{* 在Win9X下让喇叭发声}function GetLastErrorMsg(IncludeErrorCode: Boolean = False): string;
{* 取得最后一次错误信息}procedure ShowLastError;
{* 显示Win32 Api运行结果信息}function GetHzPy(const AHzStr: string): string;
{* 取汉字的拼音}function GetSelText(edt: TCustomEdit): string;
{* 获得CustomEdit选中的字符串，可正确处理使用了XP样式的程序}function SoundCardExist: Boolean;
{* 声卡是否存在}function FindFormByClass(AClass: TClass): TForm;
{* 根据指定类名查找窗体}function InheritsFromClassName(ASrc: TClass; const AClass: string): Boolean; overload;
{* 判断 ASrc 是否派生自类名为 AClass 的类 }function InheritsFromClassName(AObject: TObject; const AClass: string): Boolean; overload;
{* 判断 AObject 是否派生自类名为 AClass 的类 }procedure KillProcessByFileName(const FileName: String);
{* 根据文件名结束进程，不区分路径}function IndexStr(AText: string; AValues: array of string; IgCase: Boolean = True): Integer;
{* 查找字符串在动态数组中的索引，用于string类型使用Case语句}function IndexInt(ANum: Integer; AValues: array of Integer): Integer;
{* 查找整形变量在动态数组中的索引，用于变量使用Case语句}procedure TrimStrings(AList: TStrings);
{* 删除空行和每一行的行首尾空格 }//==============================================================================
// 级联属性操作相关函数 by Passion
//==============================================================================function GetPropInfoIncludeSub(Instance: TObject; const PropName: string;AKinds: TTypeKinds = []): PPropInfo;
{* 获得级联属性信息}function GetPropValueIncludeSub(Instance: TObject; PropName: string;PreferStrings: Boolean = True): Variant;
{* 获得级联属性值}function SetPropValueIncludeSub(Instance: TObject; const PropName: string;const Value: Variant): Boolean;
{* 设置级联属性值}procedure DoSetPropValueIncludeSub(Instance: TObject; const PropName: string;Value: Variant);
{* 设置级联属性值，不处理异常}function StrToSetValue(const Value: string; PInfo: PTypeInfo): Integer;
{* 字符串转集合值 }//==============================================================================
// 其他杂项函数 by Passion
//==============================================================================typeTCnFontControl = class(TControl)publicproperty ParentFont;property Font;end;function IsParentFont(AControl: TControl): Boolean;
{* 判断某 Control 的 ParentFont 属性是否为 True，如无 Parent 则返回 False }function GetParentFont(AControl: TComponent): TFont;
{* 取某 Control 的 Parent 的 Font 属性，如果没有返回 nil }constInvalidFileNameChar: set of Char = ['\', '/', ':', '*', '?', '"', '<', '>', '|'];implementation//------------------------------------------------------------------------------
// 扩展的文件目录操作函数
//------------------------------------------------------------------------------// 在资源管理器中打开指定目录
procedure ExploreDir(APath: string);
varstrExecute: string;
beginstrExecute := Format('EXPLORER.EXE /e,%s', [APath]);WinExec(PChar(strExecute), SW_SHOWNORMAL);
end;// 在资源管理器中打开指定文件
procedure ExploreFile(AFile: string);
varstrExecute: string;
beginstrExecute := Format('EXPLORER.EXE /e,/select,%s', [AFile]);WinExec(PChar(strExecute), SW_SHOWNORMAL);
end;// 递归创建多级子目录
function ForceDirectories(Dir: string): Boolean;
beginResult := True;if Length(Dir) = 0 thenbeginResult := False;Exit;end;Dir := ExcludeTrailingBackslash(Dir);if (Length(Dir) < 3) or DirectoryExists(Dir)or (ExtractFilePath(Dir) = Dir) thenExit; // avoid 'xyz:\' problem.Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);
end;// 移动文件、目录
function MoveFile(const sName, dName: string): Boolean;
vars1, s2: AnsiString;lpFileOp: TSHFileOpStruct;
begins1 := PChar(sName) + #0#0;s2 := PChar(dName) + #0#0;with lpFileOp dobeginWnd := Application.Handle;wFunc := FO_MOVE;pFrom := PChar(s1);pTo := PChar(s2);fFlags := FOF_ALLOWUNDO;hNameMappings := nil;lpszProgressTitle := nil;fAnyOperationsAborted := True;end;tryResult := SHFileOperation(lpFileOp) = 0;exceptResult := False;end;
end;// 删除文件到回收站
function DeleteToRecycleBin(const FileName: string): Boolean;
vars: AnsiString;lpFileOp: TSHFileOpStruct;
begins := PChar(FileName) + #0#0;with lpFileOp dobeginWnd := Application.Handle;wFunc := FO_DELETE;pFrom := PChar(s);pTo := nil;fFlags := FOF_ALLOWUNDO or FOF_SILENT or FOF_NOCONFIRMATION;hNameMappings := nil;lpszProgressTitle := nil;fAnyOperationsAborted := True;end;tryResult := SHFileOperation(lpFileOp) = 0;exceptResult := False;end;
end;// 打开文件属性窗口
procedure FileProperties(const FName: string);
varSEI: SHELLEXECUTEINFO;
beginwith SEI dobegincbSize := SizeOf(SEI);fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST orSEE_MASK_FLAG_NO_UI;Wnd := Application.Handle;lpVerb := 'properties';lpFile := PChar(FName);lpParameters := nil;lpDirectory := nil;nShow := 0;hInstApp := 0;lpIDList := nil;end;ShellExecuteEx(@SEI);
end;// 缩短显示不下的长路径名
function FormatPath(APath: string; Width: Integer): string;
varSLen: Integer;i, j: Integer;TString: string;
beginSLen := Length(APath);if (SLen <= Width) or (Width <= 6) thenbeginResult := APath;Exitendelsebegini := SLen;TString := APath;for j := 1 to 2 dobeginwhile (TString[i] <> '\') and (SLen - i < Width - 8) doi := i - 1;i := i - 1;end;for j := SLen - i - 1 downto 0 doTString[Width - j] := TString[SLen - j];for j := SLen - i to SLen - i + 2 doTString[Width - j] := '.';Delete(TString, Width + 1, 255);Result := TString;end;
end;// 通过 DrawText 来画缩略路径
procedure DrawCompactPath(Hdc: HDC; Rect: TRect; Str: string);
beginDrawText(Hdc, PChar(Str), Length(Str), Rect, DT_PATH_ELLIPSIS);
end;// 打开文件框
function OpenDialog(var FileName: string; Title: string; Filter: string;Ext: string): Boolean;
varOpenName: TOPENFILENAME;TempFilename, ReturnFile: string;
beginwith OpenName dobeginlStructSize := SizeOf(OpenName);hWndOwner := GetModuleHandle('');Hinstance := SysInit.Hinstance;lpstrFilter := PChar(Filter + #0 + Ext + #0#0);lpstrCustomFilter := '';nMaxCustFilter := 0;nFilterIndex := 1;nMaxFile := MAX_PATH;SetLength(TempFilename, nMaxFile + 2);lpstrFile := PChar(TempFilename);FillChar(lpstrFile^, MAX_PATH, 0);SetLength(TempFilename, nMaxFile + 2);nMaxFileTitle := MAX_PATH;SetLength(ReturnFile, MAX_PATH + 2);lpstrFileTitle := PChar(ReturnFile);FillChar(lpstrFile^, MAX_PATH, 0);lpstrInitialDir := '.';lpstrTitle := PChar(Title);Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;nFileOffset := 0;nFileExtension := 0;lpstrDefExt := PChar(Ext);lCustData := 0;lpfnHook := nil;lpTemplateName := '';end;Result := GetOpenFileName(OpenName);if Result thenFileName := ReturnFileelseFileName := '';
end;function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;
beginif (uMsg = BFFM_INITIALIZED) and (lpData <> 0) thenSendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);Result := 0;
end;function CnSelectDirectory(const Caption: string; const Root: WideString;var Directory: string; Owner: HWND; ShowNewButton: Boolean = True): Boolean;
varBrowseInfo: TBrowseInfo;Buffer: PChar;RootItemIDList, ItemIDList: PItemIDList;ShellMalloc: IMalloc;IDesktopFolder: IShellFolder;Eaten, Flags: LongWord;
beginResult := False;FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) thenbeginBuffer := ShellMalloc.Alloc(MAX_PATH);trySHGetDesktopFolder(IDesktopFolder);if Root = '' thenRootItemIDList := nilelseIDesktopFolder.ParseDisplayName(Application.Handle, nil,POleStr(Root), Eaten, RootItemIDList, Flags);with BrowseInfo dobeginhwndOwner := Owner;pidlRoot := RootItemIDList;pszDisplayName := Buffer;lpszTitle := PChar(Caption);ulFlags := BIF_RETURNONLYFSDIRS;if ShowNewButton thenulFlags := ulFlags or $0040;lpfn := SelectDirCB;lparam := Integer(PChar(Directory));end;ItemIDList := SHBrowseForFolder(BrowseInfo);Result := ItemIDList <> nil;if Result thenbeginShGetPathFromIDList(ItemIDList, Buffer);ShellMalloc.Free(ItemIDList);Directory := Buffer;end;finallyShellMalloc.Free(Buffer);end;end;
end;function GetDirectory(const Caption: string; var Dir: string;ShowNewButton: Boolean): Boolean;
varOldErrorMode: UINT;BrowseRoot: WideString;OwnerHandle: HWND;
beginOldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);tryBrowseRoot := '';if Screen.ActiveCustomForm <> nil thenOwnerHandle := Screen.ActiveCustomForm.HandleelseOwnerHandle := Application.Handle;Result := CnSelectDirectory(Caption, BrowseRoot, Dir, OwnerHandle,ShowNewButton);finallySetErrorMode(OldErrorMode);end;
end;// 两个字符串的前面的相同字符数
function SameCharCounts(s1, s2: string): Integer;
varStr1, Str2: PChar;
beginResult := 1;s1 := s1 + #0;s2 := s2 + #0;Str1 := PChar(s1);Str2 := PChar(s2);while (s1[Result] = s2[Result]) and (s1[Result] <> #0) dobeginInc(Result);end;Dec(Result);
{$IFDEF MSWINDOWS}if (StrByteType(Str1, Result - 1) = mbLeadByte) or(StrByteType(Str2, Result - 1) = mbLeadByte) thenDec(Result);
{$ENDIF}
{$IFDEF LINUX}if (StrByteType(Str1, Result - 1) <> mbSingleByte) or(StrByteType(Str2, Result - 1) <> mbSingleByte) thenDec(Result);
{$ENDIF}
end;// 在字符串中某字符出现的次数
function CharCounts(Str: PChar; Chr: Char): Integer;
varp: PChar;
beginResult := 0;p := StrScan(Str, Chr);while p <> nil dobegin
{$IFDEF MSWINDOWS}case StrByteType(Str, Integer(p - Str)) ofmbSingleByte: beginInc(Result);Inc(p);end;mbLeadByte: Inc(p);end;
{$ENDIF}
{$IFDEF LINUX}if StrByteType(Str, Integer(p - Str)) = mbSingleByte then beginInc(Result);Inc(p);end;
{$ENDIF}Inc(p);p := StrScan(p, Chr);end;
end;// 取两个目录的相对路径
function GetRelativePath(ATo, AFrom: string;const PathStr: string = '\'; const ParentStr: string = '..';const CurrentStr: string = '.'; const UseCurrentDir: Boolean = False): string;
vari, HeadNum: Integer;
beginATo := StringReplace(ATo, '/', '\', [rfReplaceAll]);AFrom := StringReplace(AFrom, '/', '\', [rfReplaceAll]);while AnsiPos('\\', ATo) > 0 doATo := StringReplace(ATo, '\\', '\', [rfReplaceAll]);while AnsiPos('\\', AFrom) > 0 doAFrom := StringReplace(AFrom, '\\', '\', [rfReplaceAll]);if StrRight(ATo, 1) = ':' thenATo := ATo + '\';if StrRight(AFrom, 1) = ':' thenAFrom := AFrom + '\';HeadNum := SameCharCounts(AnsiUpperCase(ExtractFilePath(ATo)),AnsiUpperCase(ExtractFilePath(AFrom)));if HeadNum > 0 thenbeginATo := StringReplace(Copy(ATo, HeadNum + 1, MaxInt), '\', PathStr, [rfReplaceAll]);AFrom := Copy(AFrom, HeadNum + 1, MaxInt);Result := '';HeadNum := CharCounts(PChar(AFrom), '\');for i := 1 to HeadNum doResult := Result + ParentStr + PathStr;if (Result = '') and UseCurrentDir thenResult := CurrentStr + PathStr;Result := Result + ATo;endelseResult := ATo;
end;{$IFNDEF BCB}
constshlwapi32 = 'shlwapi.dll';function PathRelativePathToA; external shlwapi32 name 'PathRelativePathToA';
function PathRelativePathToW; external shlwapi32 name 'PathRelativePathToW';
function PathRelativePathTo; external shlwapi32 name 'PathRelativePathToA';// 使用Windows API取两个目录的相对路径
function RelativePath(const AFrom, ATo: string; FromIsDir, ToIsDir: Boolean): string;function GetAttr(IsDir: Boolean): DWORD;beginif IsDir thenResult := FILE_ATTRIBUTE_DIRECTORYelseResult := FILE_ATTRIBUTE_NORMAL;end;
varp: array[0..MAX_PATH] of Char;
beginPathRelativePathTo(p, PChar(AFrom), GetAttr(FromIsDir), PChar(ATo), GetAttr(ToIsDir));Result := StrPas(p);
end;
{$ENDIF}// 连接两个路径，
// Head - 首路径，可以是 C:\Test、\\Test\C\Abc、http://www.abc.com/dir/ 等格式
// Tail - 尾路径，可以是 ..\Test、Abc\Temp、\Test、/web/lib 等格式或绝对地址格式
function LinkPath(const Head, Tail: string): string;
varHeadIsUrl: Boolean;TailHasRoot: Boolean;TailIsRel: Boolean;AHead, ATail, S: string;UrlPos, i: Integer;
beginif Head = '' thenbeginResult := Tail;Exit;end;if Tail = '' thenbeginResult := Head;Exit;end;TailHasRoot := (AnsiPos(':\', Tail) = 2) or // C:\Test(AnsiPos('\\', Tail) = 1) or // \\Name\C\Test(AnsiPos('://', Tail) > 0); // ftp://ftp.abc.comif TailHasRoot thenbeginResult := Tail;Exit;end;UrlPos := AnsiPos('://', Head);HeadIsUrl := UrlPos > 0;AHead := StringReplace(Head, '/', '\', [rfReplaceAll]);ATail := StringReplace(Tail, '/', '\', [rfReplaceAll]);TailIsRel := ATail[1] = '\'; // 尾路径是相对路径if TailIsRel thenbeginif AnsiPos(':\', AHead) = 2 thenResult := AHead[1] + ':' + ATailelse if AnsiPos('\\', AHead) = 1 thenbeginS := Copy(AHead, 3, MaxInt);i := AnsiPos('\', S);if i > 0 thenResult := Copy(AHead, 1, i + 1) + ATailelseResult := AHead + ATail;end else if HeadIsUrl thenbeginS := Copy(AHead, UrlPos + 3, MaxInt);i := AnsiPos('\', S);if i > 0 thenResult := Copy(AHead, 1, i + UrlPos + 1) + ATailelseResult := AHead + ATail;endelsebeginResult := Tail;Exit;end;endelsebeginif Copy(ATail, 1, 2) = '.\' thenDelete(ATail, 1, 2);AHead := MakeDir(AHead);i := Pos('..\', ATail);while i > 0 dobeginAHead := ExtractFileDir(AHead);Delete(ATail, 1, 3);i := Pos('..\', ATail);end;Result := MakePath(AHead) + ATail;end;if HeadIsUrl thenResult := StringReplace(Result, '\', '/', [rfReplaceAll]);
end;// 运行一个文件
procedure RunFile(const FName: string; Handle: THandle;const Param: string);
beginShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;// 打开一个链接
procedure OpenUrl(const Url: string);
constcsPrefix = 'http://';
varAUrl: string;
beginif Pos(csPrefix, Url) < 1 thenAUrl := csPrefix + UrlelseAUrl := Url;RunFile(AUrl);
end;// 发送邮件
procedure MailTo(const Addr: string; const Subject: string = '');
constcsPrefix = 'mailto:';csSubject = '?Subject=';
varUrl: string;
beginif Pos(csPrefix, Addr) < 1 thenUrl := csPrefix + AddrelseUrl := Addr;if Subject <> '' thenUrl := Url + csSubject + Subject;RunFile(Url);
end;// 运行一个文件并立即返回
function WinExecute(FileName: string; Visibility: Integer = SW_NORMAL): Boolean;
varStartupInfo: TStartupInfo;ProcessInfo: TProcessInformation;
beginFillChar(StartupInfo, SizeOf(StartupInfo), #0);StartupInfo.cb := SizeOf(StartupInfo);StartupInfo.dwFlags := STARTF_USESHOWWINDOW;StartupInfo.wShowWindow := Visibility;Result := CreateProcess(nil, PChar(FileName), nil, nil, False,CREATE_NEW_CONSOLE or NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo,ProcessInfo);
end;// 运行一个文件并等待其结束
function WinExecAndWait32(FileName: string; Visibility: Integer;ProcessMsg: Boolean): Integer;
varzAppName: array[0..512] of Char;zCurDir: array[0..255] of Char;WorkDir: string;StartupInfo: TStartupInfo;ProcessInfo: TProcessInformation;
beginStrPCopy(zAppName, FileName);GetDir(0, WorkDir);StrPCopy(zCurDir, WorkDir);FillChar(StartupInfo, SizeOf(StartupInfo), #0);StartupInfo.cb := SizeOf(StartupInfo);StartupInfo.dwFlags := STARTF_USESHOWWINDOW;StartupInfo.wShowWindow := Visibility;if not CreateProcess(nil,zAppName, { pointer to command line string }nil, { pointer to process security attributes }nil, { pointer to thread security attributes }False, { handle inheritance flag }CREATE_NEW_CONSOLE or { creation flags }NORMAL_PRIORITY_CLASS,nil, { pointer to new environment block }nil, { pointer to current directory name }StartupInfo, { pointer to STARTUPINFO }ProcessInfo) thenResult := -1 { pointer to PROCESS_INF }elsebeginif ProcessMsg thenbeginrepeatApplication.ProcessMessages;GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));until (Result <> STILL_ACTIVE) or Application.Terminated;endelsebeginWaitforSingleObject(ProcessInfo.hProcess, INFINITE);GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));end;end;
end;// 用管道方式在 Dir 目录执行 CmdLine，Output 返回输出信息，
// dwExitCode 返回退出码。如果成功返回 True
function WinExecWithPipe(const CmdLine, Dir: string; slOutput: TStrings;var dwExitCode: Cardinal): Boolean;
varHOutRead, HOutWrite: THandle;StartInfo: TStartupInfo;ProceInfo: TProcessInformation;sa: TSecurityAttributes;InStream: THandleStream;strTemp: string;PDir: PChar;procedure ReadLinesFromPipe(IsEnd: Boolean);vars: string;ls: TStringList;i: Integer;beginif InStream.Position < InStream.Size thenbeginSetLength(s, InStream.Size - InStream.Position);InStream.Read(PChar(s)^, InStream.Size - InStream.Position);strTemp := strTemp + s;ls := TStringList.Create;tryls.Text := strTemp;for i := 0 to ls.Count - 2 doslOutput.Add(ls[i]);strTemp := ls[ls.Count - 1];finallyls.Free;end;end;if IsEnd and (strTemp <> '') thenbeginslOutput.Add(strTemp);strTemp := '';end;end;
begindwExitCode := 0;Result := False;tryFillChar(sa, sizeof(sa), 0);sa.nLength := sizeof(sa);sa.bInheritHandle := True;sa.lpSecurityDescriptor := nil;InStream := nil;strTemp := '';HOutRead := INVALID_HANDLE_VALUE;HOutWrite := INVALID_HANDLE_VALUE;tryWin32Check(CreatePipe(HOutRead, HOutWrite, @sa, 0));FillChar(StartInfo, SizeOf(StartInfo), 0);StartInfo.cb := SizeOf(StartInfo);StartInfo.wShowWindow := SW_HIDE;StartInfo.dwFlags := STARTF_USESTDHANDLES + STARTF_USESHOWWINDOW;StartInfo.hStdError := HOutWrite;StartInfo.hStdInput := GetStdHandle(STD_INPUT_HANDLE);StartInfo.hStdOutput := HOutWrite;InStream := THandleStream.Create(HOutRead);if Dir <> '' thenPDir := PChar(Dir)elsePDir := nil;Win32Check(CreateProcess(nil, //lpApplicationName: PCharPChar(CmdLine), //lpCommandLine: PCharnil, //lpProcessAttributes: PSecurityAttributesnil, //lpThreadAttributes: PSecurityAttributesTrue, //bInheritHandles: BOOLNORMAL_PRIORITY_CLASS, //CREATE_NEW_CONSOLE,nil,PDir,StartInfo,ProceInfo));while WaitForSingleObject(ProceInfo.hProcess, 100) = WAIT_TIMEOUT dobeginReadLinesFromPipe(False);Application.ProcessMessages;//if Application.Terminated then break;end;ReadLinesFromPipe(True);GetExitCodeProcess(ProceInfo.hProcess, dwExitCode);CloseHandle(ProceInfo.hProcess);CloseHandle(ProceInfo.hThread);Result := True;finallyif InStream <> nil then InStream.Free;if HOutRead <> INVALID_HANDLE_VALUE then CloseHandle(HOutRead);if HOutWrite <> INVALID_HANDLE_VALUE then CloseHandle(HOutWrite);end;except;end;
end;function WinExecWithPipe(const CmdLine, Dir: string; var Output: string;var dwExitCode: Cardinal): Boolean;
varslOutput: TStringList;
beginslOutput := TStringList.Create;tryResult := WinExecWithPipe(CmdLine, Dir, slOutput, dwExitCode);Output := slOutput.Text;finallyslOutput.Free;end;
end;// 应用程序路径
function AppPath: string;
beginResult := ExtractFilePath(Application.ExeName);
end;// 当前执行模块所在的路径
function ModulePath: string;
varModName: array[0..MAX_PATH] of Char;
beginSetString(Result, ModName, GetModuleFileName(HInstance, ModName, SizeOf(ModName)));Result := ExtractFilePath(Result);
end;constHKLM_CURRENT_VERSION_WINDOWS = 'Software\Microsoft\Windows\CurrentVersion';HKLM_CURRENT_VERSION_NT = 'Software\Microsoft\Windows NT\CurrentVersion';function RelativeKey(const Key: string): PChar;
beginResult := PChar(Key);if (Key <> '') and (Key[1] = '\') thenInc(Result);
end;function RegReadStringDef(const RootKey: HKEY; const Key, Name, Def: string): string;
varRegKey: HKEY;Size: DWORD;StrVal: string;RegKind: DWORD;
beginResult := Def;if RegOpenKeyEx(RootKey, RelativeKey(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS thenbeginRegKind := 0;Size := 0;if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, nil, @Size) = ERROR_SUCCESS thenif RegKind in [REG_SZ, REG_EXPAND_SZ] thenbeginSetLength(StrVal, Size);if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, PByte(StrVal), @Size) = ERROR_SUCCESS thenbeginSetLength(StrVal, StrLen(PChar(StrVal)));Result := StrVal;end;end;RegCloseKey(RegKey);end;
end;procedure StrResetLength(var S: AnsiString);
beginSetLength(S, StrLen(PChar(S)));
end;// 取Program Files目录
function GetProgramFilesDir: string;
beginResult := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');
end;// 取Windows目录
function GetWindowsDir: string;
varRequired: Cardinal;
beginResult := '';Required := GetWindowsDirectory(nil, 0);if Required <> 0 thenbeginSetLength(Result, Required);GetWindowsDirectory(PChar(Result), Required);StrResetLength(Result);end;
end;// 取临时文件路径
function GetWindowsTempPath: string;
varRequired: Cardinal;
beginResult := '';Required := GetTempPath(0, nil);if Required <> 0 thenbeginSetLength(Result, Required);GetTempPath(Required, PChar(Result));StrResetLength(Result);end;
end;// 返回一个临时文件名
function CnGetTempFileName(const Ext: string): string;
varPath: string;
beginPath := MakePath(GetWindowsTempPath);repeatResult := Path + IntToStr(Random(MaxInt)) + Ext;until not FileExists(Result);
end;// 取系统目录
function GetSystemDir: string;
varRequired: Cardinal;
beginResult := '';Required := GetSystemDirectory(nil, 0);if Required <> 0 thenbeginSetLength(Result, Required);GetSystemDirectory(PChar(Result), Required);StrResetLength(Result);end;
end;function GetLongPathNameA(lpszShortPath: PAnsiChar; lpszLongPath: PAnsiChar;cchBuffer: DWORD): DWORD; stdcall; external 'kernel32.dll'name 'GetLongPathNameA';// 短文件名转长文件名
function ShortNameToLongName(const FileName: string): string;
varBuf: array[0..MAX_PATH] of Char;
beginif GetLongPathNameA(PChar(FileName), @Buf, MAX_PATH) > 0 thenResult := BufelseResult := FileName;
end;// 长文件名转短文件名
function LongNameToShortName(const FileName: string): string;
varBuf: PChar;BufSize: Integer;
beginBufSize := GetShortPathName(PChar(FileName), nil, 0) + 1;GetMem(Buf, BufSize);tryGetShortPathName(PChar(FileName), Buf, BufSize);Result := Buf;finallyFreeMem(Buf);end;
end;// 取得真实长文件名，包含大小写
function GetTrueFileName(const FileName: string): string;
varAName: string;FindName: string;function DoFindFile(const FName: string): string;varF: TSearchRec;beginif SysUtils.FindFirst(FName, faAnyFile, F) = 0 thenResult := F.NameelseResult := ExtractFileName(FName);SysUtils.FindClose(F);end;
beginAName := MakeDir(FileName);if (Length(AName) > 3) and (AName[2] = ':') thenbeginResult := '';while Length(AName) > 3 dobeginFindName := DoFindFile(AName);if FindName = '' thenbeginResult := AName;Exit;end;if Result = '' thenResult := FindNameelseResult := FindName + '\' + Result;AName := ExtractFileDir(AName);end;Result := UpperCase(AName) + Result;endelseResult := AName;
end;// 查找可执行文件的完整路径
function FindExecFile(const AName: string; var AFullName: string): Boolean;
varfn: array[0..MAX_PATH] of Char;pc: PChar;
beginif (0 = SearchPath(nil, PChar(AName), '.exe', SizeOf(fn), fn, pc)) and(0 = SearchPath(nil, PChar(AName), '.com', SizeOf(fn), fn, pc)) and(0 = SearchPath(nil, PChar(AName), '.bat', SizeOf(fn), fn, pc)) thenbeginResult := False;endelsebeginResult := True;AFullName := fn;end;
end;function PidlFree(var IdList: PItemIdList): Boolean;
varMalloc: IMalloc;
beginResult := False;if IdList = nil thenResult := Trueelsebeginif Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(IdList) > 0) thenbeginMalloc.Free(IdList);IdList := nil;Result := True;end;end;
end;function PidlToPath(IdList: PItemIdList): string;
beginSetLength(Result, MAX_PATH);if SHGetPathFromIdList(IdList, PChar(Result)) thenStrResetLength(Result)elseResult := '';
end;// 取得系统特殊文件夹位置，Folder 使用在 ShlObj 中定义的标识，如 CSIDL_DESKTOP
function GetSpecialFolderLocation(const Folder: Integer): string;
varFolderPidl: PItemIdList;
beginif Succeeded(SHGetSpecialFolderLocation(0, Folder, FolderPidl)) thenbeginResult := PidlToPath(FolderPidl);PidlFree(FolderPidl);endelseResult := '';
end;// 目录尾加'\'修正
function AddDirSuffix(const Dir: string): string;
beginResult := Trim(Dir);if Result = '' then Exit;if not IsPathDelimiter(Result, Length(Result)) thenResult := Result + {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF};
end;// 目录尾加'\'修正
function MakePath(const Dir: string): string;
beginResult := AddDirSuffix(Dir);
end;// 路径尾去掉 '\'
function MakeDir(const Path: string): string;
beginResult := Trim(Path);if Result = '' then Exit;if Result[Length(Result)] in ['/', '\'] then Delete(Result, Length(Result), 1);
end;// 路径中的 '\' 转成 '/'
function GetUnixPath(const Path: string): string;
beginResult := StringReplace(Path, '\', '/', [rfReplaceAll]);
end;// 路径中的 '/' 转成 '\'
function GetWinPath(const Path: string): string;
beginResult := StringReplace(Path, '/', '\', [rfReplaceAll]);
end;function PointerXX(var X: PChar): PChar;
{$IFDEF PUREPASCAL}
beginResult := X;Inc(X);
end;
{$ELSE}
asm{EAX = X}MOV EDX, [EAX]INC dword ptr [EAX]MOV EAX, EDX
end;
{$ENDIF}function Evaluate(var X: Char; const Value: Char): Char;
{$IFDEF PUREPASCAL}
beginX := Value;Result := X;
end;
{$ELSE}
asm{EAX = XEDX = Value (DL)}MOV [EAX], DLMOV AL, [EAX]
end;
{$ENDIF}// 文件名是否与通配符匹配，返回值为0表示匹配
function FileNameMatch(Pattern, FileName: PChar): Integer;
varp, n: PChar;c: Char;
beginp := Pattern;n := FileName;while Evaluate(c, PointerXX(p)^) <> #0 dobegincase c of'?': beginif n^ = '.' thenbeginwhile (p^ <> '.') and (p^ <> #0) dobeginif (p^ <> '?') and (p^ <> '*') thenbeginResult := -1;Exit;end;Inc(p);end;endelsebeginif n^ <> #0 thenInc(n);end;end;'>': beginif n^ = '.' thenbeginif ((n + 1)^ = #0) and (FileNameMatch(p, n+1) = 0) thenbeginResult := 0;Exit;end;if FileNameMatch(p, n) = 0 thenbeginResult := 0;Exit;end;Result := -1;Exit;end;if n^ = #0 thenbeginResult := FileNameMatch(p, n);Exit;end;Inc(n);end;'*': beginwhile n^ <> #0 dobeginif FileNameMatch(p, n) = 0 thenbeginResult := 0;Exit;end;Inc(n);end;end;'<': beginwhile n^ <> #0 dobeginif FileNameMatch(p, n) = 0 thenbeginResult := 0;Exit;end;if (n^ = '.') and (StrScan(n + 1, '.') = nil) thenbeginInc(n);Break;end;Inc(n);end;end;'"': beginif (n^ = #0) and (FileNameMatch(p, n) = 0) thenbeginResult := 0;Exit;end;if n^ <> '.' thenbeginResult := -1;Exit;end;Inc(n);end;elseif (c = '.') and (n^ = #0) thenbeginwhile p^ <> #0 dobeginif (p^ = '*') and ((p + 1)^ = #0) thenbeginResult := 0;Exit;end;if p^ <> '?' thenbeginResult := -1;Exit;end;Inc(p);end;Result := 0;Exit;
end;if c <> n^ thenbeginResult := -1;Exit;end;Inc(n);end;end;if n^ = #0 thenbeginResult := 0;Exit;end;Result := -1;
end;// 文件名是否与扩展名通配符匹配
function MatchExt(const S, Ext: string): Boolean;
beginif S = '.*' thenbeginResult := True;Exit;end;Result := FileNameMatch(PChar(S), PChar(Ext)) = 0;
end;// 文件名是否与通配符匹配
function MatchFileName(const S, FN: string): Boolean;
beginif S = '*.*' thenbeginResult := True;Exit;end;Result := FileNameMatch(PChar(S), PChar(FN)) = 0;
end;// 得到大小写是否敏感的字符串
function _CaseSensitive(const CaseSensitive: Boolean; const S: string): string;
beginif CaseSensitive thenResult := SelseResult := AnsiUpperCase(S);
end;// 转换扩展名通配符字符串为通配符列表
procedure FileExtsToStrings(const FileExts: string; ExtList: TStrings; CaseSensitive: Boolean);
varExts: string;i: Integer;
beginExts := StringReplace(FileExts, ';', ',', [rfReplaceAll]);ExtList.CommaText := Exts;for i := 0 to ExtList.Count - 1 dobeginif StrScan(PChar(ExtList[i]), '.') <> nil thenbeginExtList[i] := _CaseSensitive(CaseSensitive, ExtractFileExt(ExtList[i]));endelsebeginExtList[i] := '.' + _CaseSensitive(CaseSensitive, ExtList[i]);end;if ExtList[i] = '.*' thenbeginif i > 0 thenExtList.Exchange(0, i);Exit;end;end;
end;// 文件名是否匹配扩展名通配符
function FileMatchesExts(const FileName, FileExts: string; CaseSensitive: Boolean): Boolean;
varExtList: TStrings;FExt: string;i: Integer;
beginExtList := TStringList.Create;tryFileExtsToStrings(FileExts, ExtList, CaseSensitive);FExt := _CaseSensitive(CaseSensitive, ExtractFileExt(FileName));Result := False;for i := 0 to ExtList.Count - 1 dobeginif MatchExt(ExtList[i], FExt) thenbeginResult := True;Exit;end;end;finallyExtList.Free;end;
end;// 文件名是否匹配扩展名通配符
function FileMatchesExts(const FileName: string; ExtList: TStrings): Boolean;
varFExt: string;i: Integer;
beginFExt := _CaseSensitive(False, ExtractFileExt(FileName));Result := False;for i := 0 to ExtList.Count - 1 dobeginif MatchExt(ExtList[i], FExt) thenbeginResult := True;Exit;end;end;
end;// 转换文件通配符字符串为通配符列表
procedure FileMasksToStrings(const FileMasks: string; MaskList: TStrings; CaseSensitive: Boolean);
varExts: string;i: Integer;
beginExts := StringReplace(FileMasks, ';', ',', [rfReplaceAll]);MaskList.CommaText := Exts;for i := 0 to MaskList.Count - 1 dobeginif StrScan(PChar(MaskList[i]), '.') <> nil thenbeginif MaskList[i][1] = '.' thenMaskList[i] := '*' + _CaseSensitive(CaseSensitive, MaskList[i])elseMaskList[i] := _CaseSensitive(CaseSensitive, MaskList[i]);endelsebeginMaskList[i] := '*.' + _CaseSensitive(CaseSensitive, MaskList[i]);end;if MaskList[i] = '*.*' thenbeginif i > 0 thenMaskList.Exchange(0, i);Exit;end;end;
end;// 文件名是否匹配通配符
function FileMatchesMasks(const FileName, FileMasks: string; CaseSensitive: Boolean): Boolean;
varMaskList: TStrings;FFileName: string;i: Integer;
beginMaskList := TStringList.Create;tryFileMasksToStrings(FileMasks, MaskList, CaseSensitive);FFileName := _CaseSensitive(CaseSensitive, ExtractFileName(FileName));Result := False;for i := 0 to MaskList.Count - 1 dobeginif MatchFileName(MaskList[i], FFileName) thenbeginResult := True;Exit;end;end;finallyMaskList.Free;end;
end;// 文件名是否匹配通配符
function FileMatchesMasks(const FileName: string; MaskList: TStrings): Boolean;
varFFileName: string;i: Integer;
beginFFileName := _CaseSensitive(False, ExtractFileName(FileName));Result := False;for i := 0 to MaskList.Count - 1 dobeginif MatchFileName(MaskList[i], FFileName) thenbeginResult := True;Exit;end;end;
end;// 文件名与扩展名列表比较
function FileMatchesExts(const FileName, FileExts: string): Boolean;
beginResult := FileMatchesMasks(FileName, FileExts, False);
end;// 判断文件是否正在使用
function IsFileInUse(const FName: string): Boolean;
varHFileRes: HFILE;
beginResult := False;if not FileExists(FName) thenExit;HFileRes := CreateFile(PChar(FName), GENERIC_READ or GENERIC_WRITE, 0,nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);Result := (HFileRes = INVALID_HANDLE_VALUE);if not Result thenCloseHandle(HFileRes);
end;// 判断文件是否为 Ascii 文件
function IsAscii(FileName: string): Boolean;
constSett=2048;
varI: Integer;AFile: File;Bool: Boolean;TotSize, IncSize, ReadSize: Integer;C: array[0..Sett] of Byte;
beginResult := False;if FileExists(FileName) thenbegin{$I-}AssignFile(AFile, FileName);Reset(AFile, 1);TotSize := FileSize(AFile);IncSize := 0;Bool := True;while (IncSize < TotSize) and (Bool = True) dobeginReadSize := Sett;if IncSize + ReadSize > TotSize thenReadSize := TotSize - IncSize;IncSize := IncSize + ReadSize;BlockRead(AFile, C, ReadSize);for I := 0 to ReadSize-1 do // Iterateif (C[I] < 32) and (not(C[I] in [9, 10, 13, 26])) then Bool := False;end; // whileCloseFile(AFile);{$I+}if IOResult <> 0 thenResult := FalseelseResult := Bool;end;
end;// 判断文件是否是有效的文件名
function IsValidFileName(const Name: string): Boolean;
vari: Integer;
beginResult := False;if (Name = '') or (Length(Name) > MAX_PATH) thenExit;for i := 1 to Length(Name) dobeginif Name[i] in InvalidFileNameChar thenExit;end;Result := True;
end;// 返回有效的文件名
function GetValidFileName(const Name: string): string;
vari: Integer;
beginResult := Name;for i := Length(Result) downto 1 dobeginif Result[i] in InvalidFileNameChar thenDelete(Result, i, 1);end;if Length(Result) > MAX_PATH - 1 thenResult := Copy(Result, 1, MAX_PATH - 1);
end;// 设置文件时间
function SetFileDate(const FileName: string; CreationTime, LastWriteTime, LastAccessTime:TFileTime): Boolean;
varFileHandle: Integer;
beginFileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);if FileHandle > 0 thenbeginSetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime);FileClose(FileHandle);Result := True;endelseResult := False;
end;// 取文件时间
function GetFileDate(const FileName: string; var CreationTime, LastWriteTime, LastAccessTime:TFileTime): Boolean;
varFileHandle: Integer;
beginFileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);if FileHandle > 0 thenbeginGetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime);FileClose(FileHandle);Result := True;endelseResult := False;
end;// 取得与文件相关的图标
// FileName: e.g. "e:\hao\a.txt"
// 成功则返回True
function GetFileIcon(const FileName: string; var Icon: TIcon): Boolean;
varSHFileInfo: TSHFileInfo;h: HWND;
beginif not Assigned(Icon) thenIcon := TIcon.Create;h := SHGetFileInfo(PChar(FileName),0,SHFileInfo,SizeOf(SHFileInfo),SHGFI_ICON or SHGFI_SYSICONINDEX);Icon.Handle := SHFileInfo.hIcon;Result := (h <> 0);
end;// 文件时间转本地日期时间
function FileTimeToDateTime(const FileTime: TFileTime): TDateTime;
varSystemTime: TSystemTime;
beginSystemTime := FileTimeToLocalSystemTime(FileTime);with SystemTime doResult := EncodeDate(wYear, wMonth, wDay) + EncodeTime(wHour, wMinute,wSecond, wMilliseconds);
end;// 本地日期时间转文件时间
function DateTimeToFileTime(const DateTime: TDateTime): TFileTime;
varSystemTime: TSystemTime;
beginwith SystemTime dobeginDecodeDate(DateTime, wYear, wMonth, wDay);DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds);end;Result := LocalSystemTimeToFileTime(SystemTime);
end;// 文件时间转本地时间
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
varSTime: TSystemTime;
beginFileTimeToLocalFileTime(FTime, FTime);FileTimeToSystemTime(FTime, STime);Result := STime;
end;// 本地时间转文件时间
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
varFTime: TFileTime;
beginSystemTimeToFileTime(STime, FTime);LocalFileTimeToFileTime(FTime, FTime);Result := FTime;
end;constMinutesPerDay = 60 * 24;SecondsPerDay = MinutesPerDay * 60;// UTC 时间转本地时间
function DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;
varTimeZoneInfo: TTimeZoneInformation;
beginFillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);if GetTimeZoneInformation(TimeZoneInfo) = TIME_ZONE_ID_DAYLIGHT thenResult := DateTime - ((TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / MinutesPerDay)elseResult := DateTime - (TimeZoneInfo.Bias / MinutesPerDay);
end;// 本地时间转 UTC 时间
function LocalDateTimeToDateTime(DateTime: TDateTime): TDateTime;
varTimeZoneInfo: TTimeZoneInformation;
beginFillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0);if GetTimeZoneInformation(TimeZoneInfo) = TIME_ZONE_ID_DAYLIGHT thenResult := DateTime + ((TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / MinutesPerDay)elseResult := DateTime + (TimeZoneInfo.Bias / MinutesPerDay);
end;{$IFDEF COMPILER5}
constLessThanValue = Low(TValueRelationship);EqualsValue = 0;GreaterThanValue = High(TValueRelationship);function CompareValue(const A, B: Int64): TValueRelationship;
beginif A = B thenResult := EqualsValueelse if A < B thenResult := LessThanValueelseResult := GreaterThanValue;
end;// AText 是否以 ASubText 开头
function AnsiStartsText(const ASubText, AText: string): Boolean;
beginResult := AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText)) = 1;
end;function AnsiReplaceText(const AText, AFromText, AToText: string): string;
beginResult := StringReplace(AText, AFromText, AToText, [rfReplaceAll, rfIgnoreCase]);
end;
{$ENDIF}{$IFNDEF COMPILER7_UP}
// AText 是否包含 ASubText
function AnsiContainsText(const AText, ASubText: string): Boolean;
beginResult := AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText)) > 0;
end;
{$ENDIF}// 比较 SubText 在两个字符串中出现的位置的大小，如果相等则比较字符串本身，忽略大小写
function CompareTextPos(const ASubText, AText1, AText2: string): TValueRelationship;
beginResult := 0;if ASubText <> '' thenResult := CompareValue(AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText1)),AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText2)));if Result = 0 thenResult := CompareText(AText1, AText2);
end;// 创建备份文件
function CreateBakFile(const FileName, Ext: string): Boolean;
varBakFileName: string;AExt: string;
beginif (Ext <> '') and (Ext[1] = '.') thenAExt := ExtelseAExt := '.' + Ext;BakFileName := FileName + AExt;Result := CopyFile(PChar(FileName), PChar(BakFileName), False);
end;// 删除整个目录
function Deltree(Dir: string; DelRoot: Boolean; DelEmptyDirOnly: Boolean): Boolean;
varsr: TSearchRec;fr: Integer;
beginResult := True;if not DirectoryExists(Dir) thenExit;fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);trywhile fr = 0 dobeginif (sr.Name <> '.') and (sr.Name <> '..') thenbeginSetFileAttributes(PChar(AddDirSuffix(Dir) + sr.Name), FILE_ATTRIBUTE_NORMAL);if sr.Attr and faDirectory = faDirectory thenResult := Deltree(AddDirSuffix(Dir) + sr.Name, True, DelEmptyDirOnly)else if not DelEmptyDirOnly thenResult := DeleteFile(AddDirSuffix(Dir) + sr.Name);end;fr := FindNext(sr);end;finallyFindClose(sr);end;if DelRoot thenResult := RemoveDir(Dir);
end;// 删除整个目录中的空目录, DelRoot 表示是否删除目录本身
procedure DelEmptyTree(Dir: string; DelRoot: Boolean = True);
varsr: TSearchRec;fr: Integer;
beginfr := FindFirst(AddDirSuffix(Dir) + '*.*', faDirectory, sr);trywhile fr = 0 dobeginif (sr.Name <> '.') and (sr.Name <> '..') and (sr.Attr and faDirectory= faDirectory) thenbeginSetFileAttributes(PChar(AddDirSuffix(Dir) + sr.Name), FILE_ATTRIBUTE_NORMAL);DelEmptyTree(AddDirSuffix(Dir) + sr.Name, True);end;fr := FindNext(sr);end;finallyFindClose(sr);end;if DelRoot thenRemoveDir(Dir);
end;// 取文件夹文件数
function GetDirFiles(Dir: string): Integer;
varsr: TSearchRec;fr: Integer;
beginResult := 0;fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);while fr = 0 dobeginif (sr.Name <> '.') and (sr.Name <> '..') thenInc(Result);fr := FindNext(sr);end;FindClose(sr);
end;function FindFormByClass(AClass: TClass): TForm;
vari: Integer;
beginResult := nil;for i := 0 to Screen.FormCount - 1 dobeginif Screen.Forms[i] is AClass thenbeginResult := Screen.Forms[i];Exit;end;end;
end;varFindAbort: Boolean;// 查找指定目录下文件
function FindFile(const Path: string; const FileName: string = '*.*';Proc: TFindCallBack = nil; DirProc: TDirCallBack = nil; bSub: Boolean = True;bMsg: Boolean = True): Boolean;procedure DoFindFile(const Path, SubPath: string; const FileName: string;Proc: TFindCallBack; DirProc: TDirCallBack; bSub: Boolean;bMsg: Boolean);varAPath: string;Info: TSearchRec;Succ: Integer;beginFindAbort := False;APath := MakePath(MakePath(Path) + SubPath);Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info);trywhile Succ = 0 dobeginif (Info.Name <> '.') and (Info.Name <> '..') thenbeginif (Info.Attr and faDirectory) <> faDirectory thenbeginif Assigned(Proc) thenProc(APath + Info.FindData.cFileName, Info, FindAbort);endend;if bMsg thenApplication.ProcessMessages;if FindAbort thenExit;Succ := FindNext(Info);end;finallyFindClose(Info);end;if bSub thenbeginSucc := FindFirst(APath + '*.*', faAnyFile - faVolumeID, Info);trywhile Succ = 0 dobeginif (Info.Name <> '.') and (Info.Name <> '..') and(Info.Attr and faDirectory = faDirectory) thenbeginif Assigned(DirProc) thenDirProc(MakePath(SubPath) + Info.Name);DoFindFile(Path, MakePath(SubPath) + Info.Name, FileName, Proc,DirProc, bSub, bMsg);if FindAbort thenExit;end;Succ := FindNext(Info);end;finallyFindClose(Info);end;end;end;beginDoFindFile(Path, '', FileName, Proc, DirProc, bSub, bMsg);Result := not FindAbort;
end;// 文件打开方式
function OpenWith(const FileName: string): Integer;
beginResult := ShellExecute(Application.Handle, 'open', 'rundll32.exe',PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);
end;// 检查指定的应用程序是否正在运行
// 作者：周劲羽 2002.08.12
function CheckAppRunning(const FileName: string; var Running: Boolean): Boolean;
varhSnap: THandle;ppe: TProcessEntry32;AName: string;
beginResult := False;AName := Trim(FileName);if AName = '' then Exit; // 如果为空直接退出if ExtractFileExt(FileName) = '' then // 默认扩展名为 EXEAName := AName + '.EXE';hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); // 创建当前进程快照if hSnap <> INVALID_HANDLE_VALUE thentryif Process32First(hSnap, ppe) then // 取第一个进程信息repeatif AnsiCompareText(ExtractFileName(ppe.szExeFile), AName) = 0 thenbegin // 比较应用程序名Running := True;Result := True;Exit;end;until not Process32Next(hSnap, ppe); // 取下一个进程信息Result := GetLastError = ERROR_NO_MORE_FILES; // 判断查找是否正常结束finallyCloseHandle(hSnap); // 关闭句柄end;
end;// 取文件版本号
function GetFileVersionNumber(const FileName: string): TVersionNumber;
varVersionInfoBufferSize: DWORD;dummyHandle: DWORD;VersionInfoBuffer: Pointer;FixedFileInfoPtr: PVSFixedFileInfo;VersionValueLength: UINT;
beginFillChar(Result, SizeOf(Result), 0);if not FileExists(FileName) thenExit;VersionInfoBufferSize := GetFileVersionInfoSize(PChar(FileName), dummyHandle);if VersionInfoBufferSize = 0 thenExit;GetMem(VersionInfoBuffer, VersionInfoBufferSize);trytryWin32Check(GetFileVersionInfo(PChar(FileName), dummyHandle,VersionInfoBufferSize, VersionInfoBuffer));Win32Check(VerQueryValue(VersionInfoBuffer, '\',Pointer(FixedFileInfoPtr), VersionValueLength));exceptExit;end;Result.Major := FixedFileInfoPtr^.dwFileVersionMS shr 16;Result.Minor := FixedFileInfoPtr^.dwFileVersionMS;Result.Release := FixedFileInfoPtr^.dwFileVersionLS shr 16;Result.Build := FixedFileInfoPtr^.dwFileVersionLS;finallyFreeMem(VersionInfoBuffer);end;
end;// 取文件版本字符串
function GetFileVersionStr(const FileName: string): string;
beginwith GetFileVersionNumber(FileName) doResult := Format('%d.%d.%d.%d', [Major, Minor, Release, Build]);
end;// 取文件信息
function GetFileInfo(const FileName: string; var FileSize: Int64;var FileTime: TDateTime): Boolean;
varHandle: THandle;FindData: TWin32FindData;
beginResult := False;Handle := FindFirstFile(PChar(FileName), FindData);if Handle <> INVALID_HANDLE_VALUE thenbeginWindows.FindClose(Handle);if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 thenbeginInt64Rec(FileSize).Lo := FindData.nFileSizeLow;Int64Rec(FileSize).Hi := FindData.nFileSizeHigh;FileTime := FileTimeToDateTime(FindData.ftLastWriteTime);Result := True;end;end;
end;// 取文件长度
function GetFileSize(const FileName: string): Int64;
varFileTime: TDateTime;
beginResult := -1;GetFileInfo(FileName, Result, FileTime);
end;// 取文件Delphi格式日期时间
function GetFileDateTime(const FileName: string): TDateTime;
varSize: Int64;
beginResult := 0;GetFileInfo(FileName, Size, Result);
end;// 将文件读为字符串
function LoadStringFromFile(const FileName: string): string;
begintrywith TStringList.Create dotryLoadFromFile(FileName);Result := Text;finallyFree;end;exceptResult := '';end;
end;// 保存字符串到为文件
function SaveStringToFile(const S, FileName: string): Boolean;
begintrywith TStringList.Create dotryText := S;SaveToFile(FileName);Result := True;finallyFree;end;exceptResult := False;end;
end;//------------------------------------------------------------------------------
// 环境变量相关
//------------------------------------------------------------------------------procedure MultiSzToStrings(const Dest: TStrings; const Source: PChar);
varP: PChar;
beginAssert(Dest <> nil);Dest.Clear;if Source <> nil thenbeginP := Source;while P^ <> #0 dobeginDest.Add(P);P := StrEnd(P);Inc(P);end;end;
end;function DelEnvironmentVar(const Name: string): Boolean;
beginResult := SetEnvironmentVariable(PChar(Name), nil);
end;function ExpandEnvironmentVar(var Value: string): Boolean;
varR: Integer;Expanded: string;
beginSetLength(Expanded, 1);R := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), 0);SetLength(Expanded, R);Result := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), R) <> 0;if Result thenbeginStrResetLength(Expanded);Value := Expanded;end;
end;function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;
varR: DWORD;
beginR := GetEnvironmentVariable(PChar(Name), nil, 0);SetLength(Value, R);R := GetEnvironmentVariable(PChar(Name), PChar(Value), R);Result := R <> 0;if not Result thenValue := ''elsebeginSetLength(Value, R);if Expand thenExpandEnvironmentVar(Value);end;
end;function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;
varRaw: PChar;Expanded: string;I: Integer;
beginVars.Clear;Raw := GetEnvironmentStrings;tryMultiSzToStrings(Vars, Raw);Result := True;finallyFreeEnvironmentStrings(Raw);end;if Expand thenbeginfor I := 0 to Vars.Count - 1 dobeginExpanded := Vars[I];if ExpandEnvironmentVar(Expanded) thenVars[I] := Expanded;end;end;
end;function SetEnvironmentVar(const Name, Value: string): Boolean;
beginResult := SetEnvironmentVariable(PChar(Name), PChar(Value));
end;//------------------------------------------------------------------------------
// 扩展的字符串操作函数
//------------------------------------------------------------------------------// 判断字符串是否可转换成浮点型
function IsFloat(const s: String): Boolean;
varI: Real;E: Integer;
beginVal(s, I, E);Result := E = 0;E := Trunc( I );
end;// 判断字符串是否可转换成整型
function IsInt(const s: String): Boolean;
varI: Integer;E: Integer;
beginVal(s, I, E);Result := E = 0;E := Trunc( I );
end;// 判断字符串是否可转换成 DateTime
function IsDateTime(const s: string): Boolean;
begintryStrToDateTime(s);Result := True;exceptResult := False;end;
end;// 判断是否有效的邮件地址
function IsValidEmail(const s: string): Boolean;
vari: Integer;AtCount: Integer;
beginResult := False;if s = '' then Exit;AtCount := 0;for i := 1 to Length(s) dobeginif s[i] = '@' thenbeginInc(AtCount);if AtCount > 1 thenExit;endelse if not (s[i] in ['0'..'9', 'a'..'z', 'A'..'Z', '_', '.', '-']) thenExit;end;Result := AtCount = 1;
end;// 判断s1是否包含在s2中
function InStr(const sShort: string; const sLong: string): Boolean;
vars1, s2: string;
begins1 := LowerCase(sShort);s2 := LowerCase(sLong);Result := Pos(s1, s2) > 0;
end;// 扩展整数转字符串函数，参数分别为目标数、长度、填充字符（默认为０）
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
beginResult := IntToStr(Value);while Length(Result) < Len doResult := FillChar + Result;
end;// 带分隔符的整数－字符转换
function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
vars: string;i, j: Integer;
begins := IntToStr(Value);Result := '';j := 0;for i := Length(s) downto 1 dobeginResult := s[i] + Result;Inc(j);if ((j mod SpLen) = 0) and (i <> 1) then Result := Sp + Result;end;
end;function StrSpToInt(Value: String; Sp: Char = ','): Int64;
beginResult := StrToInt64(AnsiReplaceText(Value, Sp, ''));
end;// 返回字符串右边的字符
function StrRight(Str: string; Len: Integer): string;
beginif Len >= Length(Str) thenResult := ''elseResult := Copy(Str, Length(Str) - Len + 1, Len);
end;// 返回字符串左边的字符
function StrLeft(Str: string; Len: Integer): string;
beginif Len >= Length(Str) thenResult := StrelseResult := Copy(Str, 1, Len);
end;// 字节转二进制串
function ByteToBin(Value: Byte): string;
constV: Byte = 1;
vari: Integer;
beginfor i := 7 downto 0 doif (V shl i) and Value <> 0 thenResult := Result + '1'elseResult := Result + '0';
end;// 返回字符串行
function GetLine(C: Char; Len: Integer): string;
beginResult := StringOfChar(C, Len);
end;// 返回文本文件的行数
function GetTextFileLineCount(FileName: String): Integer;
varLines: TStringList;
beginResult := 0;Lines := TStringList.Create;tryif FileExists(FileName) thenbeginLines.LoadFromFile(FileName);Result := Result + Lines.Count;end;finallyLines.Free;end;
end;// 返回空格串
function Spc(Len: Integer): string;
beginResult := StringOfChar(' ', Len);
end;// 交换字串
procedure SwapStr(var s1, s2: string);
vartempstr: string;
begintempstr := s1;s1 := s2;s2 := tempstr;
end;// 分割"非数字+数字"格式的字符串中的非数字和数字
procedure SeparateStrAndNum(const AInStr: string; var AOutStr: string;var AOutNum: Integer);
variLen: Integer;
beginiLen := Length(AInStr);while (iLen > 0) and (AInStr[iLen] in ['0'..'9']) do Dec(iLen);AOutStr := Copy(AInStr, iLen + 1, MaxInt);if AOutStr = '' thenAOutNum := -1elseAOutNum := StrToInt(AOutStr);AOutStr := Copy(AInStr, 1, iLen);
end;// 去除被引用的字符串的引用
function UnQuotedStr(const str: string; const ch: Char;const sep: string = ''): string;
vars: string;ps: PChar;
beginResult := '';s := str;ps := PChar(s);while ps <> nil dobeginps := AnsiStrScan(ps, ch);s := AnsiExtractQuotedStr(ps, ch);if (Result = '') or (s = '') thenResult := Result + selseResult := Result + sep + s;end;
end;// 查找字符串中出现的第 Counter 次的字符的位置
function CharPosWithCounter(const Sub: Char; const AStr: string;Counter: Integer = 1): Integer;
varI, J: Integer;
beginResult := 0;if Counter <= 0 then Exit;if AStr <> '' thenbeginJ := 0;for I := 1 to Length(AStr) dobeginif AStr[I] = Sub thenInc(J);if J = Counter thenbeginResult := I;Exit;end;end;end;
end;function CountCharInStr(const Sub: Char; const AStr: string): Integer;
varI: Integer;
beginResult := 0;if AStr = '' then Exit;for I := 1 to Length(AStr) doif AStr[I] = Sub thenInc(Result);
end;// 判断字符是否有效标识符字符，First 表示是否为首字符
function IsValidIdentChar(C: Char; First: Boolean): Boolean;
beginif First thenResult := C in AlphaelseResult := C in AlphaNumeric;
end;constcsLinesCR = #13#10;csStrCR = '\n';// 多行文本转单行（换行符转'\n'）
{$IFDEF COMPILER5}
function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;
constcSimpleBoolStrs: array [boolean] of String = ('0', '-1');
beginif UseBoolStrs thenbeginif B thenResult := 'True'elseResult := 'False';endelseResult := cSimpleBoolStrs[B];
end;
{$ENDIF COMPILER5}function LinesToStr(const Lines: string): string;
beginResult := StringReplace(Lines, csLinesCR, csStrCR, [rfReplaceAll]);
end;// 单行文本转多行（'\n'转换行符）
function StrToLines(const Str: string): string;
beginResult := StringReplace(Str, csStrCR, csLinesCR, [rfReplaceAll]);
end;// 日期转字符串，使用 yyyy.mm.dd 格式
function MyDateToStr(Date: TDate): string;
beginResult := CnDateToStr(Date);
end;constcsCount = 'Count';csItem = 'Item';procedure ReadStringsFromIni(Ini: TCustomIniFile; const Section: string; Strings: TStrings);
varCount, i: Integer;
beginStrings.Clear;Count := Ini.ReadInteger(Section, csCount, 0);for i := 0 to Count - 1 doif Ini.ValueExists(Section, csItem + IntToStr(i)) thenStrings.Add(Ini.ReadString(Section, csItem + IntToStr(i), ''));
end;procedure WriteStringsToIni(Ini: TCustomIniFile; const Section: string; Strings: TStrings);
vari: Integer;
beginIni.WriteInteger(Section, csCount, Strings.Count);for i := 0 to Strings.Count - 1 doIni.WriteString(Section, csItem + IntToStr(i), Strings[i]);
end;// 版本号转成字符串，如 $01020000 --> '1.2.0.0'
function VersionToStr(Version: DWORD): string;
beginResult := Format('%d.%d.%d.%d', [Version div $1000000, version mod $1000000div $10000, version mod $10000 div $100, version mod $100]);
end;// 字符串转成版本号，如 '1.2.0.0' --> $01020000，如果格式不正确，返回 $01000000
function StrToVersion(s: string): DWORD;
varStrs: TStrings;
begintryStrs := TStringList.Create;tryStrs.Text := StringReplace(s, '.', #13#10, [rfReplaceAll]);if Strs.Count = 4 thenResult := StrToInt(Strs[0]) * $1000000 + StrToInt(Strs[1]) * $10000 +StrToInt(Strs[2]) * $100 + StrToInt(Strs[3])elseResult := $01000000;finallyStrs.Free;end;exceptResult := $01000000;end;
end;// 转换日期为 yyyy.mm.dd 格式字符串
function CnDateToStr(Date: TDateTime): string;
beginResult := FormatDateTime('yyyy.mm.dd', Date);
end;// 将 yyyy.mm.dd 格式字符串转换为日期
function CnStrToDate(const S: string): TDateTime;
vari: Integer;Year, Month, Day: string;
begintryi := 1;Year := ExtractSubstr(S, i, ['.', '/', '-']);Month := ExtractSubstr(S, i, ['.', '/', '-']);Day := ExtractSubstr(S, i, ['.', '/', '-']);Result := EncodeDate(StrToInt(Year), StrToInt(Month), StrToInt(Day));exceptResult := 0;end;
end;// 日期时间转 '20030203132345' 式样的 14 位数字字符串
function DateTimeToFlatStr(const DateTime: TDateTime): string;
varYear, Month, Day, Hour, Min, Sec, MSec: Word;
beginDecodeDate(DateTime, Year, Month, Day);DecodeTime(DateTime, Hour, Min, Sec, MSec);Result := IntToStrEx(Year, 4) + IntToStrEx(Month, 2) + IntToStrEx(Day, 2) +IntToStrEx(Hour, 2) + IntToStrEx(Min, 2) + IntToStrEx(Sec, 2);
end;// '20030203132345' 式样的 14 位数字字符串转日期时间
function FlatStrToDateTime(const Section: string; var DateTime: TDateTime): Boolean;
varYear, Month, Day, Hour, Min, Sec, MSec: Word;
begintryResult := False;if Length(Section) <> 14 then Exit;Year := StrToInt(Copy(Section, 1, 4));Month := StrToInt(Copy(Section, 5, 2));Day := StrToInt(Copy(Section, 7, 2));Hour := StrToInt(Copy(Section, 9, 2));Min := StrToInt(Copy(Section, 11, 2));Sec := StrToInt(Copy(Section, 13, 2));MSec := 0;DateTime := EncodeDate(Year, Month, Day) + EncodeTime(Hour, Min, Sec, MSec);Result := True;exceptResult := False;end;
end;// 字符串转注册表根键，支持 'HKEY_CURRENT_USER' 'HKCR' 长短两种格式
function StrToRegRoot(const s: string): HKEY;
beginif SameText(s, 'HKEY_CLASSES_ROOT') or SameText(s, 'HKCR') thenResult := HKEY_CLASSES_ROOTelse if SameText(s, 'HKEY_CURRENT_USER') or SameText(s, 'HKCU') thenResult := HKEY_CURRENT_USERelse if SameText(s, 'HKEY_LOCAL_MACHINE') or SameText(s, 'HKLM') thenResult := HKEY_LOCAL_MACHINEelse if SameText(s, 'HKEY_USERS') or SameText(s, 'HKU') thenResult := HKEY_USERSelse if SameText(s, 'HKEY_PERFORMANCE_DATA') or SameText(s, 'HKPD') thenResult := HKEY_PERFORMANCE_DATAelse if SameText(s, 'HKEY_CURRENT_CONFIG') or SameText(s, 'HKCC') thenResult := HKEY_CURRENT_CONFIGelse if SameText(s, 'HKEY_DYN_DATA') or SameText(s, 'HKDD') thenResult := HKEY_DYN_DATAelseResult := HKEY_CURRENT_USER;
end;// 注册表根键转字符串，可选 'HKEY_CURRENT_USER' 'HKCR' 长短两种格式
function RegRootToStr(Key: HKEY; ShortFormat: Boolean): string;
beginif Key = HKEY_CLASSES_ROOT thenif ShortFormat thenResult := 'HKCR'elseResult := 'HKEY_CLASSES_ROOT'else if Key = HKEY_CURRENT_USER thenif ShortFormat thenResult := 'HKCU'elseResult := 'HKEY_CURRENT_USER'else if Key = HKEY_LOCAL_MACHINE thenif ShortFormat thenResult := 'HKLM'elseResult := 'HKEY_LOCAL_MACHINE'else if Key = HKEY_USERS thenif ShortFormat thenResult := 'HKU'elseResult := 'HKEY_USERS'else if Key = HKEY_PERFORMANCE_DATA thenif ShortFormat thenResult := 'HKPD'elseResult := 'HKEY_PERFORMANCE_DATA'else if Key = HKEY_CURRENT_CONFIG thenif ShortFormat thenResult := 'HKCC'elseResult := 'HKEY_CURRENT_CONFIG'else if Key = HKEY_DYN_DATA thenif ShortFormat thenResult := 'HKDD'elseResult := 'HKEY_DYN_DATA'elseResult := ''
end;// 从字符串中分离出子串
function ExtractSubstr(const S: string; var Pos: Integer;const Delims: TSysCharSet): string;
vari: Integer;
begini := Pos;while (i <= Length(S)) and not (S[i] in Delims) do Inc(i);Result := Copy(S, Pos, i - Pos);if (i <= Length(S)) and (S[i] in Delims) then Inc(i);Pos := i;
end;// 文件名通配符比较
function WildcardCompare(const FileWildcard, FileName: string; const IgnoreCase:Boolean): Boolean;function WildCompare(var WildS, IstS: string): Boolean;varWildPos, FilePos, l, p: Integer;begin// Start at the first wildcard/filename characterWildPos := 1; // Wildcard position.FilePos := 1; // FileName position.while (WildPos <= Length(WildS)) dobegin// '*' matches any sequence of characters.if WildS[WildPos] = '*' thenbegin// We've reached the end of the wildcard string with a * and are done.if WildPos = Length(WildS) thenbeginResult := True;Exit;endelsebeginl := WildPos + 1;// Anything after a * in the wildcard must match literally.while (l < Length(WildS)) and (WildS[l + 1] <> '*') doInc(l);// Check for the literal match immediately after the current position.p := Pos(Copy(WildS, WildPos + 1, l - WildPos), IstS);if p > 0 thenFilePos := p - 1elsebeginResult := False;Exit;end;end;end// '?' matches any character - other characters must literally match.else if (WildS[WildPos] <> '?') and ((Length(IstS) < WildPos) or(WildS[WildPos] <> IstS[FilePos])) thenbeginResult := False;Exit;end;// Match is OK so far - check the next character.Inc(WildPos);Inc(FilePos);end;Result := (FilePos > Length(IstS));end;function LastCharPos(const S: string; C: Char): Integer;vari: Integer;begini := Length(S);while (i > 0) and (S[i] <> C) doDec(i);Result := i;end;varNameWild, NameFile, ExtWild, ExtFile: string;DotPos: Integer;
begin// Parse to find the extension and name base of filename and wildcard.DotPos := LastCharPos(FileWildcard, '.');if DotPos = 0 thenbegin// Assume .* if an extension is missingNameWild := FileWildcard;ExtWild := '*';endelsebeginNameWild := Copy(FileWildcard, 1, DotPos - 1);ExtWild := Copy(FileWildcard, DotPos + 1, Length(FileWildcard));end;// We could probably modify this to use ExtractFileExt, etc.DotPos := LastCharPos(FileName, '.');if DotPos = 0 thenDotPos := Length(FileName) + 1;NameFile := Copy(FileName, 1, DotPos - 1);ExtFile := Copy(FileName, DotPos + 1, Length(FileName));// Case insensitive checkif IgnoreCase thenbeginNameWild := AnsiUpperCase(NameWild);NameFile := AnsiUpperCase(NameFile);ExtWild := AnsiUpperCase(ExtWild);ExtFile := AnsiUpperCase(ExtFile);end;// Both the extension and the filename must matchResult := WildCompare(NameWild, NameFile) and WildCompare(ExtWild, ExtFile);
end;// 根据当前键盘布局将键盘扫描码转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用
// 由于不调用 ToAscii，故可支持使用 Accent Character 的键盘布局
function ScanCodeToAscii(Code: Word): Char;
vari: Byte;C: Cardinal;
beginC := Code;if GetKeyState(VK_SHIFT) < 0 thenC := C or $10000;if GetKeyState(VK_CONTROL) < 0 thenC := C or $20000;if GetKeyState(VK_MENU) < 0 thenC := C or $40000;for i := Low(Byte) to High(Byte) doif OemKeyScan(i) = C thenbeginResult := Char(i);Exit;end;Result := #0;
end;// 返回一个虚拟键是否 Dead key
function IsDeadKey(Key: Word): Boolean;
beginResult := MapVirtualKey(Key, 2) and $80000000 <> 0;
end;// 根据当前键盘状态将虚拟键转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用
// 可能会导致 Accent Character 不正确
function VirtualKeyToAscii(Key: Word): Char;
varKeyState: TKeyboardState;ScanCode: Word;Buff: array[0..1] of Char;
beginResult := #0;if not IsDeadKey(Key) thenbegincase Key ofVK_SHIFT, VK_CONTROL, VK_MENU:;elsebeginScanCode := MapVirtualKey(Key, 0);GetKeyboardState(KeyState);if ToAscii(Key, ScanCode, KeyState, @Buff, 0) = 1 thenResult := Buff[0];end;end;end;
end;// 根据当前的键盘布局将虚拟键和扫描码转换成 ASCII 字符。通过虚拟键来处理小键盘，
// 扫描码处理大键盘，支持 Accent Character 的键盘布局
function VK_ScanCodeToAscii(VKey: Word; Code: Word): Char;
beginif (VKey >= VK_NUMPAD0) and (VKey <= VK_DIVIDE) thenbegincase VKey ofVK_NUMPAD0..VK_NUMPAD9:if IsNumLockDown thenResult := Char(Ord('0') + VKey - VK_NUMPAD0)elseResult := #0;VK_MULTIPLY: Result := '*';VK_ADD: Result := '+';VK_SEPARATOR: Result := #13;VK_SUBTRACT: Result := '-';VK_DECIMAL: Result := '.';VK_DIVIDE: Result := '/';elseResult := #0;end;endelsebeginResult := ScanCodeToAscii(Code);end;
end;// 返回当前的按键状态，暂不支持 ssDouble 状态
function GetShiftState: TShiftState;
varKeyState: TKeyboardState;function IsDown(Key: Byte): Boolean;beginResult := (Key and $80) = $80;end;
beginResult := [];GetKeyboardState(KeyState);if IsDown(KeyState[VK_LSHIFT]) or IsDown(KeyState[VK_RSHIFT]) thenInclude(Result, ssShift);if IsDown(KeyState[VK_LMENU]) or IsDown(KeyState[VK_RMENU]) thenInclude(Result, ssAlt);if IsDown(KeyState[VK_LCONTROL]) or IsDown(KeyState[VK_RCONTROL]) thenInclude(Result, ssCtrl);if IsDown(KeyState[VK_LBUTTON]) thenInclude(Result, ssLeft);if IsDown(KeyState[VK_RBUTTON]) thenInclude(Result, ssRight);if IsDown(KeyState[VK_MBUTTON]) thenInclude(Result, ssMiddle);
end;// 判断当前 Shift 是否按下
function IsShiftDown: Boolean;
beginResult := ssShift in GetShiftState;
end;// 判断当前 Alt 是否按下
function IsAltDown: Boolean;
beginResult := ssAlt in GetShiftState;
end;// 判断当前 Ctrl 是否按下
function IsCtrlDown: Boolean;
beginResult := ssCtrl in GetShiftState;
end;// 判断当前 Insert 是否按下
function IsInsertDown: Boolean;
varKeyState: TKeyboardState;
beginGetKeyboardState(KeyState);Result := Odd(KeyState[VK_INSERT]);
end;// 判断当前 Caps Lock 是否按下
function IsCapsLockDown: Boolean;
varKeyState: TKeyboardState;
beginGetKeyboardState(KeyState);Result := Odd(KeyState[VK_CAPITAL]);
end;// 判断当前 NumLock 是否按下
function IsNumLockDown: Boolean;
varKeyState: TKeyboardState;
beginGetKeyboardState(KeyState);Result := Odd(KeyState[VK_NUMLOCK]);
end;// 判断当前 Scroll Lock 是否按下
function IsScrollLockDown: Boolean;
varKeyState: TKeyboardState;
beginGetKeyboardState(KeyState);Result := Odd(KeyState[VK_SCROLL]);
end;// 删除类名前缀 T
function RemoveClassPrefix(const ClassName: string): string;
beginResult := ClassName;if (Result <> '') and (UpperCase(Result[1]) = 'T') thenDelete(Result, 1, 1);
end;// 用分号分隔的作者、邮箱字符串转换为输出格式
function CnAuthorEmailToStr(Author, Email: string): string;
vars1, s2: string;function GetLeftStr(var s: string; Sep: string): string;vari: Integer;beginResult := '';i := AnsiPos(Sep, s);if i > 0 thenbeginResult := Trim(Copy(s, 1, i - 1));Delete(s, 1, i);endelse beginResult := s;s := '';end;end;
beginResult := '';s1 := GetLeftStr(Author, ';');s2 := GetLeftStr(Email, ';');while s1 <> '' dobeginif Result <> '' then Result := Result + #13#10;Result := Result + s1;if s2 <> '' then Result := Result + ' (' + s2 + ')';s1 := GetLeftStr(Author, ';');s2 := GetLeftStr(Email, ';');end;
end;//------------------------------------------------------------------------------
// 扩展的对话框函数
//------------------------------------------------------------------------------// 显示提示窗口
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
beginif Caption = '' thenCaption := SCnInformation;Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;// 显示提示确认窗口
function InfoOk(Mess: string; Caption: string): Boolean;
beginif Caption = '' thenCaption := SCnInformation;Result := Application.MessageBox(PChar(Mess), PChar(Caption),MB_OKCANCEL + MB_ICONINFORMATION) = IDOK;
end;// 显示错误窗口
procedure ErrorDlg(Mess: string; Caption: string);
beginif Caption = '' thenCaption := SCnError;Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;// 显示警告窗口
procedure WarningDlg(Mess: string; Caption: string);
beginif Caption = '' thenCaption := SCnWarning;Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;// 显示查询是否窗口
function QueryDlg(Mess: string; DefaultNo: Boolean; Caption: string): Boolean;
constDefaults: array[Boolean] of DWORD = (0, MB_DEFBUTTON2);
beginif Caption = '' thenCaption := SCnInformation;Result := Application.MessageBox(PChar(Mess), PChar(Caption),MB_YESNO + MB_ICONQUESTION + Defaults[DefaultNo]) = IDYES;
end;function GetAveCharSize(Canvas: TCanvas): TPoint;
varI: Integer;Buffer: array[0..51] of Char;
beginfor I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));Result.X := Result.X div 52;
end;// 输入对话框
function CnInputQuery(const ACaption, APrompt: string;var Value: string; Ini: TCustomIniFile; const Section: string): Boolean;
varForm: TForm;Prompt: TLabel;Edit: TEdit;ComboBox: TComboBox;DialogUnits: TPoint;ButtonTop, ButtonWidth, ButtonHeight: Integer;
beginResult := False;Edit := nil;ComboBox := nil;Form := TForm.Create(Application);with Form dotryScaled := False;Font.Handle := GetStockObject(DEFAULT_GUI_FONT);Canvas.Font := Font;DialogUnits := GetAveCharSize(Canvas);BorderStyle := bsDialog;Caption := ACaption;ClientWidth := MulDiv(180, DialogUnits.X, 4);ClientHeight := MulDiv(63, DialogUnits.Y, 8);Position := poScreenCenter;Prompt := TLabel.Create(Form);with Prompt dobeginParent := Form;AutoSize := True;Left := MulDiv(8, DialogUnits.X, 4);Top := MulDiv(8, DialogUnits.Y, 8);Caption := APrompt;end;if Assigned(Ini) thenbeginComboBox := TComboBox.Create(Form);with ComboBox dobeginParent := Form;Left := Prompt.Left;Top := MulDiv(19, DialogUnits.Y, 8);Width := MulDiv(164, DialogUnits.X, 4);MaxLength := 255;ReadStringsFromIni(Ini, Section, ComboBox.Items);if (Value = '') and (ComboBox.Items.Count > 0) thenText := ComboBox.Items[0]elseText := Value;SelectAll;end;endelsebeginEdit := TEdit.Create(Form);with Edit dobeginParent := Form;Left := Prompt.Left;Top := MulDiv(19, DialogUnits.Y, 8);Width := MulDiv(164, DialogUnits.X, 4);MaxLength := 255;Text := Value;SelectAll;end;end;ButtonTop := MulDiv(41, DialogUnits.Y, 8);ButtonWidth := MulDiv(50, DialogUnits.X, 4);ButtonHeight := MulDiv(14, DialogUnits.Y, 8);with TButton.Create(Form) dobeginParent := Form;Caption := SCnMsgDlgOK;ModalResult := mrOk;Default := True;SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,ButtonHeight);end;with TButton.Create(Form) dobeginParent := Form;Caption := SCnMsgDlgCancel;ModalResult := mrCancel;Cancel := True;SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,ButtonHeight);end;if ShowModal = mrOk thenbeginif Assigned(ComboBox) thenbeginValue := ComboBox.Text;AddComboBoxTextToItems(ComboBox);WriteStringsToIni(Ini, Section, ComboBox.Items);endelseValue := Edit.Text;Result := True;end;finallyForm.Free;end;
end;// 输入对话框
function CnInputBox(const ACaption, APrompt, ADefault: string;Ini: TCustomIniFile; const Section: string): string;
beginResult := ADefault;CnInputQuery(ACaption, APrompt, Result, Ini, Section);
end;//------------------------------------------------------------------------------
// 位扩展日期时间操作函数
//------------------------------------------------------------------------------function GetYear(Date: TDate): Integer;
vary, m, d: WORD;
beginDecodeDate(Date, y, m, d);Result := y;
end;function GetMonth(Date: TDate): Integer;
vary, m, d: WORD;
beginDecodeDate(Date, y, m, d);Result := m;
end;function GetDay(Date: TDate): Integer;
vary, m, d: WORD;
beginDecodeDate(Date, y, m, d);Result := d;
end;function GetHour(Time: TTime): Integer;
varh, m, s, ms: WORD;
beginDecodeTime(Time, h, m, s, ms);Result := h;
end;function GetMinute(Time: TTime): Integer;
varh, m, s, ms: WORD;
beginDecodeTime(Time, h, m, s, ms);Result := m;
end;function GetSecond(Time: TTime): Integer;
varh, m, s, ms: WORD;
beginDecodeTime(Time, h, m, s, ms);Result := s;
end;function GetMSecond(Time: TTime): Integer;
varh, m, s, ms: WORD;
beginDecodeTime(Time, h, m, s, ms);Result := ms;
end;//------------------------------------------------------------------------------
// 位操作函数
//------------------------------------------------------------------------------// 设置位
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean);
beginif IsSet thenValue := Value or (1 shl Bit)elseValue := Value and not (1 shl Bit);
end;procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean);
beginif IsSet thenValue := Value or (1 shl Bit)elseValue := Value and not (1 shl Bit);
end;procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean);
beginif IsSet thenValue := Value or (1 shl Bit)elseValue := Value and not (1 shl Bit);
end;// 取位
function GetBit(Value: Byte; Bit: TByteBit): Boolean;
beginResult := Value and (1 shl Bit) <> 0;
end;function GetBit(Value: WORD; Bit: TWordBit): Boolean;
beginResult := Value and (1 shl Bit) <> 0;
end;function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;
beginResult := Value and (1 shl Bit) <> 0;
end;//------------------------------------------------------------------------------
// 系统功能函数
//------------------------------------------------------------------------------// 移动鼠标到控件
procedure MoveMouseIntoControl(AWinControl: TControl);
varrtControl: TRect;
beginrtControl := AWinControl.BoundsRect;MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2);SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2,rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2);
end;// 将 ComboBox 的文本内容增加到下拉列表中
procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10);
varText: string;
beginif ComboBox.Text <> '' thenbeginText := ComboBox.Text;if ComboBox.Items.IndexOf(ComboBox.Text) < 0 thenComboBox.Items.Insert(0, ComboBox.Text)elseComboBox.Items.Move(ComboBox.Items.IndexOf(ComboBox.Text), 0);while (MaxItemsCount > 1) and (ComboBox.Items.Count > MaxItemsCount) doComboBox.Items.Delete(ComboBox.Items.Count - 1);ComboBox.Text := Text;end;
end;// 动态设置分辨率
function DynamicResolution(x, y: WORD): Boolean;
varlpDevMode: TDeviceMode;
beginResult := EnumDisplaySettings(nil, 0, lpDevMode);if Result thenbeginlpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;lpDevMode.dmPelsWidth := x;lpDevMode.dmPelsHeight := y;Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;end;
end;// 窗口最上方显示
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
constcsOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
beginSetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE orSWP_NOACTIVATE);
end;varWndLong: Integer;// 设置程序是否出现在任务栏
procedure SetHidden(Hide: Boolean);
beginShowWindow(Application.Handle, SW_HIDE);if Hide thenSetWindowLong(Application.Handle, GWL_EXSTYLE,WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)elseSetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);ShowWindow(Application.Handle, SW_SHOW);
end;constcsWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);// 设置任务栏是否可见
procedure SetTaskBarVisible(Visible: Boolean);
varwndHandle: THandle;
beginwndHandle := FindWindow('Shell_TrayWnd', nil);ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;// 设置桌面是否可见
procedure SetDesktopVisible(Visible: Boolean);
varhDesktop: THandle;
beginhDesktop := FindWindow('Progman', nil);ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;// 强制让一个窗口显示在前台
function ForceForegroundWindow(HWND: HWND): Boolean;
varThreadID1, ThreadID2: DWORD;
beginif HWND = GetForegroundWindow thenResult := TrueelsebeginThreadID1 := GetWindowThreadProcessId(GetForegroundWindow, nil);ThreadID2 := GetWindowThreadProcessId(HWND, nil);if ThreadID1 <> ThreadID2 thenbeginAttachThreadInput(ThreadID1, ThreadID2, True);Result := SetForegroundWindow(HWND);AttachThreadInput(ThreadID1, ThreadID2, False);endelseResult := SetForegroundWindow(HWND);if IsIconic(HWND) thenShowWindow(HWND, SW_RESTORE)elseShowWindow(HWND, SW_SHOW);end;
end;// 取桌面区域
function GetWorkRect(const Form: TCustomForm = nil): TRect;
varMonitor: TMonitor;MonInfo: TMonitorInfo;
beginResult.Top := 0;Result.Left := 0;Result.Right := Screen.Width;Result.Bottom := Screen.Height;if Assigned(Form) thenbeginMonitor := Form.Monitor;if Assigned(Monitor) thenbeginMonInfo.cbSize := SizeOf(MonInfo);GetMonitorInfo(Monitor.Handle, @MonInfo);Result := MonInfo.rcWork;end;endelseSystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
end;// 显示等待光标
procedure BeginWait;
beginScreen.Cursor := crHourGlass;
end;// 结束等待光标
procedure EndWait;
beginScreen.Cursor := crDefault;
end;// 检测是否Win95/98平台
function CheckWindows9598: Boolean;
varV: TOSVersionInfo;
beginV.dwOSVersionInfoSize := SizeOf(V);Result := False;if not GetVersionEx(V) then Exit;if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS thenResult := True;
end;// 检测是否WinXP以上平台
function CheckWinXP: Boolean;
beginResult := (Win32MajorVersion > 5) or((Win32MajorVersion = 5) and (Win32MinorVersion >= 1));
end;// 获得Dll的版本信息
function DllGetVersion(const dllname: string;var DVI: TDLLVERSIONINFO2): Boolean;
type_DllGetVersion = function (var DVI: TDLLVERSIONINFO2): DWORD; stdcall;
varhMod:THandle;pfDllVersion: _DllGetVersion;
beginResult := False;hMod := LoadLibrary(PChar(dllname));if hMod <> 0 thentry@pfDllVersion := GetProcAddress(hMod, 'DllGetVersion');if @pfDllVersion = nil thenExit;FillChar(DVI, SizeOf(TDLLVERSIONINFO2), 0);DVI.info1.cbSize := SizeOf(TDLLVERSIONINFO2);Result := pfDllVersion(DVI) and $80000000 = 0;finallyFreeLibrary(hMod);end;
end;// 返回操作系统标识串
function GetOSString: string;
varOSPlatform: string;BuildNumber: Integer;
beginResult := 'Unknown Windows Version';OSPlatform := 'Windows';BuildNumber := 0;case Win32Platform ofVER_PLATFORM_WIN32_WINDOWS:beginBuildNumber := Win32BuildNumber and $0000FFFF;case Win32MinorVersion of0..9:beginif Trim(Win32CSDVersion) = 'B' thenOSPlatform := 'Windows 95 OSR2'elseOSPlatform := 'Windows 95';end;10..89:beginif Trim(Win32CSDVersion) = 'A' thenOSPlatform := 'Windows 98'elseOSPlatform := 'Windows 98 SE';end;90:OSPlatform := 'Windows Millennium';end;end;VER_PLATFORM_WIN32_NT:beginif Win32MajorVersion in [3, 4] thenOSPlatform := 'Windows NT'else if Win32MajorVersion = 5 thenbegincase Win32MinorVersion of0: OSPlatform := 'Windows 2000';1: OSPlatform := 'Windows XP';end;end;BuildNumber := Win32BuildNumber;end;VER_PLATFORM_WIN32s:beginOSPlatform := 'Win32s';BuildNumber := Win32BuildNumber;end;end;if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or(Win32Platform = VER_PLATFORM_WIN32_NT) thenbeginif Trim(Win32CSDVersion) = '' thenResult := Format('%s %d.%d (Build %d)', [OSPlatform, Win32MajorVersion,Win32MinorVersion, BuildNumber])elseResult := Format('%s %d.%d (Build %d: %s)', [OSPlatform, Win32MajorVersion,Win32MinorVersion, BuildNumber, Win32CSDVersion]);endelseResult := Format('%s %d.%d', [OSPlatform, Win32MajorVersion, Win32MinorVersion])
end;// 得到本机名
function GetComputeNameStr : string;
vardwBuff : DWORD;aryCmpName : array [0..255] of Char;
beginResult := '';dwBuff := 256;FillChar(aryCmpName, SizeOf(aryCmpName), 0);if GetComputerName(aryCmpName, dwBuff) thenResult := StrPas(aryCmpName);
end;// 得到本机用户名
function GetLocalUserName: string;
varCount: DWORD;
beginCount := 256 + 1; // UNLEN + 1// set buffer size to 256 + 2 charactersSetLength(Result, Count);if GetUserName(PChar(Result), Count) thenStrResetLength(Result)elseResult := '';
end;function REG_CURRENT_VERSION: string;
beginif CheckWindows9598 thenResult := HKLM_CURRENT_VERSION_WINDOWSelseResult := HKLM_CURRENT_VERSION_NT;
end;function GetRegisteredCompany: string;
beginResult := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOrganization', '');
end;function GetRegisteredOwner: string;
beginResult := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOwner', '');
end;//------------------------------------------------------------------------------
// 其它过程
//------------------------------------------------------------------------------// 返回控件在屏幕上的坐标区域
function GetControlScreenRect(AControl: TControl): TRect;
varAParent: TWinControl;
beginAssert(Assigned(AControl));AParent := AControl.Parent;Assert(Assigned(AParent));with AControl dobeginResult.TopLeft := AParent.ClientToScreen(Point(Left, Top));Result.BottomRight := AParent.ClientToScreen(Point(Left + Width, Top + Height));end;
end;// 设置控件在屏幕上的坐标区域
procedure SetControlScreenRect(AControl: TControl; ARect: TRect);
varAParent: TWinControl;P1, P2: TPoint;
beginAssert(Assigned(AControl));AParent := AControl.Parent;Assert(Assigned(AParent));P1 := AParent.ScreenToClient(ARect.TopLeft);P2 := AParent.ScreenToClient(ARect.BottomRight);AControl.SetBounds(P1.x, P1.y, P2.x - P1.x, P2.y - P1.y);
end;// 为 Listbox 增加水平滚动条
procedure ListboxHorizontalScrollbar(Listbox: TCustomListBox);
vari: Integer;Width, MaxWidth: Integer;
beginAssert(Assigned(Listbox));MaxWidth := 0;for i := 0 to Listbox.Items.Count - 1 dobeginWidth := Listbox.Canvas.TextWidth(Listbox.Items[i]) + 4;if Width > MaxWidth thenMaxWidth := Width;end;if ListBox is TCheckListBox thenInc(MaxWidth, GetSystemMetrics(SM_CXMENUCHECK) + 2);SendMessage(Listbox.Handle, LB_SETHORIZONTALEXTENT, MaxWidth, 0);
end;// 输出限制在Min..Max之间
function TrimInt(Value, Min, Max: Integer): Integer; overload;
beginif Value > Max thenResult := Maxelse if Value < Min thenResult := MinelseResult := Value;
end;// 比较两个整数，V1 > V2 返回 1，V1 < V2 返回 -1，V1 = V2 返回 0
// 如果 Desc 为 True，返回结果反向
function CompareInt(V1, V2: Integer; Desc: Boolean = False): Integer;
beginif V1 > V2 thenResult := 1else if V1 < V2 thenResult := -1else // V1 = V2Result := 0;if Desc thenResult := -Result;
end;// 输出限制在0..255之间
function IntToByte(Value: Integer): Byte; overload;
asmOR EAX, EAXJNS @@PositiveXOR EAX, EAXRET@@Positive:CMP EAX, 255JBE @@OKMOV EAX, 255
@@OK:
end;// 由TRect分离出坐标、宽高
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
beginx := Rect.Left;y := Rect.Top;Width := Rect.Right - Rect.Left;Height := Rect.Bottom - Rect.Top;
end;// 比较两个Rect
function RectEqu(Rect1, Rect2: TRect): Boolean;
beginResult := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;// 产生TSize类型
function EnSize(cx, cy: Integer): TSize;
beginResult.cx := cx;Result.cy := cy;
end;// 计算Rect的宽度
function RectWidth(Rect: TRect): Integer;
beginResult := Rect.Right - Rect.Left;
end;// 计算Rect的高度
function RectHeight(Rect: TRect): Integer;
beginResult := Rect.Bottom - Rect.Top;
end;// 判断范围
function InBound(Value: Integer; V1, V2: Integer): Boolean;
beginResult := (Value >= Min(V1, V2)) and (Value <= Max(V1, V2));
end;// 比较两个方法地址是否相等
function SameMethod(Method1, Method2: TMethod): Boolean;
beginResult := CompareMem(@Method1, @Method2, SizeOf(TMethod));
end;// 二分法在列表中查找
function HalfFind(List: TList; P: Pointer; SCompare: TListSortCompare): Integer;
varL, R, M: Integer;Res: Integer;
beginResult := -1;L := 0;R := List.Count - 1;if R < L then Exit;if SCompare(P, List[L]) < 0 then Exit;if SCompare(P, List[R]) > 0 then Exit;while True dobeginM := (L + R) shr 1;Res := SCompare(P, List[M]);if Res > 0 thenL := Melse if Res < 0 thenR := MelsebeginResult := M;Exit;end;if L = R thenExitelse if R - L = 1 thenbeginif SCompare(P, List[L]) = 0 thenResult := Lelse if SCompare(P, List[R]) = 0 thenResult := R;Exit;end;end;
end;// 二分法在排序列表中查找，支持重复记录，返回一个范围值
function HalfFindEx(List: TList; P: Pointer; SCompare: TListSortCompare): TFindRange;
vari, Idx: Integer;
beginIdx := HalfFind(List, P, SCompare);Result.tgFirst := Idx;for i := Idx - 1 downto 0 doif SCompare(P, List[i]) = 0 thenResult.tgFirst := ielseBreak;Result.tgLast := Idx;for i := Idx + 1 to List.Count - 1 doif SCompare(P, List[i]) = 0 thenResult.tgLast := ielseBreak;
end;// 交换两个数
procedure CnSwap(var A, B: Byte); overload;
varTmp: Byte;
beginTmp := A;A := B;B := Tmp;
end;procedure CnSwap(var A, B: Integer); overload;
varTmp: Integer;
beginTmp := A;A := B;B := Tmp;
end;procedure CnSwap(var A, B: Single); overload;
varTmp: Single;
beginTmp := A;A := B;B := Tmp;
end;procedure CnSwap(var A, B: Double); overload;
varTmp: Double;
beginTmp := A;A := B;B := Tmp;
end;// 延时
procedure Delay(const uDelay: DWORD);
varn: DWORD;
beginn := GetTickCount;while GetTickCount - n <= uDelay doApplication.ProcessMessages;
end;// 在Win9X下让喇叭发声
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
constFREQ_SCALE = $1193180;
varTemp: WORD;
beginTemp := FREQ_SCALE div Freq;asmin al,61h;or al,3;out 61h,al;mov al,$b6;out 43h,al;mov ax,temp;out 42h,al;mov al,ah;out 42h,al;end;Sleep(Delay);asmin al,$61;and al,$fc;out $61,al;end;
end;function GetLastErrorMsg(IncludeErrorCode: Boolean): string;
varErrNo: Integer;Buf: array[0..255] of Char;
beginErrNo := GetLastError;FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, $400, Buf, 255, nil);if Buf = '' then StrCopy(@Buf, PChar(SUnknowError));Result := Buf;if IncludeErrorCode thenResult := Result + #10#13 + SErrorCode + IntToStr(ErrNo);
end;// 显示Win32 Api运行结果信息
procedure ShowLastError;
beginMessageBox(Application.Handle, PChar(GetLastErrorMsg),PChar(SCnInformation), MB_OK + MB_ICONINFORMATION);
end;// 取汉字的拼音
function GetHzPy(const AHzStr: string): string;
constChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077),(2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000),(2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729),(3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000),(9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589));
vari, j, HzOrd: Integer;
beginResult := '';i := 1;while i <= Length(AHzStr) dobeginif (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) thenbeginHzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;for j := 0 to 25 dobeginif (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) thenbeginResult := Result + Char(Byte('A') + j);Break;end;end;Inc(i);end else Result := Result + AHzStr[i];Inc(i);end;
end;// 获得CustomEdit选中的字符串，可以处理XP以上的系统
function GetSelText(edt: TCustomEdit): string;
varVer: TDLLVERSIONINFO2;iSelStart, Len: Integer;i, j, itemp: Integer;stext: string;
beginAssert(Assigned(edt));Result := edt.SelText;if not DllGetVersion('comctl32.dll', Ver) thenExit;if Ver.info1.dwMajorVersion <= 5 thenExit;with edt dobeginResult := '';if SelLength <= 0 thenExit;stext := edt.Text;iSelStart := 0;i := 0;j := 1;itemp := SelStart;while i < itemp dobeginif ByteType(stext, j) <> mbLeadByte thenInc(i);Inc(iSelStart);Inc(j);end;Len := SelLength;i := 0;j := 1;while i < Len dobeginResult := Result + stext[iSelStart + j];if ByteType(stext, iSelStart + j) <> mbLeadByte thenInc(i);Inc(j);end;end;
end;// 删除空行和每一行的行首尾空格
procedure TrimStrings(AList: TStrings);
vari: Integer;
beginfor i := AList.Count - 1 downto 0 dobeginAList[i] := Trim(AList[i]);if AList[i] = '' thenAList.Delete(i);end;
end;// 声卡是否存在
function SoundCardExist: Boolean;
beginResult := WaveOutGetNumDevs > 0;
end;// 判断 ASrc 是否派生自类名为 AClass 的类
function InheritsFromClassName(ASrc: TClass; const AClass: string): Boolean;
beginResult := False;while ASrc <> nil dobeginif ASrc.ClassNameIs(AClass) thenbeginResult := True;Exit;end;ASrc := ASrc.ClassParent;end;
end;// 判断 AObject 是否派生自类名为 AClass 的类
function InheritsFromClassName(AObject: TObject; const AClass: string): Boolean;
beginResult := InheritsFromClassName(AObject.ClassType, AClass);
end; // 根据文件名结束进程，不区分路径
procedure KillProcessByFileName(const FileName: String);
varID:DWORD;S, Tmp: string;Ret: Boolean;SnapshotHandle: THandle;PE32: TProcessEntry32;hh: HWND;
beginS := LowerCase(FileName);SnapshotHandle := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0);PE32.dwSize := SizeOf(PE32);Ret := Process32First(SnapshotHandle, PE32);while Integer(Ret) <> 0 dobeginTmp := LowerCase(PE32.szExeFile);if Pos(S, Tmp) > 0 thenbeginId := PE32.th32ProcessID;hh := OpenProcess(PROCESS_ALL_ACCESS, True,Id);TerminateProcess(hh, 0);end;Ret := Process32Next(SnapshotHandle,PE32);end;
end;// 获得级联属性信息
function GetPropInfoIncludeSub(Instance: TObject; const PropName: string;AKinds: TTypeKinds): PPropInfo;
varAObject: TObject;Dot: Integer;RestProp: String;
beginDot := Pos('.', PropName);if Dot = 0 thenbeginResult := GetPropInfo(Instance, PropName, AKinds);endelsebeginif GetPropInfo(Instance, Copy(PropName, 1, Dot - 1)) <> nil thenbeginAObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1));if AObject = nil thenResult := nilelsebeginRestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot);Result := GetPropInfoIncludeSub(AObject, RestProp, AKinds);end;endelseResult := nil;end;
end;// 获得级联属性值
function GetPropValueIncludeSub(Instance: TObject; PropName: string;PreferStrings: Boolean = True): Variant;
constSCnControlFont = '!Font';
varAObject: TObject;Dot: Integer;RestProp: String;IntToId: TIntToIdent;IdValue: String;PropInfo: PPropInfo;
beginResult := Null;if Instance = nil then Exit;Dot := Pos('.', PropName);if Dot = 0 thenbeginif (Instance is TStrings) and (PropName = 'Text') thenbeginResult := (Instance as TStrings).Text;Exit;endelse if (Instance is TListItem) and (PropName = 'Caption') thenbeginResult := (Instance as TListItem).Caption;Exit;endelse if (Instance is TTreeNode) and (PropName = 'Text') thenbeginResult := (Instance as TTreeNode).Text;Exit;endelse if PropName = SCnControlFont then // 在此内部处理 !Font 的情况beginPropName := 'Font';PropInfo := GetPropInfo(Instance, PropName);if PropInfo = nil thenExit;if PropInfo^.PropType^.Kind = tkClass thenbegintryResult := FontToString(TFont(GetObjectProp(Instance, PropName)));except;end;Exit;end;end;PropInfo := GetPropInfo(Instance, PropName);if PropInfo = nil thenExit;if PropInfo^.PropType^.Kind = tkClass thenbeginResult := Integer(GetObjectProp(Instance, PropName));Exit;end;Result := GetPropValue(Instance, PropName, PreferStrings);if (Result <> Null) and IsInt(Result) then // 如果返回整数，尝试将其转换成常量。beginif PropInfo^.PropType^.Kind = tkInteger thenbeginIntToId := FindIntToIdent(PPropInfo(PropInfo)^.PropType^);if Assigned(IntToId) and IntToId(Result, IdValue) thenResult := IdValue;endendendelsebegin// 递归寻找AObject := nil;if GetPropInfo(Instance, Copy(PropName, 1, Dot - 1)) <> nil thenAObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1));if AObject = nil thenResult := NullelsebeginRestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot);Result := GetPropValueIncludeSub(AObject, RestProp);end;end;
end;// 设置级联属性值，不处理异常
procedure DoSetPropValueIncludeSub(Instance: TObject; const PropName: string;Value: Variant);
varAObject: TObject;Dot, IntValue: Integer;RestProp: String;PropInfo: PPropInfo;IdToInt: TIdentToInt;
beginDot := Pos('.', PropName);if Dot = 0 thenbeginPropInfo := GetPropInfo(Instance, PropName);if PropInfo^.PropType^.Kind = tkInteger thenbeginIdToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType^);if Assigned(IdToInt) and IdToInt(Value, IntValue) thenSetPropValue(Instance, PropName, IntValue)elseSetPropValue(Instance, PropName, Value)endelsebeginif (PropInfo^.PropType^.Kind in [tkSet, tkEnumeration]) and(VarType(Value) <> varInteger) thenValue := Trim(Value);SetPropValue(Instance, PropName, Value);end;endelsebegin// 递归设置AObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1));RestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot);DoSetPropValueIncludeSub(AObject, RestProp, Value);end;
end;// 设置级联属性值
function SetPropValueIncludeSub(Instance: TObject; const PropName: string;const Value: Variant): Boolean;
begintryDoSetPropValueIncludeSub(Instance, PropName, Value);Result := True;exceptResult := False;end;
end;// 字符串转集合值
function StrToSetValue(const Value: string; PInfo: PTypeInfo): Integer;
varEnumInfo: PTypeInfo;EnumValue: 0..SizeOf(Integer) * 8 - 1;S: string;Strings: TStrings;i: Integer;
beginResult := 0;S := Trim(Value);if S = '' then Exit;if S[1] = '[' thenDelete(S, 1, 1);if S = '' then Exit;if S[Length(S)] = ']' thenDelete(S, Length(S), 1);EnumInfo := GetTypeData(PInfo).CompType^;Strings := TStringList.Create;tryStrings.CommaText := S;for i := 0 to Strings.Count - 1 dobeginEnumValue := GetEnumValue(EnumInfo, Trim(Strings[i]));if (EnumValue < GetTypeData(EnumInfo)^.MinValue) or(EnumValue > GetTypeData(EnumInfo)^.MaxValue) thenExit; // 不是有效的枚举值Include(TIntegerSet(Result), EnumValue);end;finallyStrings.Free;end;
end;// 判断某 Control 的 ParentFont 属性是否为 True，如无 Parent 则返回 False
function IsParentFont(AControl: TControl): Boolean;
begintryResult := not (AControl.Parent = nil);if Result thenResult := TCnFontControl(AControl).ParentFont;exceptResult := False;end;
end;// 取某 Control 的 Parent 的 Font 属性，如果没有返回 nil
function GetParentFont(AControl: TComponent): TFont;
beginResult := nil;tryif AControl <> nil thenbeginif AControl is TControl thenbeginif TControl(AControl).Parent <> nil thenResult := TCnFontControl(TControl(AControl).Parent).Font;endelse if AControl is TComponent thenbeginif (AControl.Owner <> nil) and (AControl.Owner is TControl) thenResult := TCnFontControl(AControl.Owner).Font;end;end;except;end;
end;//查找字符串在动态数组中的索引，用于string类型使用Case语句
function IndexStr(AText: string; AValues: array of string; IgCase: Boolean = True): Integer;
typeTSameFunc = function(const S1, S2: string): Boolean;
varIndex: Integer;SameFunc: TSameFunc;
beginResult := -1;if IgCase thenSameFunc := AnsiSameTextelseSameFunc := AnsiSameStr;for Index := Low(AValues) to High(AValues) doif SameFunc(AValues[Index], AText) thenbeginResult := Index;Exit;end;
end;// 查找整形变量在动态数组中的索引，用于变量使用Case语句
function IndexInt(ANum: Integer; AValues: array of Integer): Integer;
varIndex: Integer;
beginResult := -1;for Index := Low(AValues) to High(AValues) doif ANum = AValues[Index] thenbeginResult := Index;Exit;end;
end;initializationWndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);end.CnPack开发包基础库相关推荐
- Java图像处理方面的工具库和开发包
Java图像处理类库Java Image Filters Java Image Filters 是由 Jhlabs 开发的一组用来处理 Java 图像的类库,提供各种常用的图像处理效果,例如反转色.扭 ...
- Android第三方开发包值高德地图SDK使用介绍，android面试基础
jcenter() // 或者 mavenCentral() } } (2)配置主工程文件的build.gradle文件 文件位置: 代码: android { defaultConfig { ndk ...
- python期货数据 库_GitHub - kozyan/tqsdk-python: 天勤量化开发包, 期货量化, 实时行情/历史数据/实盘交易...
TqSdk 天勤量化交易策略程序开发包 TqSdk 是一个由信易科技发起并贡献主要代码的开源 python 库. 依托快期多年积累成熟的交易及行情服务器体系, TqSdk 支持用户使用极少的代码量构建 ...
- php扩展库EOS,EOS区块链PHP开发包 —— EosTool
__EosTool__的目的是消除使用PHP开发EOS区块链应用的痛苦,例如: - 通过Nodeos和Keosd的RPC接口调用其功能 - 离线生成EOS格式的私钥和公钥 - 使用本地私钥生成符合EO ...
- 【C++ 语言】Visual Studio 配置 FFMPEG 开发环境 ( VS2019 CMake 环境安装 | 下载 FFMPEG 开发包 | 配置 FFMPEG )
文章目录 Visual Studio 2019 社区版 CMakeList 开发环境安装 创建 FFMPEG 配置项目 FFMPEG 开发包下载 FFMPEG 头文件 静态链接库 ( .lib ) 动 ...
- sdk开发包怎么使用_怎么使用 Buildroot 构建根文件系统？
1. Buildroot 简介 制作根文件系统有归多种方法: ① 使用Busybox手工制作 Busybox本身包含了很了Linux命令,但是要编译其他程序的话需要手工下载.编译,如果它需要某些依赖库 ...
- 视频聊天开发包的介绍
现在有商业的视频聊天开发SDK,如AnyChat等.但是这类软件是怎样开发出来的呢?本文中,让我们来共同剖析视频会议软件开发相关的主要技术,下面的说明我们主要从自己动手的角度来描述,-- 开发这一类软 ...
- SVG开发包, 20 个有用的 SVG 工具，提供更好的图像处理
20 个有用的 SVG 工具,提供更好的图像处理 SVG 现正在 Web 设计领域变得越发流行, 你可以使用 Illustrator 或者 Inkscape 来创建 SVG 图像. 但当进行 Web ...
- 微软研究院Detour开发包之API拦截技术
我们截获函数执行最直接的目的就是为函数增添功能,修改返回值,或者为调试以及性能测试加入附加的代码,或者截获函数的输入输出作研究,破解使用.通过访 问源代码,我们可以轻而易举的使用重建(Rebuildi ...
- EOS Chain/Wallet RPC API的PHP开发包
2019独角兽企业重金招聘Python工程师标准>>> 介绍一个EOS Chain/Wallet RPC API的PHP开发包. 开始 你可以查看EOS的RPC API参考,但要注意 ...
最新文章
- 如何成为一个合格的项目经理?
- Hinton：胶囊网络的专利是我的了！
- 那个当上非洲酋长的交大才子，如今怎么样了？
- mysql makefile_编译安装mysql，找不到makefile
- pandas dataframe column_Python数据分析——Pandas 教程（下）
- 良心之作----centos6.5下安装svn客户端报错
- metronic-Website Template
- antd vue中，如何给表单动态添加input，解决遇到一些坑
- 在HTML中如何把块的边框做成圆角
- java cookbook中文版_Java Client快速入门指南
- Ubuntu 20.04 安装 ModSecurity3.0+Nginx
- MySQL 数据恢复 —— 使用 data 目录
- 51单片机用PID算法温度控制器毕业设计 完整资料,Matlab作图仿真源码
- WordPress社交问答社区主题模板
- BATJ大数据架构师带你领略实时计算框架Flink的魅力！
- AndroidO Treble架构下Hal进程启动及HIDL服务注册过程
- python php java地铁站自动售票系统nodejs+vue+elementui
- 【Python】Decision on buying cars COROLLA or LEVIN（数据分析技术实现过程之·1数据清洗）
- 全球卫星导航 看中国“北斗”
- 论AI小游戏是怎么练成的——『寻物大作战』原理揭秘