CnPack开发包基础库
来源：互联网 发布：遥感图像拼接软件 编辑：程序博客网 时间：2024/06/05 21:12
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}uses Windows, 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;//------------------------------------------------------------------------------// 公共类型定义//------------------------------------------------------------------------------type PRGBColor = ^TRGBColor; TRGBColor = packed record b, 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}type TValueRelationship = -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;{* 取文件夹文件数}type TFindCallBack = 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.EXE var Running: Boolean - 返回该应用程序是否运行，运行为 True Result: Boolean - 如果查找成功返回为 True，否则为 False |</PRE>}type TVersionNumber = 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;{* 显示查询是否窗口}const csDefComboBoxSection = '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;{* 取时间毫秒分量}//------------------------------------------------------------------------------// 位操作函数//------------------------------------------------------------------------------type TByteBit = 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;{* 取二进制位}//------------------------------------------------------------------------------// 系统功能函数//------------------------------------------------------------------------------type PDLLVERSIONINFO = ^TDLLVERSIONINFO; TDLLVERSIONINFO = packed record cbSize: DWORD; dwMajorVersion: DWORD; dwMinorVersion: DWORD; dwBuildNumber: DWORD; dwPlatformId: DWORD; end; PDLLVERSIONINFO2 = ^TDLLVERSIONINFO2; TDLLVERSIONINFO2 = packed record info1: 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;{* 二分法在排序列表中查找}type TFindRange = record tgFirst: 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//==============================================================================type TCnFontControl = class(TControl) public property ParentFont; property Font; end;function IsParentFont(AControl: TControl): Boolean;{* 判断某 Control 的 ParentFont 属性是否为 True，如无 Parent 则返回 False }function GetParentFont(AControl: TComponent): TFont;{* 取某 Control 的 Parent 的 Font 属性，如果没有返回 nil }const InvalidFileNameChar: set of Char = ['\', '/', ':', '*', '?', '"', '<', '>', '|'];implementation//------------------------------------------------------------------------------// 扩展的文件目录操作函数//------------------------------------------------------------------------------// 在资源管理器中打开指定目录procedure ExploreDir(APath: string);var strExecute: string;begin strExecute := Format('EXPLORER.EXE /e,%s', [APath]); WinExec(PChar(strExecute), SW_SHOWNORMAL);end;// 在资源管理器中打开指定文件procedure ExploreFile(AFile: string);var strExecute: string;begin strExecute := Format('EXPLORER.EXE /e,/select,%s', [AFile]); WinExec(PChar(strExecute), SW_SHOWNORMAL);end;// 递归创建多级子目录function ForceDirectories(Dir: string): Boolean;begin Result := True; if Length(Dir) = 0 then begin Result := False; Exit; end; Dir := ExcludeTrailingBackslash(Dir); if (Length(Dir) < 3) or DirectoryExists(Dir) or (ExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. Result := ForceDirectories(ExtractFilePath(Dir)) and CreateDir(Dir);end;// 移动文件、目录function MoveFile(const sName, dName: string): Boolean;var s1, s2: AnsiString; lpFileOp: TSHFileOpStruct;begin s1 := PChar(sName) + #0#0; s2 := PChar(dName) + #0#0; with lpFileOp do begin Wnd := Application.Handle; wFunc := FO_MOVE; pFrom := PChar(s1); pTo := PChar(s2); fFlags := FOF_ALLOWUNDO; hNameMappings := nil; lpszProgressTitle := nil; fAnyOperationsAborted := True; end; try Result := SHFileOperation(lpFileOp) = 0; except Result := False; end;end;// 删除文件到回收站function DeleteToRecycleBin(const FileName: string): Boolean;var s: AnsiString; lpFileOp: TSHFileOpStruct;begin s := PChar(FileName) + #0#0; with lpFileOp do begin Wnd := 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; try Result := SHFileOperation(lpFileOp) = 0; except Result := False; end;end;// 打开文件属性窗口procedure FileProperties(const FName: string);var SEI: SHELLEXECUTEINFO;begin with SEI do begin cbSize := SizeOf(SEI); fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or SEE_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;var SLen: Integer; i, j: Integer; TString: string;begin SLen := Length(APath); if (SLen <= Width) or (Width <= 6) then begin Result := APath; Exit end else begin i := SLen; TString := APath; for j := 1 to 2 do begin while (TString[i] <> '\') and (SLen - i < Width - 8) do i := i - 1; i := i - 1; end; for j := SLen - i - 1 downto 0 do TString[Width - j] := TString[SLen - j]; for j := SLen - i to SLen - i + 2 do TString[Width - j] := '.'; Delete(TString, Width + 1, 255); Result := TString; end;end;// 通过 DrawText 来画缩略路径procedure DrawCompactPath(Hdc: HDC; Rect: TRect; Str: string);begin DrawText(Hdc, PChar(Str), Length(Str), Rect, DT_PATH_ELLIPSIS);end;// 打开文件框function OpenDialog(var FileName: string; Title: string; Filter: string; Ext: string): Boolean;var OpenName: TOPENFILENAME; TempFilename, ReturnFile: string;begin with OpenName do begin lStructSize := 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 then FileName := ReturnFile else FileName := '';end;function SelectDirCB(Wnd: HWND; uMsg: UINT; lParam, lpData: LPARAM): Integer stdcall;begin if (uMsg = BFFM_INITIALIZED) and (lpData <> 0) then SendMessage(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;var BrowseInfo: TBrowseInfo; Buffer: PChar; RootItemIDList, ItemIDList: PItemIDList; ShellMalloc: IMalloc; IDesktopFolder: IShellFolder; Eaten, Flags: LongWord;begin Result := False; FillChar(BrowseInfo, SizeOf(BrowseInfo), 0); if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then begin Buffer := ShellMalloc.Alloc(MAX_PATH); try SHGetDesktopFolder(IDesktopFolder); if Root = '' then RootItemIDList := nil else IDesktopFolder.ParseDisplayName(Application.Handle, nil, POleStr(Root), Eaten, RootItemIDList, Flags); with BrowseInfo do begin hwndOwner := Owner; pidlRoot := RootItemIDList; pszDisplayName := Buffer; lpszTitle := PChar(Caption); ulFlags := BIF_RETURNONLYFSDIRS; if ShowNewButton then ulFlags := ulFlags or $0040; lpfn := SelectDirCB; lparam := Integer(PChar(Directory)); end; ItemIDList := SHBrowseForFolder(BrowseInfo); Result := ItemIDList <> nil; if Result then begin ShGetPathFromIDList(ItemIDList, Buffer); ShellMalloc.Free(ItemIDList); Directory := Buffer; end; finally ShellMalloc.Free(Buffer); end; end;end;function GetDirectory(const Caption: string; var Dir: string; ShowNewButton: Boolean): Boolean;var OldErrorMode: UINT; BrowseRoot: WideString; OwnerHandle: HWND;begin OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS); try BrowseRoot := ''; if Screen.ActiveCustomForm <> nil then OwnerHandle := Screen.ActiveCustomForm.Handle else OwnerHandle := Application.Handle; Result := CnSelectDirectory(Caption, BrowseRoot, Dir, OwnerHandle, ShowNewButton); finally SetErrorMode(OldErrorMode); end;end;// 两个字符串的前面的相同字符数function SameCharCounts(s1, s2: string): Integer;var Str1, Str2: PChar;begin Result := 1; s1 := s1 + #0; s2 := s2 + #0; Str1 := PChar(s1); Str2 := PChar(s2); while (s1[Result] = s2[Result]) and (s1[Result] <> #0) do begin Inc(Result); end; Dec(Result);{$IFDEF MSWINDOWS} if (StrByteType(Str1, Result - 1) = mbLeadByte) or (StrByteType(Str2, Result - 1) = mbLeadByte) then Dec(Result);{$ENDIF}{$IFDEF LINUX} if (StrByteType(Str1, Result - 1) <> mbSingleByte) or (StrByteType(Str2, Result - 1) <> mbSingleByte) then Dec(Result);{$ENDIF}end;// 在字符串中某字符出现的次数function CharCounts(Str: PChar; Chr: Char): Integer;var p: PChar;begin Result := 0; p := StrScan(Str, Chr); while p <> nil do begin{$IFDEF MSWINDOWS} case StrByteType(Str, Integer(p - Str)) of mbSingleByte: begin Inc(Result); Inc(p); end; mbLeadByte: Inc(p); end;{$ENDIF}{$IFDEF LINUX} if StrByteType(Str, Integer(p - Str)) = mbSingleByte then begin Inc(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;var i, HeadNum: Integer;begin ATo := StringReplace(ATo, '/', '\', [rfReplaceAll]); AFrom := StringReplace(AFrom, '/', '\', [rfReplaceAll]); while AnsiPos('\\', ATo) > 0 do ATo := StringReplace(ATo, '\\', '\', [rfReplaceAll]); while AnsiPos('\\', AFrom) > 0 do AFrom := StringReplace(AFrom, '\\', '\', [rfReplaceAll]); if StrRight(ATo, 1) = ':' then ATo := ATo + '\'; if StrRight(AFrom, 1) = ':' then AFrom := AFrom + '\'; HeadNum := SameCharCounts(AnsiUpperCase(ExtractFilePath(ATo)), AnsiUpperCase(ExtractFilePath(AFrom))); if HeadNum > 0 then begin ATo := StringReplace(Copy(ATo, HeadNum + 1, MaxInt), '\', PathStr, [rfReplaceAll]); AFrom := Copy(AFrom, HeadNum + 1, MaxInt); Result := ''; HeadNum := CharCounts(PChar(AFrom), '\'); for i := 1 to HeadNum do Result := Result + ParentStr + PathStr; if (Result = '') and UseCurrentDir then Result := CurrentStr + PathStr; Result := Result + ATo; end else Result := ATo;end;{$IFNDEF BCB}const shlwapi32 = '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; begin if IsDir then Result := FILE_ATTRIBUTE_DIRECTORY else Result := FILE_ATTRIBUTE_NORMAL; end;var p: array[0..MAX_PATH] of Char;begin PathRelativePathTo(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;var HeadIsUrl: Boolean; TailHasRoot: Boolean; TailIsRel: Boolean; AHead, ATail, S: string; UrlPos, i: Integer;begin if Head = '' then begin Result := Tail; Exit; end; if Tail = '' then begin Result := Head; Exit; end; TailHasRoot := (AnsiPos(':\', Tail) = 2) or // C:\Test (AnsiPos('\\', Tail) = 1) or // \\Name\C\Test (AnsiPos('://', Tail) > 0); // ftp://ftp.abc.com if TailHasRoot then begin Result := Tail; Exit; end; UrlPos := AnsiPos('://', Head); HeadIsUrl := UrlPos > 0; AHead := StringReplace(Head, '/', '\', [rfReplaceAll]); ATail := StringReplace(Tail, '/', '\', [rfReplaceAll]); TailIsRel := ATail[1] = '\'; // 尾路径是相对路径 if TailIsRel then begin if AnsiPos(':\', AHead) = 2 then Result := AHead[1] + ':' + ATail else if AnsiPos('\\', AHead) = 1 then begin S := Copy(AHead, 3, MaxInt); i := AnsiPos('\', S); if i > 0 then Result := Copy(AHead, 1, i + 1) + ATail else Result := AHead + ATail; end else if HeadIsUrl then begin S := Copy(AHead, UrlPos + 3, MaxInt); i := AnsiPos('\', S); if i > 0 then Result := Copy(AHead, 1, i + UrlPos + 1) + ATail else Result := AHead + ATail; end else begin Result := Tail; Exit; end; end else begin if Copy(ATail, 1, 2) = '.\' then Delete(ATail, 1, 2); AHead := MakeDir(AHead); i := Pos('..\', ATail); while i > 0 do begin AHead := ExtractFileDir(AHead); Delete(ATail, 1, 3); i := Pos('..\', ATail); end; Result := MakePath(AHead) + ATail; end; if HeadIsUrl then Result := StringReplace(Result, '\', '/', [rfReplaceAll]);end;// 运行一个文件procedure RunFile(const FName: string; Handle: THandle; const Param: string);begin ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);end;// 打开一个链接procedure OpenUrl(const Url: string);const csPrefix = 'http://';var AUrl: string;begin if Pos(csPrefix, Url) < 1 then AUrl := csPrefix + Url else AUrl := Url; RunFile(AUrl);end;// 发送邮件procedure MailTo(const Addr: string; const Subject: string = '');const csPrefix = 'mailto:'; csSubject = '?Subject=';var Url: string;begin if Pos(csPrefix, Addr) < 1 then Url := csPrefix + Addr else Url := Addr; if Subject <> '' then Url := Url + csSubject + Subject; RunFile(Url);end;// 运行一个文件并立即返回function WinExecute(FileName: string; Visibility: Integer = SW_NORMAL): Boolean;var StartupInfo: TStartupInfo; ProcessInfo: TProcessInformation;begin FillChar(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;var zAppName: array[0..512] of Char; zCurDir: array[0..255] of Char; WorkDir: string; StartupInfo: TStartupInfo; ProcessInfo: TProcessInformation;begin StrPCopy(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) then Result := -1 { pointer to PROCESS_INF } else begin if ProcessMsg then begin repeat Application.ProcessMessages; GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result)); until (Result <> STILL_ACTIVE) or Application.Terminated; end else begin WaitforSingleObject(ProcessInfo.hProcess, INFINITE); GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result)); end; end;end;// 用管道方式在 Dir 目录执行 CmdLine，Output 返回输出信息，// dwExitCode 返回退出码。如果成功返回 Truefunction WinExecWithPipe(const CmdLine, Dir: string; slOutput: TStrings; var dwExitCode: Cardinal): Boolean;var HOutRead, HOutWrite: THandle; StartInfo: TStartupInfo; ProceInfo: TProcessInformation; sa: TSecurityAttributes; InStream: THandleStream; strTemp: string; PDir: PChar; procedure ReadLinesFromPipe(IsEnd: Boolean); var s: string; ls: TStringList; i: Integer; begin if InStream.Position < InStream.Size then begin SetLength(s, InStream.Size - InStream.Position); InStream.Read(PChar(s)^, InStream.Size - InStream.Position); strTemp := strTemp + s; ls := TStringList.Create; try ls.Text := strTemp; for i := 0 to ls.Count - 2 do slOutput.Add(ls[i]); strTemp := ls[ls.Count - 1]; finally ls.Free; end; end; if IsEnd and (strTemp <> '') then begin slOutput.Add(strTemp); strTemp := ''; end; end;begin dwExitCode := 0; Result := False; try FillChar(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; try Win32Check(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 <> '' then PDir := PChar(Dir) else PDir := nil; Win32Check(CreateProcess(nil, //lpApplicationName: PChar PChar(CmdLine), //lpCommandLine: PChar nil, //lpProcessAttributes: PSecurityAttributes nil, //lpThreadAttributes: PSecurityAttributes True, //bInheritHandles: BOOL NORMAL_PRIORITY_CLASS, //CREATE_NEW_CONSOLE, nil, PDir, StartInfo, ProceInfo)); while WaitForSingleObject(ProceInfo.hProcess, 100) = WAIT_TIMEOUT do begin ReadLinesFromPipe(False); Application.ProcessMessages; //if Application.Terminated then break; end; ReadLinesFromPipe(True); GetExitCodeProcess(ProceInfo.hProcess, dwExitCode); CloseHandle(ProceInfo.hProcess); CloseHandle(ProceInfo.hThread); Result := True; finally if 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;var slOutput: TStringList;begin slOutput := TStringList.Create; try Result := WinExecWithPipe(CmdLine, Dir, slOutput, dwExitCode); Output := slOutput.Text; finally slOutput.Free; end;end;// 应用程序路径function AppPath: string;begin Result := ExtractFilePath(Application.ExeName);end;// 当前执行模块所在的路径function ModulePath: string;var ModName: array[0..MAX_PATH] of Char;begin SetString(Result, ModName, GetModuleFileName(HInstance, ModName, SizeOf(ModName))); Result := ExtractFilePath(Result);end;const HKLM_CURRENT_VERSION_WINDOWS = 'Software\Microsoft\Windows\CurrentVersion'; HKLM_CURRENT_VERSION_NT = 'Software\Microsoft\Windows NT\CurrentVersion';function RelativeKey(const Key: string): PChar;begin Result := PChar(Key); if (Key <> '') and (Key[1] = '\') then Inc(Result);end;function RegReadStringDef(const RootKey: HKEY; const Key, Name, Def: string): string;var RegKey: HKEY; Size: DWORD; StrVal: string; RegKind: DWORD;begin Result := Def; if RegOpenKeyEx(RootKey, RelativeKey(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then begin RegKind := 0; Size := 0; if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, nil, @Size) = ERROR_SUCCESS then if RegKind in [REG_SZ, REG_EXPAND_SZ] then begin SetLength(StrVal, Size); if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, PByte(StrVal), @Size) = ERROR_SUCCESS then begin SetLength(StrVal, StrLen(PChar(StrVal))); Result := StrVal; end; end; RegCloseKey(RegKey); end;end;procedure StrResetLength(var S: AnsiString);begin SetLength(S, StrLen(PChar(S)));end;// 取Program Files目录function GetProgramFilesDir: string;begin Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');end;// 取Windows目录function GetWindowsDir: string;var Required: Cardinal;begin Result := ''; Required := GetWindowsDirectory(nil, 0); if Required <> 0 then begin SetLength(Result, Required); GetWindowsDirectory(PChar(Result), Required); StrResetLength(Result); end;end;// 取临时文件路径function GetWindowsTempPath: string;var Required: Cardinal;begin Result := ''; Required := GetTempPath(0, nil); if Required <> 0 then begin SetLength(Result, Required); GetTempPath(Required, PChar(Result)); StrResetLength(Result); end;end;// 返回一个临时文件名function CnGetTempFileName(const Ext: string): string;var Path: string;begin Path := MakePath(GetWindowsTempPath); repeat Result := Path + IntToStr(Random(MaxInt)) + Ext; until not FileExists(Result);end;// 取系统目录function GetSystemDir: string;var Required: Cardinal;begin Result := ''; Required := GetSystemDirectory(nil, 0); if Required <> 0 then begin SetLength(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;var Buf: array[0..MAX_PATH] of Char;begin if GetLongPathNameA(PChar(FileName), @Buf, MAX_PATH) > 0 then Result := Buf else Result := FileName;end;// 长文件名转短文件名function LongNameToShortName(const FileName: string): string;var Buf: PChar; BufSize: Integer;begin BufSize := GetShortPathName(PChar(FileName), nil, 0) + 1; GetMem(Buf, BufSize); try GetShortPathName(PChar(FileName), Buf, BufSize); Result := Buf; finally FreeMem(Buf); end;end;// 取得真实长文件名，包含大小写function GetTrueFileName(const FileName: string): string;var AName: string; FindName: string; function DoFindFile(const FName: string): string; var F: TSearchRec; begin if SysUtils.FindFirst(FName, faAnyFile, F) = 0 then Result := F.Name else Result := ExtractFileName(FName); SysUtils.FindClose(F); end;begin AName := MakeDir(FileName); if (Length(AName) > 3) and (AName[2] = ':') then begin Result := ''; while Length(AName) > 3 do begin FindName := DoFindFile(AName); if FindName = '' then begin Result := AName; Exit; end; if Result = '' then Result := FindName else Result := FindName + '\' + Result; AName := ExtractFileDir(AName); end; Result := UpperCase(AName) + Result; end else Result := AName;end;// 查找可执行文件的完整路径function FindExecFile(const AName: string; var AFullName: string): Boolean;var fn: array[0..MAX_PATH] of Char; pc: PChar;begin if (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)) then begin Result := False; end else begin Result := True; AFullName := fn; end;end;function PidlFree(var IdList: PItemIdList): Boolean;var Malloc: IMalloc;begin Result := False; if IdList = nil then Result := True else begin if Succeeded(SHGetMalloc(Malloc)) and (Malloc.DidAlloc(IdList) > 0) then begin Malloc.Free(IdList); IdList := nil; Result := True; end; end;end;function PidlToPath(IdList: PItemIdList): string;begin SetLength(Result, MAX_PATH); if SHGetPathFromIdList(IdList, PChar(Result)) then StrResetLength(Result) else Result := '';end;// 取得系统特殊文件夹位置，Folder 使用在 ShlObj 中定义的标识，如 CSIDL_DESKTOPfunction GetSpecialFolderLocation(const Folder: Integer): string;var FolderPidl: PItemIdList;begin if Succeeded(SHGetSpecialFolderLocation(0, Folder, FolderPidl)) then begin Result := PidlToPath(FolderPidl); PidlFree(FolderPidl); end else Result := '';end;// 目录尾加'\'修正function AddDirSuffix(const Dir: string): string;begin Result := Trim(Dir); if Result = '' then Exit; if not IsPathDelimiter(Result, Length(Result)) then Result := Result + {$IFDEF MSWINDOWS} '\'; {$ELSE} '/'; {$ENDIF};end;// 目录尾加'\'修正function MakePath(const Dir: string): string;begin Result := AddDirSuffix(Dir);end;// 路径尾去掉 '\'function MakeDir(const Path: string): string;begin Result := Trim(Path); if Result = '' then Exit; if Result[Length(Result)] in ['/', '\'] then Delete(Result, Length(Result), 1);end;// 路径中的 '\' 转成 '/'function GetUnixPath(const Path: string): string;begin Result := StringReplace(Path, '\', '/', [rfReplaceAll]);end;// 路径中的 '/' 转成 '\'function GetWinPath(const Path: string): string;begin Result := StringReplace(Path, '/', '\', [rfReplaceAll]);end;function PointerXX(var X: PChar): PChar;{$IFDEF PUREPASCAL}begin Result := X; Inc(X);end;{$ELSE}asm { EAX = X } MOV EDX, [EAX] INC dword ptr [EAX] MOV EAX, EDXend;{$ENDIF}function Evaluate(var X: Char; const Value: Char): Char;{$IFDEF PUREPASCAL}begin X := Value; Result := X;end;{$ELSE}asm { EAX = X EDX = Value (DL) } MOV [EAX], DL MOV AL, [EAX]end;{$ENDIF}// 文件名是否与通配符匹配，返回值为0表示匹配function FileNameMatch(Pattern, FileName: PChar): Integer;var p, n: PChar; c: Char;begin p := Pattern; n := FileName; while Evaluate(c, PointerXX(p)^) <> #0 do begin case c of '?': begin if n^ = '.' then begin while (p^ <> '.') and (p^ <> #0) do begin if (p^ <> '?') and (p^ <> '*') then begin Result := -1; Exit; end; Inc(p); end; end else begin if n^ <> #0 then Inc(n); end; end; '>': begin if n^ = '.' then begin if ((n + 1)^ = #0) and (FileNameMatch(p, n+1) = 0) then begin Result := 0; Exit; end; if FileNameMatch(p, n) = 0 then begin Result := 0; Exit; end; Result := -1; Exit; end; if n^ = #0 then begin Result := FileNameMatch(p, n); Exit; end; Inc(n); end; '*': begin while n^ <> #0 do begin if FileNameMatch(p, n) = 0 then begin Result := 0; Exit; end; Inc(n); end; end; '<': begin while n^ <> #0 do begin if FileNameMatch(p, n) = 0 then begin Result := 0; Exit; end; if (n^ = '.') and (StrScan(n + 1, '.') = nil) then begin Inc(n); Break; end; Inc(n); end; end; '"': begin if (n^ = #0) and (FileNameMatch(p, n) = 0) then begin Result := 0; Exit; end; if n^ <> '.' then begin Result := -1; Exit; end; Inc(n); end; else if (c = '.') and (n^ = #0) then begin while p^ <> #0 do begin if (p^ = '*') and ((p + 1)^ = #0) then begin Result := 0; Exit; end; if p^ <> '?' then begin Result := -1; Exit; end; Inc(p); end; Result := 0; Exit;end; if c <> n^ then begin Result := -1; Exit; end; Inc(n); end; end; if n^ = #0 then begin Result := 0; Exit; end; Result := -1;end;// 文件名是否与扩展名通配符匹配function MatchExt(const S, Ext: string): Boolean;begin if S = '.*' then begin Result := True; Exit; end; Result := FileNameMatch(PChar(S), PChar(Ext)) = 0;end;// 文件名是否与通配符匹配function MatchFileName(const S, FN: string): Boolean;begin if S = '*.*' then begin Result := True; Exit; end; Result := FileNameMatch(PChar(S), PChar(FN)) = 0;end;// 得到大小写是否敏感的字符串function _CaseSensitive(const CaseSensitive: Boolean; const S: string): string;begin if CaseSensitive then Result := S else Result := AnsiUpperCase(S);end;// 转换扩展名通配符字符串为通配符列表procedure FileExtsToStrings(const FileExts: string; ExtList: TStrings; CaseSensitive: Boolean);var Exts: string; i: Integer;begin Exts := StringReplace(FileExts, ';', ',', [rfReplaceAll]); ExtList.CommaText := Exts; for i := 0 to ExtList.Count - 1 do begin if StrScan(PChar(ExtList[i]), '.') <> nil then begin ExtList[i] := _CaseSensitive(CaseSensitive, ExtractFileExt(ExtList[i])); end else begin ExtList[i] := '.' + _CaseSensitive(CaseSensitive, ExtList[i]); end; if ExtList[i] = '.*' then begin if i > 0 then ExtList.Exchange(0, i); Exit; end; end;end;// 文件名是否匹配扩展名通配符function FileMatchesExts(const FileName, FileExts: string; CaseSensitive: Boolean): Boolean;var ExtList: TStrings; FExt: string; i: Integer;begin ExtList := TStringList.Create; try FileExtsToStrings(FileExts, ExtList, CaseSensitive); FExt := _CaseSensitive(CaseSensitive, ExtractFileExt(FileName)); Result := False; for i := 0 to ExtList.Count - 1 do begin if MatchExt(ExtList[i], FExt) then begin Result := True; Exit; end; end; finally ExtList.Free; end;end;// 文件名是否匹配扩展名通配符function FileMatchesExts(const FileName: string; ExtList: TStrings): Boolean;var FExt: string; i: Integer;begin FExt := _CaseSensitive(False, ExtractFileExt(FileName)); Result := False; for i := 0 to ExtList.Count - 1 do begin if MatchExt(ExtList[i], FExt) then begin Result := True; Exit; end; end;end;// 转换文件通配符字符串为通配符列表procedure FileMasksToStrings(const FileMasks: string; MaskList: TStrings; CaseSensitive: Boolean);var Exts: string; i: Integer;begin Exts := StringReplace(FileMasks, ';', ',', [rfReplaceAll]); MaskList.CommaText := Exts; for i := 0 to MaskList.Count - 1 do begin if StrScan(PChar(MaskList[i]), '.') <> nil then begin if MaskList[i][1] = '.' then MaskList[i] := '*' + _CaseSensitive(CaseSensitive, MaskList[i]) else MaskList[i] := _CaseSensitive(CaseSensitive, MaskList[i]); end else begin MaskList[i] := '*.' + _CaseSensitive(CaseSensitive, MaskList[i]); end; if MaskList[i] = '*.*' then begin if i > 0 then MaskList.Exchange(0, i); Exit; end; end;end;// 文件名是否匹配通配符function FileMatchesMasks(const FileName, FileMasks: string; CaseSensitive: Boolean): Boolean;var MaskList: TStrings; FFileName: string; i: Integer;begin MaskList := TStringList.Create; try FileMasksToStrings(FileMasks, MaskList, CaseSensitive); FFileName := _CaseSensitive(CaseSensitive, ExtractFileName(FileName)); Result := False; for i := 0 to MaskList.Count - 1 do begin if MatchFileName(MaskList[i], FFileName) then begin Result := True; Exit; end; end; finally MaskList.Free; end;end;// 文件名是否匹配通配符function FileMatchesMasks(const FileName: string; MaskList: TStrings): Boolean;var FFileName: string; i: Integer;begin FFileName := _CaseSensitive(False, ExtractFileName(FileName)); Result := False; for i := 0 to MaskList.Count - 1 do begin if MatchFileName(MaskList[i], FFileName) then begin Result := True; Exit; end; end;end;// 文件名与扩展名列表比较function FileMatchesExts(const FileName, FileExts: string): Boolean;begin Result := FileMatchesMasks(FileName, FileExts, False);end;// 判断文件是否正在使用function IsFileInUse(const FName: string): Boolean;var HFileRes: HFILE;begin Result := False; if not FileExists(FName) then Exit; 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 then CloseHandle(HFileRes);end;// 判断文件是否为 Ascii 文件function IsAscii(FileName: string): Boolean;const Sett=2048;var I: Integer; AFile: File; Bool: Boolean; TotSize, IncSize, ReadSize: Integer; C: array[0..Sett] of Byte;begin Result := False; if FileExists(FileName) then begin {$I-} AssignFile(AFile, FileName); Reset(AFile, 1); TotSize := FileSize(AFile); IncSize := 0; Bool := True; while (IncSize < TotSize) and (Bool = True) do begin ReadSize := Sett; if IncSize + ReadSize > TotSize then ReadSize := TotSize - IncSize; IncSize := IncSize + ReadSize; BlockRead(AFile, C, ReadSize); for I := 0 to ReadSize-1 do // Iterate if (C[I] < 32) and (not(C[I] in [9, 10, 13, 26])) then Bool := False; end; // while CloseFile(AFile); {$I+} if IOResult <> 0 then Result := False else Result := Bool; end;end;// 判断文件是否是有效的文件名function IsValidFileName(const Name: string): Boolean;var i: Integer;begin Result := False; if (Name = '') or (Length(Name) > MAX_PATH) then Exit; for i := 1 to Length(Name) do begin if Name[i] in InvalidFileNameChar then Exit; end; Result := True;end;// 返回有效的文件名function GetValidFileName(const Name: string): string;var i: Integer;begin Result := Name; for i := Length(Result) downto 1 do begin if Result[i] in InvalidFileNameChar then Delete(Result, i, 1); end; if Length(Result) > MAX_PATH - 1 then Result := Copy(Result, 1, MAX_PATH - 1);end;// 设置文件时间function SetFileDate(const FileName: string; CreationTime, LastWriteTime, LastAccessTime: TFileTime): Boolean;var FileHandle: Integer;begin FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone); if FileHandle > 0 then begin SetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime); FileClose(FileHandle); Result := True; end else Result := False;end;// 取文件时间function GetFileDate(const FileName: string; var CreationTime, LastWriteTime, LastAccessTime: TFileTime): Boolean;var FileHandle: Integer;begin FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone); if FileHandle > 0 then begin GetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime); FileClose(FileHandle); Result := True; end else Result := False;end;// 取得与文件相关的图标// FileName: e.g. "e:\hao\a.txt"// 成功则返回Truefunction GetFileIcon(const FileName: string; var Icon: TIcon): Boolean;var SHFileInfo: TSHFileInfo; h: HWND;begin if not Assigned(Icon) then Icon := 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;var SystemTime: TSystemTime;begin SystemTime := FileTimeToLocalSystemTime(FileTime); with SystemTime do Result := EncodeDate(wYear, wMonth, wDay) + EncodeTime(wHour, wMinute, wSecond, wMilliseconds);end;// 本地日期时间转文件时间function DateTimeToFileTime(const DateTime: TDateTime): TFileTime;var SystemTime: TSystemTime;begin with SystemTime do begin DecodeDate(DateTime, wYear, wMonth, wDay); DecodeTime(DateTime, wHour, wMinute, wSecond, wMilliseconds); end; Result := LocalSystemTimeToFileTime(SystemTime);end;// 文件时间转本地时间function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;var STime: TSystemTime;begin FileTimeToLocalFileTime(FTime, FTime); FileTimeToSystemTime(FTime, STime); Result := STime;end;// 本地时间转文件时间function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;var FTime: TFileTime;begin SystemTimeToFileTime(STime, FTime); LocalFileTimeToFileTime(FTime, FTime); Result := FTime;end;const MinutesPerDay = 60 * 24; SecondsPerDay = MinutesPerDay * 60;// UTC 时间转本地时间function DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;var TimeZoneInfo: TTimeZoneInformation;begin FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0); if GetTimeZoneInformation(TimeZoneInfo) = TIME_ZONE_ID_DAYLIGHT then Result := DateTime - ((TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / MinutesPerDay) else Result := DateTime - (TimeZoneInfo.Bias / MinutesPerDay);end;// 本地时间转 UTC 时间function LocalDateTimeToDateTime(DateTime: TDateTime): TDateTime;var TimeZoneInfo: TTimeZoneInformation;begin FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #0); if GetTimeZoneInformation(TimeZoneInfo) = TIME_ZONE_ID_DAYLIGHT then Result := DateTime + ((TimeZoneInfo.Bias + TimeZoneInfo.DaylightBias) / MinutesPerDay) else Result := DateTime + (TimeZoneInfo.Bias / MinutesPerDay);end;{$IFDEF COMPILER5}const LessThanValue = Low(TValueRelationship); EqualsValue = 0; GreaterThanValue = High(TValueRelationship);function CompareValue(const A, B: Int64): TValueRelationship;begin if A = B then Result := EqualsValue else if A < B then Result := LessThanValue else Result := GreaterThanValue;end;// AText 是否以 ASubText 开头function AnsiStartsText(const ASubText, AText: string): Boolean;begin Result := AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText)) = 1;end;function AnsiReplaceText(const AText, AFromText, AToText: string): string;begin Result := StringReplace(AText, AFromText, AToText, [rfReplaceAll, rfIgnoreCase]);end;{$ENDIF}{$IFNDEF COMPILER7_UP}// AText 是否包含 ASubTextfunction AnsiContainsText(const AText, ASubText: string): Boolean;begin Result := AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText)) > 0;end;{$ENDIF}// 比较 SubText 在两个字符串中出现的位置的大小，如果相等则比较字符串本身，忽略大小写function CompareTextPos(const ASubText, AText1, AText2: string): TValueRelationship;begin Result := 0; if ASubText <> '' then Result := CompareValue(AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText1)), AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText2))); if Result = 0 then Result := CompareText(AText1, AText2);end;// 创建备份文件function CreateBakFile(const FileName, Ext: string): Boolean;var BakFileName: string; AExt: string;begin if (Ext <> '') and (Ext[1] = '.') then AExt := Ext else AExt := '.' + Ext; BakFileName := FileName + AExt; Result := CopyFile(PChar(FileName), PChar(BakFileName), False);end;// 删除整个目录function Deltree(Dir: string; DelRoot: Boolean; DelEmptyDirOnly: Boolean): Boolean;var sr: TSearchRec; fr: Integer;begin Result := True; if not DirectoryExists(Dir) then Exit; fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr); try while fr = 0 do begin if (sr.Name <> '.') and (sr.Name <> '..') then begin SetFileAttributes(PChar(AddDirSuffix(Dir) + sr.Name), FILE_ATTRIBUTE_NORMAL); if sr.Attr and faDirectory = faDirectory then Result := Deltree(AddDirSuffix(Dir) + sr.Name, True, DelEmptyDirOnly) else if not DelEmptyDirOnly then Result := DeleteFile(AddDirSuffix(Dir) + sr.Name); end; fr := FindNext(sr); end; finally FindClose(sr); end; if DelRoot then Result := RemoveDir(Dir);end;// 删除整个目录中的空目录, DelRoot 表示是否删除目录本身procedure DelEmptyTree(Dir: string; DelRoot: Boolean = True);var sr: TSearchRec; fr: Integer;begin fr := FindFirst(AddDirSuffix(Dir) + '*.*', faDirectory, sr); try while fr = 0 do begin if (sr.Name <> '.') and (sr.Name <> '..') and (sr.Attr and faDirectory = faDirectory) then begin SetFileAttributes(PChar(AddDirSuffix(Dir) + sr.Name), FILE_ATTRIBUTE_NORMAL); DelEmptyTree(AddDirSuffix(Dir) + sr.Name, True); end; fr := FindNext(sr); end; finally FindClose(sr); end; if DelRoot then RemoveDir(Dir);end;// 取文件夹文件数function GetDirFiles(Dir: string): Integer;var sr: TSearchRec; fr: Integer;begin Result := 0; fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr); while fr = 0 do begin if (sr.Name <> '.') and (sr.Name <> '..') then Inc(Result); fr := FindNext(sr); end; FindClose(sr);end;function FindFormByClass(AClass: TClass): TForm;var i: Integer;begin Result := nil; for i := 0 to Screen.FormCount - 1 do begin if Screen.Forms[i] is AClass then begin Result := Screen.Forms[i]; Exit; end; end;end;var FindAbort: 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); var APath: string; Info: TSearchRec; Succ: Integer; begin FindAbort := False; APath := MakePath(MakePath(Path) + SubPath); Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info); try while Succ = 0 do begin if (Info.Name <> '.') and (Info.Name <> '..') then begin if (Info.Attr and faDirectory) <> faDirectory then begin if Assigned(Proc) then Proc(APath + Info.FindData.cFileName, Info, FindAbort); end end; if bMsg then Application.ProcessMessages; if FindAbort then Exit; Succ := FindNext(Info); end; finally FindClose(Info); end; if bSub then begin Succ := FindFirst(APath + '*.*', faAnyFile - faVolumeID, Info); try while Succ = 0 do begin if (Info.Name <> '.') and (Info.Name <> '..') and (Info.Attr and faDirectory = faDirectory) then begin if Assigned(DirProc) then DirProc(MakePath(SubPath) + Info.Name); DoFindFile(Path, MakePath(SubPath) + Info.Name, FileName, Proc, DirProc, bSub, bMsg); if FindAbort then Exit; end; Succ := FindNext(Info); end; finally FindClose(Info); end; end; end;begin DoFindFile(Path, '', FileName, Proc, DirProc, bSub, bMsg); Result := not FindAbort;end;// 文件打开方式function OpenWith(const FileName: string): Integer;begin Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe', PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);end;// 检查指定的应用程序是否正在运行// 作者：周劲羽 2002.08.12function CheckAppRunning(const FileName: string; var Running: Boolean): Boolean;var hSnap: THandle; ppe: TProcessEntry32; AName: string;begin Result := False; AName := Trim(FileName); if AName = '' then Exit; // 如果为空直接退出 if ExtractFileExt(FileName) = '' then // 默认扩展名为 EXE AName := AName + '.EXE'; hSnap := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); // 创建当前进程快照 if hSnap <> INVALID_HANDLE_VALUE then try if Process32First(hSnap, ppe) then // 取第一个进程信息 repeat if AnsiCompareText(ExtractFileName(ppe.szExeFile), AName) = 0 then begin // 比较应用程序名 Running := True; Result := True; Exit; end; until not Process32Next(hSnap, ppe); // 取下一个进程信息 Result := GetLastError = ERROR_NO_MORE_FILES; // 判断查找是否正常结束 finally CloseHandle(hSnap); // 关闭句柄 end;end;// 取文件版本号function GetFileVersionNumber(const FileName: string): TVersionNumber;var VersionInfoBufferSize: DWORD; dummyHandle: DWORD; VersionInfoBuffer: Pointer; FixedFileInfoPtr: PVSFixedFileInfo; VersionValueLength: UINT;begin FillChar(Result, SizeOf(Result), 0); if not FileExists(FileName) then Exit; VersionInfoBufferSize := GetFileVersionInfoSize(PChar(FileName), dummyHandle); if VersionInfoBufferSize = 0 then Exit; GetMem(VersionInfoBuffer, VersionInfoBufferSize); try try Win32Check(GetFileVersionInfo(PChar(FileName), dummyHandle, VersionInfoBufferSize, VersionInfoBuffer)); Win32Check(VerQueryValue(VersionInfoBuffer, '\', Pointer(FixedFileInfoPtr), VersionValueLength)); except Exit; end; Result.Major := FixedFileInfoPtr^.dwFileVersionMS shr 16; Result.Minor := FixedFileInfoPtr^.dwFileVersionMS; Result.Release := FixedFileInfoPtr^.dwFileVersionLS shr 16; Result.Build := FixedFileInfoPtr^.dwFileVersionLS; finally FreeMem(VersionInfoBuffer); end;end;// 取文件版本字符串function GetFileVersionStr(const FileName: string): string;begin with GetFileVersionNumber(FileName) do Result := Format('%d.%d.%d.%d', [Major, Minor, Release, Build]);end;// 取文件信息function GetFileInfo(const FileName: string; var FileSize: Int64; var FileTime: TDateTime): Boolean;var Handle: THandle; FindData: TWin32FindData;begin Result := False; Handle := FindFirstFile(PChar(FileName), FindData); if Handle <> INVALID_HANDLE_VALUE then begin Windows.FindClose(Handle); if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then begin Int64Rec(FileSize).Lo := FindData.nFileSizeLow; Int64Rec(FileSize).Hi := FindData.nFileSizeHigh; FileTime := FileTimeToDateTime(FindData.ftLastWriteTime); Result := True; end; end;end;// 取文件长度function GetFileSize(const FileName: string): Int64;var FileTime: TDateTime;begin Result := -1; GetFileInfo(FileName, Result, FileTime);end;// 取文件Delphi格式日期时间function GetFileDateTime(const FileName: string): TDateTime;var Size: Int64;begin Result := 0; GetFileInfo(FileName, Size, Result);end;// 将文件读为字符串function LoadStringFromFile(const FileName: string): string;begin try with TStringList.Create do try LoadFromFile(FileName); Result := Text; finally Free; end; except Result := ''; end;end;// 保存字符串到为文件function SaveStringToFile(const S, FileName: string): Boolean;begin try with TStringList.Create do try Text := S; SaveToFile(FileName); Result := True; finally Free; end; except Result := False; end;end;//------------------------------------------------------------------------------// 环境变量相关//------------------------------------------------------------------------------procedure MultiSzToStrings(const Dest: TStrings; const Source: PChar);var P: PChar;begin Assert(Dest <> nil); Dest.Clear; if Source <> nil then begin P := Source; while P^ <> #0 do begin Dest.Add(P); P := StrEnd(P); Inc(P); end; end;end;function DelEnvironmentVar(const Name: string): Boolean;begin Result := SetEnvironmentVariable(PChar(Name), nil);end;function ExpandEnvironmentVar(var Value: string): Boolean;var R: Integer; Expanded: string;begin SetLength(Expanded, 1); R := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), 0); SetLength(Expanded, R); Result := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), R) <> 0; if Result then begin StrResetLength(Expanded); Value := Expanded; end;end;function GetEnvironmentVar(const Name: string; var Value: string; Expand: Boolean): Boolean;var R: DWORD;begin R := GetEnvironmentVariable(PChar(Name), nil, 0); SetLength(Value, R); R := GetEnvironmentVariable(PChar(Name), PChar(Value), R); Result := R <> 0; if not Result then Value := '' else begin SetLength(Value, R); if Expand then ExpandEnvironmentVar(Value); end;end;function GetEnvironmentVars(const Vars: TStrings; Expand: Boolean): Boolean;var Raw: PChar; Expanded: string; I: Integer;begin Vars.Clear; Raw := GetEnvironmentStrings; try MultiSzToStrings(Vars, Raw); Result := True; finally FreeEnvironmentStrings(Raw); end; if Expand then begin for I := 0 to Vars.Count - 1 do begin Expanded := Vars[I]; if ExpandEnvironmentVar(Expanded) then Vars[I] := Expanded; end; end;end;function SetEnvironmentVar(const Name, Value: string): Boolean;begin Result := SetEnvironmentVariable(PChar(Name), PChar(Value));end;//------------------------------------------------------------------------------// 扩展的字符串操作函数//------------------------------------------------------------------------------// 判断字符串是否可转换成浮点型function IsFloat(const s: String): Boolean;var I: Real; E: Integer;begin Val(s, I, E); Result := E = 0; E := Trunc( I );end;// 判断字符串是否可转换成整型function IsInt(const s: String): Boolean;var I: Integer; E: Integer;begin Val(s, I, E); Result := E = 0; E := Trunc( I );end;// 判断字符串是否可转换成 DateTimefunction IsDateTime(const s: string): Boolean;begin try StrToDateTime(s); Result := True; except Result := False; end;end;// 判断是否有效的邮件地址function IsValidEmail(const s: string): Boolean;var i: Integer; AtCount: Integer;begin Result := False; if s = '' then Exit; AtCount := 0; for i := 1 to Length(s) do begin if s[i] = '@' then begin Inc(AtCount); if AtCount > 1 then Exit; end else if not (s[i] in ['0'..'9', 'a'..'z', 'A'..'Z', '_', '.', '-']) then Exit; end; Result := AtCount = 1;end;// 判断s1是否包含在s2中function InStr(const sShort: string; const sLong: string): Boolean;var s1, s2: string;begin s1 := LowerCase(sShort); s2 := LowerCase(sLong); Result := Pos(s1, s2) > 0;end;// 扩展整数转字符串函数，参数分别为目标数、长度、填充字符（默认为０）function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;begin Result := IntToStr(Value); while Length(Result) < Len do Result := FillChar + Result;end;// 带分隔符的整数－字符转换function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;var s: string; i, j: Integer;begin s := IntToStr(Value); Result := ''; j := 0; for i := Length(s) downto 1 do begin Result := 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;begin Result := StrToInt64(AnsiReplaceText(Value, Sp, ''));end;// 返回字符串右边的字符function StrRight(Str: string; Len: Integer): string;begin if Len >= Length(Str) then Result := '' else Result := Copy(Str, Length(Str) - Len + 1, Len);end;// 返回字符串左边的字符function StrLeft(Str: string; Len: Integer): string;begin if Len >= Length(Str) then Result := Str else Result := Copy(Str, 1, Len);end;// 字节转二进制串function ByteToBin(Value: Byte): string;const V: Byte = 1;var i: Integer;begin for i := 7 downto 0 do if (V shl i) and Value <> 0 then Result := Result + '1' else Result := Result + '0';end;// 返回字符串行function GetLine(C: Char; Len: Integer): string;begin Result := StringOfChar(C, Len);end;// 返回文本文件的行数function GetTextFileLineCount(FileName: String): Integer;var Lines: TStringList;begin Result := 0; Lines := TStringList.Create; try if FileExists(FileName) then begin Lines.LoadFromFile(FileName); Result := Result + Lines.Count; end; finally Lines.Free; end;end;// 返回空格串function Spc(Len: Integer): string;begin Result := StringOfChar(' ', Len);end;// 交换字串procedure SwapStr(var s1, s2: string);var tempstr: string;begin tempstr := s1; s1 := s2; s2 := tempstr;end;// 分割"非数字+数字"格式的字符串中的非数字和数字procedure SeparateStrAndNum(const AInStr: string; var AOutStr: string; var AOutNum: Integer);var iLen: Integer;begin iLen := Length(AInStr); while (iLen > 0) and (AInStr[iLen] in ['0'..'9']) do Dec(iLen); AOutStr := Copy(AInStr, iLen + 1, MaxInt); if AOutStr = '' then AOutNum := -1 else AOutNum := StrToInt(AOutStr); AOutStr := Copy(AInStr, 1, iLen);end;// 去除被引用的字符串的引用function UnQuotedStr(const str: string; const ch: Char; const sep: string = ''): string;var s: string; ps: PChar;begin Result := ''; s := str; ps := PChar(s); while ps <> nil do begin ps := AnsiStrScan(ps, ch); s := AnsiExtractQuotedStr(ps, ch); if (Result = '') or (s = '') then Result := Result + s else Result := Result + sep + s; end;end;// 查找字符串中出现的第 Counter 次的字符的位置function CharPosWithCounter(const Sub: Char; const AStr: string; Counter: Integer = 1): Integer;var I, J: Integer;begin Result := 0; if Counter <= 0 then Exit; if AStr <> '' then begin J := 0; for I := 1 to Length(AStr) do begin if AStr[I] = Sub then Inc(J); if J = Counter then begin Result := I; Exit; end; end; end;end;function CountCharInStr(const Sub: Char; const AStr: string): Integer;var I: Integer;begin Result := 0; if AStr = '' then Exit; for I := 1 to Length(AStr) do if AStr[I] = Sub then Inc(Result);end;// 判断字符是否有效标识符字符，First 表示是否为首字符function IsValidIdentChar(C: Char; First: Boolean): Boolean;begin if First then Result := C in Alpha else Result := C in AlphaNumeric;end;const csLinesCR = #13#10; csStrCR = '\n';// 多行文本转单行（换行符转'\n'）{$IFDEF COMPILER5}function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;const cSimpleBoolStrs: array [boolean] of String = ('0', '-1');begin if UseBoolStrs then begin if B then Result := 'True' else Result := 'False'; end else Result := cSimpleBoolStrs[B];end;{$ENDIF COMPILER5}function LinesToStr(const Lines: string): string;begin Result := StringReplace(Lines, csLinesCR, csStrCR, [rfReplaceAll]);end;// 单行文本转多行（'\n'转换行符）function StrToLines(const Str: string): string;begin Result := StringReplace(Str, csStrCR, csLinesCR, [rfReplaceAll]);end;// 日期转字符串，使用 yyyy.mm.dd 格式function MyDateToStr(Date: TDate): string;begin Result := CnDateToStr(Date);end;const csCount = 'Count'; csItem = 'Item';procedure ReadStringsFromIni(Ini: TCustomIniFile; const Section: string; Strings: TStrings);var Count, i: Integer;begin Strings.Clear; Count := Ini.ReadInteger(Section, csCount, 0); for i := 0 to Count - 1 do if Ini.ValueExists(Section, csItem + IntToStr(i)) then Strings.Add(Ini.ReadString(Section, csItem + IntToStr(i), ''));end;procedure WriteStringsToIni(Ini: TCustomIniFile; const Section: string; Strings: TStrings);var i: Integer;begin Ini.WriteInteger(Section, csCount, Strings.Count); for i := 0 to Strings.Count - 1 do Ini.WriteString(Section, csItem + IntToStr(i), Strings[i]);end;// 版本号转成字符串，如 $01020000 --> '1.2.0.0'function VersionToStr(Version: DWORD): string;begin Result := Format('%d.%d.%d.%d', [Version div $1000000, version mod $1000000 div $10000, version mod $10000 div $100, version mod $100]);end;// 字符串转成版本号，如 '1.2.0.0' --> $01020000，如果格式不正确，返回 $01000000function StrToVersion(s: string): DWORD;var Strs: TStrings;begin try Strs := TStringList.Create; try Strs.Text := StringReplace(s, '.', #13#10, [rfReplaceAll]); if Strs.Count = 4 then Result := StrToInt(Strs[0]) * $1000000 + StrToInt(Strs[1]) * $10000 + StrToInt(Strs[2]) * $100 + StrToInt(Strs[3]) else Result := $01000000; finally Strs.Free; end; except Result := $01000000; end;end;// 转换日期为 yyyy.mm.dd 格式字符串function CnDateToStr(Date: TDateTime): string;begin Result := FormatDateTime('yyyy.mm.dd', Date);end;// 将 yyyy.mm.dd 格式字符串转换为日期function CnStrToDate(const S: string): TDateTime;var i: Integer; Year, Month, Day: string;begin try i := 1; Year := ExtractSubstr(S, i, ['.', '/', '-']); Month := ExtractSubstr(S, i, ['.', '/', '-']); Day := ExtractSubstr(S, i, ['.', '/', '-']); Result := EncodeDate(StrToInt(Year), StrToInt(Month), StrToInt(Day)); except Result := 0; end;end;// 日期时间转 '20030203132345' 式样的 14 位数字字符串function DateTimeToFlatStr(const DateTime: TDateTime): string;var Year, Month, Day, Hour, Min, Sec, MSec: Word;begin DecodeDate(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;var Year, Month, Day, Hour, Min, Sec, MSec: Word;begin try Result := 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; except Result := False; end;end;// 字符串转注册表根键，支持 'HKEY_CURRENT_USER' 'HKCR' 长短两种格式function StrToRegRoot(const s: string): HKEY;begin if SameText(s, 'HKEY_CLASSES_ROOT') or SameText(s, 'HKCR') then Result := HKEY_CLASSES_ROOT else if SameText(s, 'HKEY_CURRENT_USER') or SameText(s, 'HKCU') then Result := HKEY_CURRENT_USER else if SameText(s, 'HKEY_LOCAL_MACHINE') or SameText(s, 'HKLM') then Result := HKEY_LOCAL_MACHINE else if SameText(s, 'HKEY_USERS') or SameText(s, 'HKU') then Result := HKEY_USERS else if SameText(s, 'HKEY_PERFORMANCE_DATA') or SameText(s, 'HKPD') then Result := HKEY_PERFORMANCE_DATA else if SameText(s, 'HKEY_CURRENT_CONFIG') or SameText(s, 'HKCC') then Result := HKEY_CURRENT_CONFIG else if SameText(s, 'HKEY_DYN_DATA') or SameText(s, 'HKDD') then Result := HKEY_DYN_DATA else Result := HKEY_CURRENT_USER;end;// 注册表根键转字符串，可选 'HKEY_CURRENT_USER' 'HKCR' 长短两种格式function RegRootToStr(Key: HKEY; ShortFormat: Boolean): string;begin if Key = HKEY_CLASSES_ROOT then if ShortFormat then Result := 'HKCR' else Result := 'HKEY_CLASSES_ROOT' else if Key = HKEY_CURRENT_USER then if ShortFormat then Result := 'HKCU' else Result := 'HKEY_CURRENT_USER' else if Key = HKEY_LOCAL_MACHINE then if ShortFormat then Result := 'HKLM' else Result := 'HKEY_LOCAL_MACHINE' else if Key = HKEY_USERS then if ShortFormat then Result := 'HKU' else Result := 'HKEY_USERS' else if Key = HKEY_PERFORMANCE_DATA then if ShortFormat then Result := 'HKPD' else Result := 'HKEY_PERFORMANCE_DATA' else if Key = HKEY_CURRENT_CONFIG then if ShortFormat then Result := 'HKCC' else Result := 'HKEY_CURRENT_CONFIG' else if Key = HKEY_DYN_DATA then if ShortFormat then Result := 'HKDD' else Result := 'HKEY_DYN_DATA' else Result := ''end;// 从字符串中分离出子串function ExtractSubstr(const S: string; var Pos: Integer; const Delims: TSysCharSet): string;var i: Integer;begin i := 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; var WildPos, FilePos, l, p: Integer; begin // Start at the first wildcard/filename character WildPos := 1; // Wildcard position. FilePos := 1; // FileName position. while (WildPos <= Length(WildS)) do begin // '*' matches any sequence of characters. if WildS[WildPos] = '*' then begin // We've reached the end of the wildcard string with a * and are done. if WildPos = Length(WildS) then begin Result := True; Exit; end else begin l := WildPos + 1; // Anything after a * in the wildcard must match literally. while (l < Length(WildS)) and (WildS[l + 1] <> '*') do Inc(l); // Check for the literal match immediately after the current position. p := Pos(Copy(WildS, WildPos + 1, l - WildPos), IstS); if p > 0 then FilePos := p - 1 else begin Result := 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])) then begin Result := 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; var i: Integer; begin i := Length(S); while (i > 0) and (S[i] <> C) do Dec(i); Result := i; end;var NameWild, 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 then begin // Assume .* if an extension is missing NameWild := FileWildcard; ExtWild := '*'; end else begin NameWild := 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 then DotPos := Length(FileName) + 1; NameFile := Copy(FileName, 1, DotPos - 1); ExtFile := Copy(FileName, DotPos + 1, Length(FileName)); // Case insensitive check if IgnoreCase then begin NameWild := AnsiUpperCase(NameWild); NameFile := AnsiUpperCase(NameFile); ExtWild := AnsiUpperCase(ExtWild); ExtFile := AnsiUpperCase(ExtFile); end; // Both the extension and the filename must match Result := WildCompare(NameWild, NameFile) and WildCompare(ExtWild, ExtFile);end;// 根据当前键盘布局将键盘扫描码转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用// 由于不调用 ToAscii，故可支持使用 Accent Character 的键盘布局function ScanCodeToAscii(Code: Word): Char;var i: Byte; C: Cardinal;begin C := Code; if GetKeyState(VK_SHIFT) < 0 then C := C or $10000; if GetKeyState(VK_CONTROL) < 0 then C := C or $20000; if GetKeyState(VK_MENU) < 0 then C := C or $40000; for i := Low(Byte) to High(Byte) do if OemKeyScan(i) = C then begin Result := Char(i); Exit; end; Result := #0;end;// 返回一个虚拟键是否 Dead keyfunction IsDeadKey(Key: Word): Boolean;begin Result := MapVirtualKey(Key, 2) and $80000000 <> 0;end;// 根据当前键盘状态将虚拟键转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用// 可能会导致 Accent Character 不正确function VirtualKeyToAscii(Key: Word): Char;var KeyState: TKeyboardState; ScanCode: Word; Buff: array[0..1] of Char;begin Result := #0; if not IsDeadKey(Key) then begin case Key of VK_SHIFT, VK_CONTROL, VK_MENU: ; else begin ScanCode := MapVirtualKey(Key, 0); GetKeyboardState(KeyState); if ToAscii(Key, ScanCode, KeyState, @Buff, 0) = 1 then Result := Buff[0]; end; end; end;end;// 根据当前的键盘布局将虚拟键和扫描码转换成 ASCII 字符。通过虚拟键来处理小键盘，// 扫描码处理大键盘，支持 Accent Character 的键盘布局function VK_ScanCodeToAscii(VKey: Word; Code: Word): Char;begin if (VKey >= VK_NUMPAD0) and (VKey <= VK_DIVIDE) then begin case VKey of VK_NUMPAD0..VK_NUMPAD9: if IsNumLockDown then Result := Char(Ord('0') + VKey - VK_NUMPAD0) else Result := #0; VK_MULTIPLY: Result := '*'; VK_ADD: Result := '+'; VK_SEPARATOR: Result := #13; VK_SUBTRACT: Result := '-'; VK_DECIMAL: Result := '.'; VK_DIVIDE: Result := '/'; else Result := #0; end; end else begin Result := ScanCodeToAscii(Code); end; end;// 返回当前的按键状态，暂不支持 ssDouble 状态function GetShiftState: TShiftState;var KeyState: TKeyboardState; function IsDown(Key: Byte): Boolean; begin Result := (Key and $80) = $80; end;begin Result := []; GetKeyboardState(KeyState); if IsDown(KeyState[VK_LSHIFT]) or IsDown(KeyState[VK_RSHIFT]) then Include(Result, ssShift); if IsDown(KeyState[VK_LMENU]) or IsDown(KeyState[VK_RMENU]) then Include(Result, ssAlt); if IsDown(KeyState[VK_LCONTROL]) or IsDown(KeyState[VK_RCONTROL]) then Include(Result, ssCtrl); if IsDown(KeyState[VK_LBUTTON]) then Include(Result, ssLeft); if IsDown(KeyState[VK_RBUTTON]) then Include(Result, ssRight); if IsDown(KeyState[VK_MBUTTON]) then Include(Result, ssMiddle);end;// 判断当前 Shift 是否按下function IsShiftDown: Boolean;begin Result := ssShift in GetShiftState;end;// 判断当前 Alt 是否按下function IsAltDown: Boolean;begin Result := ssAlt in GetShiftState;end;// 判断当前 Ctrl 是否按下function IsCtrlDown: Boolean;begin Result := ssCtrl in GetShiftState;end;// 判断当前 Insert 是否按下function IsInsertDown: Boolean;var KeyState: TKeyboardState;begin GetKeyboardState(KeyState); Result := Odd(KeyState[VK_INSERT]);end;// 判断当前 Caps Lock 是否按下function IsCapsLockDown: Boolean;var KeyState: TKeyboardState;begin GetKeyboardState(KeyState); Result := Odd(KeyState[VK_CAPITAL]);end;// 判断当前 NumLock 是否按下function IsNumLockDown: Boolean;var KeyState: TKeyboardState;begin GetKeyboardState(KeyState); Result := Odd(KeyState[VK_NUMLOCK]);end;// 判断当前 Scroll Lock 是否按下function IsScrollLockDown: Boolean;var KeyState: TKeyboardState;begin GetKeyboardState(KeyState); Result := Odd(KeyState[VK_SCROLL]);end;// 删除类名前缀 Tfunction RemoveClassPrefix(const ClassName: string): string;begin Result := ClassName; if (Result <> '') and (UpperCase(Result[1]) = 'T') then Delete(Result, 1, 1);end;// 用分号分隔的作者、邮箱字符串转换为输出格式function CnAuthorEmailToStr(Author, Email: string): string;var s1, s2: string; function GetLeftStr(var s: string; Sep: string): string; var i: Integer; begin Result := ''; i := AnsiPos(Sep, s); if i > 0 then begin Result := Trim(Copy(s, 1, i - 1)); Delete(s, 1, i); end else begin Result := s; s := ''; end; end;begin Result := ''; s1 := GetLeftStr(Author, ';'); s2 := GetLeftStr(Email, ';'); while s1 <> '' do begin if 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);begin if Caption = '' then Caption := SCnInformation; Application.MessageBox(PChar(Mess), PChar(Caption), Flags);end;// 显示提示确认窗口function InfoOk(Mess: string; Caption: string): Boolean;begin if Caption = '' then Caption := SCnInformation; Result := Application.MessageBox(PChar(Mess), PChar(Caption), MB_OKCANCEL + MB_ICONINFORMATION) = IDOK;end;// 显示错误窗口procedure ErrorDlg(Mess: string; Caption: string);begin if Caption = '' then Caption := SCnError; Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);end;// 显示警告窗口procedure WarningDlg(Mess: string; Caption: string);begin if Caption = '' then Caption := SCnWarning; Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);end;// 显示查询是否窗口function QueryDlg(Mess: string; DefaultNo: Boolean; Caption: string): Boolean;const Defaults: array[Boolean] of DWORD = (0, MB_DEFBUTTON2);begin if Caption = '' then Caption := SCnInformation; Result := Application.MessageBox(PChar(Mess), PChar(Caption), MB_YESNO + MB_ICONQUESTION + Defaults[DefaultNo]) = IDYES;end;function GetAveCharSize(Canvas: TCanvas): TPoint;var I: Integer; Buffer: array[0..51] of Char;begin for 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;var Form: TForm; Prompt: TLabel; Edit: TEdit; ComboBox: TComboBox; DialogUnits: TPoint; ButtonTop, ButtonWidth, ButtonHeight: Integer;begin Result := False; Edit := nil; ComboBox := nil; Form := TForm.Create(Application); with Form do try Scaled := 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 do begin Parent := Form; AutoSize := True; Left := MulDiv(8, DialogUnits.X, 4); Top := MulDiv(8, DialogUnits.Y, 8); Caption := APrompt; end; if Assigned(Ini) then begin ComboBox := TComboBox.Create(Form); with ComboBox do begin Parent := 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) then Text := ComboBox.Items[0] else Text := Value; SelectAll; end; end else begin Edit := TEdit.Create(Form); with Edit do begin Parent := 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) do begin Parent := Form; Caption := SCnMsgDlgOK; ModalResult := mrOk; Default := True; SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth, ButtonHeight); end; with TButton.Create(Form) do begin Parent := Form; Caption := SCnMsgDlgCancel; ModalResult := mrCancel; Cancel := True; SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth, ButtonHeight); end; if ShowModal = mrOk then begin if Assigned(ComboBox) then begin Value := ComboBox.Text; AddComboBoxTextToItems(ComboBox); WriteStringsToIni(Ini, Section, ComboBox.Items); end else Value := Edit.Text; Result := True; end; finally Form.Free; end;end;// 输入对话框function CnInputBox(const ACaption, APrompt, ADefault: string; Ini: TCustomIniFile; const Section: string): string;begin Result := ADefault; CnInputQuery(ACaption, APrompt, Result, Ini, Section);end;//------------------------------------------------------------------------------// 位扩展日期时间操作函数//------------------------------------------------------------------------------function GetYear(Date: TDate): Integer;var y, m, d: WORD;begin DecodeDate(Date, y, m, d); Result := y;end;function GetMonth(Date: TDate): Integer;var y, m, d: WORD;begin DecodeDate(Date, y, m, d); Result := m;end;function GetDay(Date: TDate): Integer;var y, m, d: WORD;begin DecodeDate(Date, y, m, d); Result := d;end;function GetHour(Time: TTime): Integer;var h, m, s, ms: WORD;begin DecodeTime(Time, h, m, s, ms); Result := h;end;function GetMinute(Time: TTime): Integer;var h, m, s, ms: WORD;begin DecodeTime(Time, h, m, s, ms); Result := m;end;function GetSecond(Time: TTime): Integer;var h, m, s, ms: WORD;begin DecodeTime(Time, h, m, s, ms); Result := s;end;function GetMSecond(Time: TTime): Integer;var h, m, s, ms: WORD;begin DecodeTime(Time, h, m, s, ms); Result := ms;end;//------------------------------------------------------------------------------// 位操作函数//------------------------------------------------------------------------------// 设置位procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean);begin if IsSet then Value := Value or (1 shl Bit) else Value := Value and not (1 shl Bit);end;procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean);begin if IsSet then Value := Value or (1 shl Bit) else Value := Value and not (1 shl Bit);end;procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean);begin if IsSet then Value := Value or (1 shl Bit) else Value := Value and not (1 shl Bit);end;// 取位function GetBit(Value: Byte; Bit: TByteBit): Boolean;begin Result := Value and (1 shl Bit) <> 0;end;function GetBit(Value: WORD; Bit: TWordBit): Boolean;begin Result := Value and (1 shl Bit) <> 0;end;function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;begin Result := Value and (1 shl Bit) <> 0;end;//------------------------------------------------------------------------------// 系统功能函数//------------------------------------------------------------------------------// 移动鼠标到控件procedure MoveMouseIntoControl(AWinControl: TControl);var rtControl: TRect;begin rtControl := 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);var Text: string;begin if ComboBox.Text <> '' then begin Text := ComboBox.Text; if ComboBox.Items.IndexOf(ComboBox.Text) < 0 then ComboBox.Items.Insert(0, ComboBox.Text) else ComboBox.Items.Move(ComboBox.Items.IndexOf(ComboBox.Text), 0); while (MaxItemsCount > 1) and (ComboBox.Items.Count > MaxItemsCount) do ComboBox.Items.Delete(ComboBox.Items.Count - 1); ComboBox.Text := Text; end;end;// 动态设置分辨率function DynamicResolution(x, y: WORD): Boolean;var lpDevMode: TDeviceMode;begin Result := EnumDisplaySettings(nil, 0, lpDevMode); if Result then begin lpDevMode.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);const csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);begin SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);end;var WndLong: Integer;// 设置程序是否出现在任务栏procedure SetHidden(Hide: Boolean);begin ShowWindow(Application.Handle, SW_HIDE); if Hide then SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST) else SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong); ShowWindow(Application.Handle, SW_SHOW);end;const csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);// 设置任务栏是否可见procedure SetTaskBarVisible(Visible: Boolean);var wndHandle: THandle;begin wndHandle := FindWindow('Shell_TrayWnd', nil); ShowWindow(wndHandle, csWndShowFlag[Visible]);end;// 设置桌面是否可见procedure SetDesktopVisible(Visible: Boolean);var hDesktop: THandle;begin hDesktop := FindWindow('Progman', nil); ShowWindow(hDesktop, csWndShowFlag[Visible]);end;// 强制让一个窗口显示在前台function ForceForegroundWindow(HWND: HWND): Boolean;var ThreadID1, ThreadID2: DWORD;begin if HWND = GetForegroundWindow then Result := True else begin ThreadID1 := GetWindowThreadProcessId(GetForegroundWindow, nil); ThreadID2 := GetWindowThreadProcessId(HWND, nil); if ThreadID1 <> ThreadID2 then begin AttachThreadInput(ThreadID1, ThreadID2, True); Result := SetForegroundWindow(HWND); AttachThreadInput(ThreadID1, ThreadID2, False); end else Result := SetForegroundWindow(HWND); if IsIconic(HWND) then ShowWindow(HWND, SW_RESTORE) else ShowWindow(HWND, SW_SHOW); end;end;// 取桌面区域function GetWorkRect(const Form: TCustomForm = nil): TRect;var Monitor: TMonitor; MonInfo: TMonitorInfo;begin Result.Top := 0; Result.Left := 0; Result.Right := Screen.Width; Result.Bottom := Screen.Height; if Assigned(Form) then begin Monitor := Form.Monitor; if Assigned(Monitor) then begin MonInfo.cbSize := SizeOf(MonInfo); GetMonitorInfo(Monitor.Handle, @MonInfo); Result := MonInfo.rcWork; end; end else SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);end;// 显示等待光标procedure BeginWait;begin Screen.Cursor := crHourGlass;end;// 结束等待光标procedure EndWait;begin Screen.Cursor := crDefault;end;// 检测是否Win95/98平台function CheckWindows9598: Boolean;var V: TOSVersionInfo;begin V.dwOSVersionInfoSize := SizeOf(V); Result := False; if not GetVersionEx(V) then Exit; if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then Result := True;end;// 检测是否WinXP以上平台function CheckWinXP: Boolean;begin Result := (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;var hMod:THandle; pfDllVersion: _DllGetVersion;begin Result := False; hMod := LoadLibrary(PChar(dllname)); if hMod <> 0 then try @pfDllVersion := GetProcAddress(hMod, 'DllGetVersion'); if @pfDllVersion = nil then Exit; FillChar(DVI, SizeOf(TDLLVERSIONINFO2), 0); DVI.info1.cbSize := SizeOf(TDLLVERSIONINFO2); Result := pfDllVersion(DVI) and $80000000 = 0; finally FreeLibrary(hMod); end;end;// 返回操作系统标识串function GetOSString: string;var OSPlatform: string; BuildNumber: Integer;begin Result := 'Unknown Windows Version'; OSPlatform := 'Windows'; BuildNumber := 0; case Win32Platform of VER_PLATFORM_WIN32_WINDOWS: begin BuildNumber := Win32BuildNumber and $0000FFFF; case Win32MinorVersion of 0..9: begin if Trim(Win32CSDVersion) = 'B' then OSPlatform := 'Windows 95 OSR2' else OSPlatform := 'Windows 95'; end; 10..89: begin if Trim(Win32CSDVersion) = 'A' then OSPlatform := 'Windows 98' else OSPlatform := 'Windows 98 SE'; end; 90: OSPlatform := 'Windows Millennium'; end; end; VER_PLATFORM_WIN32_NT: begin if Win32MajorVersion in [3, 4] then OSPlatform := 'Windows NT' else if Win32MajorVersion = 5 then begin case Win32MinorVersion of 0: OSPlatform := 'Windows 2000'; 1: OSPlatform := 'Windows XP'; end; end; BuildNumber := Win32BuildNumber; end; VER_PLATFORM_WIN32s: begin OSPlatform := 'Win32s'; BuildNumber := Win32BuildNumber; end; end; if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or (Win32Platform = VER_PLATFORM_WIN32_NT) then begin if Trim(Win32CSDVersion) = '' then Result := Format('%s %d.%d (Build %d)', [OSPlatform, Win32MajorVersion, Win32MinorVersion, BuildNumber]) else Result := Format('%s %d.%d (Build %d: %s)', [OSPlatform, Win32MajorVersion, Win32MinorVersion, BuildNumber, Win32CSDVersion]); end else Result := Format('%s %d.%d', [OSPlatform, Win32MajorVersion, Win32MinorVersion])end;// 得到本机名function GetComputeNameStr : string;var dwBuff : DWORD; aryCmpName : array [0..255] of Char;begin Result := ''; dwBuff := 256; FillChar(aryCmpName, SizeOf(aryCmpName), 0); if GetComputerName(aryCmpName, dwBuff) then Result := StrPas(aryCmpName);end;// 得到本机用户名function GetLocalUserName: string;var Count: DWORD;begin Count := 256 + 1; // UNLEN + 1 // set buffer size to 256 + 2 characters SetLength(Result, Count); if GetUserName(PChar(Result), Count) then StrResetLength(Result) else Result := '';end;function REG_CURRENT_VERSION: string;begin if CheckWindows9598 then Result := HKLM_CURRENT_VERSION_WINDOWS else Result := HKLM_CURRENT_VERSION_NT;end;function GetRegisteredCompany: string;begin Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOrganization', '');end;function GetRegisteredOwner: string;begin Result := RegReadStringDef(HKEY_LOCAL_MACHINE, REG_CURRENT_VERSION, 'RegisteredOwner', '');end;//------------------------------------------------------------------------------// 其它过程//------------------------------------------------------------------------------// 返回控件在屏幕上的坐标区域function GetControlScreenRect(AControl: TControl): TRect;var AParent: TWinControl;begin Assert(Assigned(AControl)); AParent := AControl.Parent; Assert(Assigned(AParent)); with AControl do begin Result.TopLeft := AParent.ClientToScreen(Point(Left, Top)); Result.BottomRight := AParent.ClientToScreen(Point(Left + Width, Top + Height)); end;end;// 设置控件在屏幕上的坐标区域procedure SetControlScreenRect(AControl: TControl; ARect: TRect);var AParent: TWinControl; P1, P2: TPoint;begin Assert(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);var i: Integer; Width, MaxWidth: Integer;begin Assert(Assigned(Listbox)); MaxWidth := 0; for i := 0 to Listbox.Items.Count - 1 do begin Width := Listbox.Canvas.TextWidth(Listbox.Items[i]) + 4; if Width > MaxWidth then MaxWidth := Width; end; if ListBox is TCheckListBox then Inc(MaxWidth, GetSystemMetrics(SM_CXMENUCHECK) + 2); SendMessage(Listbox.Handle, LB_SETHORIZONTALEXTENT, MaxWidth, 0);end;// 输出限制在Min..Max之间function TrimInt(Value, Min, Max: Integer): Integer; overload;begin if Value > Max then Result := Max else if Value < Min then Result := Min else Result := Value;end;// 比较两个整数，V1 > V2 返回 1，V1 < V2 返回 -1，V1 = V2 返回 0// 如果 Desc 为 True，返回结果反向function CompareInt(V1, V2: Integer; Desc: Boolean = False): Integer;begin if V1 > V2 then Result := 1 else if V1 < V2 then Result := -1 else // V1 = V2 Result := 0; if Desc then Result := -Result;end;// 输出限制在0..255之间function IntToByte(Value: Integer): Byte; overload;asm OR EAX, EAX JNS @@Positive XOR EAX, EAX RET@@Positive: CMP EAX, 255 JBE @@OK MOV EAX, 255@@OK:end;// 由TRect分离出坐标、宽高procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);begin x := Rect.Left; y := Rect.Top; Width := Rect.Right - Rect.Left; Height := Rect.Bottom - Rect.Top;end;// 比较两个Rectfunction RectEqu(Rect1, Rect2: TRect): Boolean;begin Result := (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;begin Result.cx := cx; Result.cy := cy;end;// 计算Rect的宽度function RectWidth(Rect: TRect): Integer;begin Result := Rect.Right - Rect.Left;end;// 计算Rect的高度function RectHeight(Rect: TRect): Integer;begin Result := Rect.Bottom - Rect.Top;end;// 判断范围function InBound(Value: Integer; V1, V2: Integer): Boolean;begin Result := (Value >= Min(V1, V2)) and (Value <= Max(V1, V2));end;// 比较两个方法地址是否相等function SameMethod(Method1, Method2: TMethod): Boolean;begin Result := CompareMem(@Method1, @Method2, SizeOf(TMethod));end;// 二分法在列表中查找function HalfFind(List: TList; P: Pointer; SCompare: TListSortCompare): Integer;var L, R, M: Integer; Res: Integer;begin Result := -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 do begin M := (L + R) shr 1; Res := SCompare(P, List[M]); if Res > 0 then L := M else if Res < 0 then R := M else begin Result := M; Exit; end; if L = R then Exit else if R - L = 1 then begin if SCompare(P, List[L]) = 0 then Result := L else if SCompare(P, List[R]) = 0 then Result := R; Exit; end; end;end;// 二分法在排序列表中查找，支持重复记录，返回一个范围值function HalfFindEx(List: TList; P: Pointer; SCompare: TListSortCompare): TFindRange;var i, Idx: Integer;begin Idx := HalfFind(List, P, SCompare); Result.tgFirst := Idx; for i := Idx - 1 downto 0 do if SCompare(P, List[i]) = 0 then Result.tgFirst := i else Break; Result.tgLast := Idx; for i := Idx + 1 to List.Count - 1 do if SCompare(P, List[i]) = 0 then Result.tgLast := i else Break;end;// 交换两个数procedure CnSwap(var A, B: Byte); overload;var Tmp: Byte;begin Tmp := A; A := B; B := Tmp;end;procedure CnSwap(var A, B: Integer); overload;var Tmp: Integer;begin Tmp := A; A := B; B := Tmp;end;procedure CnSwap(var A, B: Single); overload;var Tmp: Single;begin Tmp := A; A := B; B := Tmp;end;procedure CnSwap(var A, B: Double); overload;var Tmp: Double;begin Tmp := A; A := B; B := Tmp;end;// 延时procedure Delay(const uDelay: DWORD);var n: DWORD;begin n := GetTickCount; while GetTickCount - n <= uDelay do Application.ProcessMessages;end;// 在Win9X下让喇叭发声procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);const FREQ_SCALE = $1193180;var Temp: WORD;begin Temp := FREQ_SCALE div Freq; asm in 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); asm in al,$61; and al,$fc; out $61,al; end;end;function GetLastErrorMsg(IncludeErrorCode: Boolean): string;var ErrNo: Integer; Buf: array[0..255] of Char;begin ErrNo := GetLastError; FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, $400, Buf, 255, nil); if Buf = '' then StrCopy(@Buf, PChar(SUnknowError)); Result := Buf; if IncludeErrorCode then Result := Result + #10#13 + SErrorCode + IntToStr(ErrNo);end;// 显示Win32 Api运行结果信息procedure ShowLastError;begin MessageBox(Application.Handle, PChar(GetLastErrorMsg), PChar(SCnInformation), MB_OK + MB_ICONINFORMATION);end;// 取汉字的拼音function GetHzPy(const AHzStr: string): string;const ChinaCode: 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));var i, j, HzOrd: Integer;begin Result := ''; i := 1; while i <= Length(AHzStr) do begin if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then begin HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160; for j := 0 to 25 do begin if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then begin Result := 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;var Ver: TDLLVERSIONINFO2; iSelStart, Len: Integer; i, j, itemp: Integer; stext: string;begin Assert(Assigned(edt)); Result := edt.SelText; if not DllGetVersion('comctl32.dll', Ver) then Exit; if Ver.info1.dwMajorVersion <= 5 then Exit; with edt do begin Result := ''; if SelLength <= 0 then Exit; stext := edt.Text; iSelStart := 0; i := 0; j := 1; itemp := SelStart; while i < itemp do begin if ByteType(stext, j) <> mbLeadByte then Inc(i); Inc(iSelStart); Inc(j); end; Len := SelLength; i := 0; j := 1; while i < Len do begin Result := Result + stext[iSelStart + j]; if ByteType(stext, iSelStart + j) <> mbLeadByte then Inc(i); Inc(j); end; end;end;// 删除空行和每一行的行首尾空格procedure TrimStrings(AList: TStrings);var i: Integer;begin for i := AList.Count - 1 downto 0 do begin AList[i] := Trim(AList[i]); if AList[i] = '' then AList.Delete(i); end;end;// 声卡是否存在function SoundCardExist: Boolean;begin Result := WaveOutGetNumDevs > 0;end;// 判断 ASrc 是否派生自类名为 AClass 的类function InheritsFromClassName(ASrc: TClass; const AClass: string): Boolean;begin Result := False; while ASrc <> nil do begin if ASrc.ClassNameIs(AClass) then begin Result := True; Exit; end; ASrc := ASrc.ClassParent; end;end;// 判断 AObject 是否派生自类名为 AClass 的类function InheritsFromClassName(AObject: TObject; const AClass: string): Boolean;begin Result := InheritsFromClassName(AObject.ClassType, AClass);end; // 根据文件名结束进程，不区分路径procedure KillProcessByFileName(const FileName: String);var ID:DWORD; S, Tmp: string; Ret: Boolean; SnapshotHandle: THandle; PE32: TProcessEntry32; hh: HWND;begin S := LowerCase(FileName); SnapshotHandle := CreateToolHelp32Snapshot(TH32CS_SNAPPROCESS, 0); PE32.dwSize := SizeOf(PE32); Ret := Process32First(SnapshotHandle, PE32); while Integer(Ret) <> 0 do begin Tmp := LowerCase(PE32.szExeFile); if Pos(S, Tmp) > 0 then begin Id := 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;var AObject: TObject; Dot: Integer; RestProp: String;begin Dot := Pos('.', PropName); if Dot = 0 then begin Result := GetPropInfo(Instance, PropName, AKinds); end else begin if GetPropInfo(Instance, Copy(PropName, 1, Dot - 1)) <> nil then begin AObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1)); if AObject = nil then Result := nil else begin RestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot); Result := GetPropInfoIncludeSub(AObject, RestProp, AKinds); end; end else Result := nil; end;end;// 获得级联属性值function GetPropValueIncludeSub(Instance: TObject; PropName: string; PreferStrings: Boolean = True): Variant;const SCnControlFont = '!Font';var AObject: TObject; Dot: Integer; RestProp: String; IntToId: TIntToIdent; IdValue: String; PropInfo: PPropInfo;begin Result := Null; if Instance = nil then Exit; Dot := Pos('.', PropName); if Dot = 0 then begin if (Instance is TStrings) and (PropName = 'Text') then begin Result := (Instance as TStrings).Text; Exit; end else if (Instance is TListItem) and (PropName = 'Caption') then begin Result := (Instance as TListItem).Caption; Exit; end else if (Instance is TTreeNode) and (PropName = 'Text') then begin Result := (Instance as TTreeNode).Text; Exit; end else if PropName = SCnControlFont then // 在此内部处理 !Font 的情况 begin PropName := 'Font'; PropInfo := GetPropInfo(Instance, PropName); if PropInfo = nil then Exit; if PropInfo^.PropType^.Kind = tkClass then begin try Result := FontToString(TFont(GetObjectProp(Instance, PropName))); except ; end; Exit; end; end; PropInfo := GetPropInfo(Instance, PropName); if PropInfo = nil then Exit; if PropInfo^.PropType^.Kind = tkClass then begin Result := Integer(GetObjectProp(Instance, PropName)); Exit; end; Result := GetPropValue(Instance, PropName, PreferStrings); if (Result <> Null) and IsInt(Result) then // 如果返回整数，尝试将其转换成常量。 begin if PropInfo^.PropType^.Kind = tkInteger then begin IntToId := FindIntToIdent(PPropInfo(PropInfo)^.PropType^); if Assigned(IntToId) and IntToId(Result, IdValue) then Result := IdValue; end end end else begin // 递归寻找 AObject := nil; if GetPropInfo(Instance, Copy(PropName, 1, Dot - 1)) <> nil then AObject := GetObjectProp(Instance, Copy(PropName, 1, Dot - 1)); if AObject = nil then Result := Null else begin RestProp := Copy(PropName, Dot + 1, Length(PropName) - Dot); Result := GetPropValueIncludeSub(AObject, RestProp); end; end;end;// 设置级联属性值，不处理异常procedure DoSetPropValueIncludeSub(Instance: TObject; const PropName: string; Value: Variant);var AObject: TObject; Dot, IntValue: Integer; RestProp: String; PropInfo: PPropInfo; IdToInt: TIdentToInt;begin Dot := Pos('.', PropName); if Dot = 0 then begin PropInfo := GetPropInfo(Instance, PropName); if PropInfo^.PropType^.Kind = tkInteger then begin IdToInt := FindIdentToInt(PPropInfo(PropInfo)^.PropType^); if Assigned(IdToInt) and IdToInt(Value, IntValue) then SetPropValue(Instance, PropName, IntValue) else SetPropValue(Instance, PropName, Value) end else begin if (PropInfo^.PropType^.Kind in [tkSet, tkEnumeration]) and (VarType(Value) <> varInteger) then Value := Trim(Value); SetPropValue(Instance, PropName, Value); end; end else begin // 递归设置 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;begin try DoSetPropValueIncludeSub(Instance, PropName, Value); Result := True; except Result := False; end;end;// 字符串转集合值function StrToSetValue(const Value: string; PInfo: PTypeInfo): Integer;var EnumInfo: PTypeInfo; EnumValue: 0..SizeOf(Integer) * 8 - 1; S: string; Strings: TStrings; i: Integer;begin Result := 0; S := Trim(Value); if S = '' then Exit; if S[1] = '[' then Delete(S, 1, 1); if S = '' then Exit; if S[Length(S)] = ']' then Delete(S, Length(S), 1); EnumInfo := GetTypeData(PInfo).CompType^; Strings := TStringList.Create; try Strings.CommaText := S; for i := 0 to Strings.Count - 1 do begin EnumValue := GetEnumValue(EnumInfo, Trim(Strings[i])); if (EnumValue < GetTypeData(EnumInfo)^.MinValue) or (EnumValue > GetTypeData(EnumInfo)^.MaxValue) then Exit; // 不是有效的枚举值 Include(TIntegerSet(Result), EnumValue); end; finally Strings.Free; end;end;// 判断某 Control 的 ParentFont 属性是否为 True，如无 Parent 则返回 Falsefunction IsParentFont(AControl: TControl): Boolean;begin try Result := not (AControl.Parent = nil); if Result then Result := TCnFontControl(AControl).ParentFont; except Result := False; end;end;// 取某 Control 的 Parent 的 Font 属性，如果没有返回 nilfunction GetParentFont(AControl: TComponent): TFont;begin Result := nil; try if AControl <> nil then begin if AControl is TControl then begin if TControl(AControl).Parent <> nil then Result := TCnFontControl(TControl(AControl).Parent).Font; end else if AControl is TComponent then begin if (AControl.Owner <> nil) and (AControl.Owner is TControl) then Result := TCnFontControl(AControl.Owner).Font; end; end; except ; end;end;//查找字符串在动态数组中的索引，用于string类型使用Case语句function IndexStr(AText: string; AValues: array of string; IgCase: Boolean = True): Integer;type TSameFunc = function(const S1, S2: string): Boolean;var Index: Integer; SameFunc: TSameFunc;begin Result := -1; if IgCase then SameFunc := AnsiSameText else SameFunc := AnsiSameStr; for Index := Low(AValues) to High(AValues) do if SameFunc(AValues[Index], AText) then begin Result := Index; Exit; end;end;// 查找整形变量在动态数组中的索引，用于变量使用Case语句function IndexInt(ANum: Integer; AValues: array of Integer): Integer;var Index: Integer;begin Result := -1; for Index := Low(AValues) to High(AValues) do if ANum = AValues[Index] then begin Result := Index; Exit; end;end;initialization WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);end. 0 0
- CnPack开发包基础库
- CnPack开发包基础库
- 在 CnPack 开发中使用 CVS
- CnPack 开发组以及产品介绍
- CnPack VCL组件库中 TCnButtonEdit 组件的BUG修正
- 开放源码的 CnPack IDE 专家包发布 0.9.1 版 !
- SSH开发基础-Spring包结构说明
- SAS JAVA基础开发包下载
- SSH开发基础-hibernate 包结构说明
- 认识ExtJs的开发包(基础必备)
- cnpack转换dfm文件
- cnpack 菜单顺序
- CnPack实用功能推荐
- JQUERY 闭包基础及插件开发基础
- SSH开发基础-Struts相关jar包简介
- Oracle11g基础学习---------（5） 开发子程序和包
- Extjs学习(基础系列 - 认识Extjs开发包)
- [Lua基础]包package——模块开发
- linux常用命令（50）：tftp 命令
- HDU 1237(简单计算器)栈的应用-表达式求值
- Linux下目录的合并以及文件的覆盖案例
- MySQL数据库MyISAM和InnoDB存储引擎的比较
- 【J2EE】企业级项目开发总结--EJB篇
- CnPack开发包基础库
- 【iOS9】我在iOS9遇到的一些问题
- 大家好，，，刚刚来的菜鸟
- unity3d 学习笔记(五) 湖泊与瀑布
- 日志框架Nlog之前言
- SVN帮助文档
- 使用iLO远程管理HP系列服务器英文版操作步骤
- request.getQueryString()是什么意思
- 未能从程序集“System.ServiceModel, Version=3.0.0.0, Culture=neutral, PublicKeyToken=b77a5c561934e089”中加载类型“
