CnPack开发包基础库

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[..] of TRGBColor;

const

{$IFNDEF COMPILER6_UP}

  sLineBreak = {$IFDEF LINUX} # {$ENDIF} {$IFDEF MSWINDOWS} ## {$ENDIF};

{$ENDIF}

  Alpha = ['A'..'Z', 'a'..'z', '_'];

  AlphaNumeric = Alpha + [''..''];

//------------------------------------------------------------------------------

// 扩展的文件目录操作函数

//------------------------------------------------------------------------------

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 = ;

  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 = -..;

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 = ''): string;

{* 扩展整数转字符串函数}

function IntToStrSp(Value: Integer; SpLen: Integer = ; 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 = ): 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   = '[email protected];[email protected];[email protected]'

   Result  = 'Tom([email protected])' + #13#10 +

             'Jack([email protected])' + #13#10 +

             'Bill([email protected])

 |</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 = ..;

  {* Byte类型位数范围}

  TWordBit = ..;

  {* Word类型位数范围}

  TDWordBit = ..;

  {* 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 = );

{* 将 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 = ; const Delay: WORD = );

{* 在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) =  then

  begin

    Result := False;

    Exit;

  end;

  Dir := ExcludeTrailingBackslash(Dir);

  if (Length(Dir) < ) 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) + ##;

  s2 := PChar(dName) + ##;

  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) = ;

  except

    Result := False;

  end;

end;

// 删除文件到回收站

function DeleteToRecycleBin(const FileName: string): Boolean;

var

  s: AnsiString;

  lpFileOp: TSHFileOpStruct;

begin

  s := PChar(FileName) + ##;

  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) = ;

  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 := ;

    hInstApp := ;

    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 <= ) then

  begin

    Result := APath;

    Exit

  end

  else

  begin

    i := SLen;

    TString := APath;

    for j :=  to  do

    begin

      while (TString[i] <> '\') and (SLen - i < Width - ) do

        i := i - ;

      i := i - ;

    end;

    for j := SLen - i -  downto  do

      TString[Width - j] := TString[SLen - j];

    for j := SLen - i to SLen - i +  do

      TString[Width - j] := '.';

    Delete(TString, Width + , );

    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 + # + Ext + ##);

    lpstrCustomFilter := '';

    nMaxCustFilter := ;

    nFilterIndex := ;

    nMaxFile := MAX_PATH;

    SetLength(TempFilename, nMaxFile + );

    lpstrFile := PChar(TempFilename);

    FillChar(lpstrFile^, MAX_PATH, );

    SetLength(TempFilename, nMaxFile + );

    nMaxFileTitle := MAX_PATH;

    SetLength(ReturnFile, MAX_PATH + );

    lpstrFileTitle := PChar(ReturnFile);

    FillChar(lpstrFile^, MAX_PATH, );

    lpstrInitialDir := '.';

    lpstrTitle := PChar(Title);

    Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;

    nFileOffset := ;

    nFileExtension := ;

    lpstrDefExt := PChar(Ext);

    lCustData := ;

    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 <> ) then

    SendMessage(Wnd, BFFM_SETSELECTION, Integer(True), lpdata);

  Result := ;

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), );

  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 $;

        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 := ;

  s1 := s1 + #;

  s2 := s2 + #;

  Str1 := PChar(s1);

  Str2 := PChar(s2);

  while (s1[Result] = s2[Result]) and (s1[Result] <> #) do

  begin

    Inc(Result);

  end;

  Dec(Result);

{$IFDEF MSWINDOWS}

  if (StrByteType(Str1, Result - ) = mbLeadByte) or

    (StrByteType(Str2, Result - ) = mbLeadByte) then

    Dec(Result);

{$ENDIF}

{$IFDEF LINUX}

  if (StrByteType(Str1, Result - ) <> mbSingleByte) or

    (StrByteType(Str2, Result - ) <> mbSingleByte) then

    Dec(Result);

{$ENDIF}

end;

// 在字符串中某字符出现的次数

function CharCounts(Str: PChar; Chr: Char): Integer;

var

  p: PChar;

begin

  Result := ;

  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) >  do

    ATo := StringReplace(ATo, '\\', '\', [rfReplaceAll]);

  while AnsiPos('\\', AFrom) >  do

    AFrom := StringReplace(AFrom, '\\', '\', [rfReplaceAll]);

  if StrRight(ATo, ) = ':' then

    ATo := ATo + '\';

  if StrRight(AFrom, ) = ':' then

    AFrom := AFrom + '\';

  HeadNum := SameCharCounts(AnsiUpperCase(ExtractFilePath(ATo)),

    AnsiUpperCase(ExtractFilePath(AFrom)));

  if HeadNum >  then

  begin

    ATo := StringReplace(Copy(ATo, HeadNum + , MaxInt), '\', PathStr, [rfReplaceAll]);

    AFrom := Copy(AFrom, HeadNum + , MaxInt);

    Result := '';

    HeadNum := CharCounts(PChar(AFrom), '\');

    for i :=  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[..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) = ) or // C:\Test

                 (AnsiPos('\\', Tail) = ) or // \\Name\C\Test

                 (AnsiPos('://', Tail) > );  // ftp://ftp.abc.com

  if TailHasRoot then

  begin

    Result := Tail;

    Exit;

  end;

  UrlPos := AnsiPos('://', Head);

  HeadIsUrl := UrlPos > ;

  AHead := StringReplace(Head, '/', '\', [rfReplaceAll]);

  ATail := StringReplace(Tail, '/', '\', [rfReplaceAll]);

  TailIsRel := ATail[] = '\'; // 尾路径是相对路径

  if TailIsRel then

  begin

    if AnsiPos(':\', AHead) =  then

      Result := AHead[] + ':' + ATail

    else if AnsiPos('\\', AHead) =  then

    begin

      S := Copy(AHead, , MaxInt);

      i := AnsiPos('\', S);

      if i >  then

        Result := Copy(AHead, , i + ) + ATail

      else

        Result := AHead + ATail;

    end else if HeadIsUrl then

    begin

      S := Copy(AHead, UrlPos + , MaxInt);

      i := AnsiPos('\', S);

      if i >  then

        Result := Copy(AHead, , i + UrlPos + ) + ATail

      else

        Result := AHead + ATail;

    end

    else

    begin

      Result := Tail;

      Exit;

    end;

  end

  else

  begin

    if Copy(ATail, , ) = '.\' then

      Delete(ATail, , );

    AHead := MakeDir(AHead);

    i := Pos('..\', ATail);

    while i >  do

    begin

      AHead := ExtractFileDir(AHead);

      Delete(ATail, , );

      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) <  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) <  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), #);

  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[..] of Char;

  zCurDir: array[..] of Char;

  WorkDir: string;

  StartupInfo: TStartupInfo;

  ProcessInfo: TProcessInformation;

begin

  StrPCopy(zAppName, FileName);

  GetDir(, WorkDir);

  StrPCopy(zCurDir, WorkDir);

  FillChar(StartupInfo, SizeOf(StartupInfo), #);

  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 := -                        { 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 返回退出码。如果成功返回 True

function 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 :=  to ls.Count -  do

          slOutput.Add(ls[i]);

        strTemp := ls[ls.Count - ];

      finally

        ls.Free;

      end;

    end;

    if IsEnd and (strTemp <> '') then

    begin

      slOutput.Add(strTemp);

      strTemp := '';

    end;

  end;

begin

  dwExitCode := ;

  Result := False;

  try

    FillChar(sa, sizeof(sa), );

    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, ));

      FillChar(StartInfo, SizeOf(StartInfo), );

      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, ) = 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[..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[] = '\') 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), , KEY_READ, RegKey) = ERROR_SUCCESS then

  begin

    RegKind := ;

    Size := ;

    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, );

  if Required <>  then

  begin

    SetLength(Result, Required);

    GetWindowsDirectory(PChar(Result), Required);

    StrResetLength(Result);

  end;

end;

// 取临时文件路径

function GetWindowsTempPath: string;

var

  Required: Cardinal;

begin

  Result := '';

  Required := GetTempPath(, nil);

  if Required <>  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, );

  if Required <>  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[..MAX_PATH] of Char;

begin

  if GetLongPathNameA(PChar(FileName), @Buf, MAX_PATH) >  then

    Result := Buf

  else

    Result := FileName;

end;

// 长文件名转短文件名

function LongNameToShortName(const FileName: string): string;

var

  Buf: PChar;

  BufSize: Integer;

begin

  BufSize := GetShortPathName(PChar(FileName), nil, ) + ;

  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) =  then

      Result := F.Name

    else

      Result := ExtractFileName(FName);

    SysUtils.FindClose(F);

  end;

begin

  AName := MakeDir(FileName);

  if (Length(AName) > ) and (AName[] = ':') then

  begin

    Result := '';

    while Length(AName) >  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[..MAX_PATH] of Char;

  pc: PChar;

begin

  if ( = SearchPath(nil, PChar(AName), '.exe', SizeOf(fn), fn, pc)) and

     ( = SearchPath(nil, PChar(AName), '.com', SizeOf(fn), fn, pc)) and

     ( = 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) > ) 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_DESKTOP

function GetSpecialFolderLocation(const Folder: Integer): string;

var

  FolderPidl: PItemIdList;

begin

  if Succeeded(SHGetSpecialFolderLocation(, 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), );

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, EDX

end;

{$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)^) <> # do

  begin

 case c of

 '?': begin

          if n^ = '.' then

          begin

            while (p^ <> '.') and (p^ <> #) do

            begin

              if (p^ <> '?') and (p^ <> '*') then

              begin

                Result := -;

                Exit;

              end;

              Inc(p);

            end;

          end

          else

          begin

            if n^ <> # then

              Inc(n);

          end;

        end;

      '>': begin

          if n^ = '.' then

          begin

            if ((n + )^ = #) and (FileNameMatch(p, n+) = ) then

            begin

              Result := ;

              Exit;

            end;

            if FileNameMatch(p, n) =  then

            begin

              Result := ;

              Exit;

            end;

            Result := -;

            Exit;

          end;

          if n^ = # then

          begin

            Result := FileNameMatch(p, n);

            Exit;

          end;

          Inc(n);

        end;

      '*': begin

          while n^ <> # do

          begin

            if FileNameMatch(p, n) =  then

            begin

              Result := ;

              Exit;

            end;

            Inc(n);

          end;

        end;

      '<': begin

          while n^ <> # do

          begin

   if FileNameMatch(p, n) =  then

            begin

              Result := ;

              Exit;

            end;

            if (n^ = '.') and (StrScan(n + , '.') = nil) then

            begin

              Inc(n);

              Break;

            end;

            Inc(n);

          end;

        end;

      '"': begin

          if (n^ = #) and (FileNameMatch(p, n) = ) then

          begin

            Result := ;

            Exit;

          end;

          if n^ <> '.' then

          begin

            Result := -;

            Exit;

          end;

          Inc(n);

        end;

    else

      if (c = '.') and (n^ = #) then

      begin

        while p^ <> # do

        begin

          if (p^ = '*') and ((p + )^ = #) then

          begin

            Result := ;

            Exit;

          end;

          if p^ <> '?' then

          begin

            Result := -;

            Exit;

          end;

          Inc(p);

        end;

        Result := ;

        Exit;

end;

      if c <> n^ then

      begin

        Result := -;

        Exit;

      end;

      Inc(n);

    end;

  end;

  if n^ = # then

  begin

    Result := ;

    Exit;

  end;

  Result := -;

end;

// 文件名是否与扩展名通配符匹配

function MatchExt(const S, Ext: string): Boolean;

begin

  if S = '.*' then

  begin

    Result := True;

    Exit;

  end;

  Result := FileNameMatch(PChar(S), PChar(Ext)) = ;

end;

// 文件名是否与通配符匹配

function MatchFileName(const S, FN: string): Boolean;

begin

  if S = '*.*' then

  begin

    Result := True;

    Exit;

  end;

  Result := FileNameMatch(PChar(S), PChar(FN)) = ;

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 :=  to ExtList.Count -  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 >  then

        ExtList.Exchange(, 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 :=  to ExtList.Count -  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 :=  to ExtList.Count -  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 :=  to MaskList.Count -  do

  begin

    if StrScan(PChar(MaskList[i]), '.') <> nil then

    begin

      if MaskList[i][] = '.' 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 >  then

        MaskList.Exchange(, 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 :=  to MaskList.Count -  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 :=  to MaskList.Count -  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, ,

    nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, );

  Result := (HFileRes = INVALID_HANDLE_VALUE);

  if not Result then

    CloseHandle(HFileRes);

end;

// 判断文件是否为 Ascii 文件

function IsAscii(FileName: string): Boolean;

const

  Sett=;

var

  I: Integer;

  AFile: File;

  Bool: Boolean;

  TotSize, IncSize, ReadSize: Integer;

  C: array[..Sett] of Byte;

begin

  Result := False;

  if FileExists(FileName) then

  begin

    {$I-}

    AssignFile(AFile, FileName);

    Reset(AFile, );

    TotSize := FileSize(AFile);

    IncSize := ;

    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 :=  to ReadSize- do // Iterate

        if (C[I] < ) and (not(C[I] in [, , , ])) then Bool := False;

    end; // while

    CloseFile(AFile);

    {$I+}

    if IOResult <>  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 :=  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  do

  begin

    if Result[i] in InvalidFileNameChar then

      Delete(Result, i, );

  end;

  if Length(Result) > MAX_PATH -  then

    Result := Copy(Result, , MAX_PATH - );

end;

// 设置文件时间

function SetFileDate(const FileName: string; CreationTime, LastWriteTime, LastAccessTime:

  TFileTime): Boolean;

var

  FileHandle: Integer;

begin

  FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);

  if FileHandle >  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 >  then

  begin

    GetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime);

    FileClose(FileHandle);

    Result := True;

  end

  else

    Result := False;

end;

// 取得与文件相关的图标

// FileName: e.g. "e:\hao\a.txt"

// 成功则返回True

function 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),

    ,

    SHFileInfo,

    SizeOf(SHFileInfo),

    SHGFI_ICON or SHGFI_SYSICONINDEX);

  Icon.Handle := SHFileInfo.hIcon;

  Result := (h <> );

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     =  * ;

  SecondsPerDay     = MinutesPerDay * ;

// UTC 时间转本地时间

function DateTimeToLocalDateTime(DateTime: TDateTime): TDateTime;

var

  TimeZoneInfo: TTimeZoneInformation;

begin

  FillChar(TimeZoneInfo, SizeOf(TimeZoneInfo), #);

  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), #);

  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 = ;

  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)) = ;

end;

function AnsiReplaceText(const AText, AFromText, AToText: string): string;

begin

  Result := StringReplace(AText, AFromText, AToText, [rfReplaceAll, rfIgnoreCase]);

end;

{$ENDIF}

{$IFNDEF COMPILER7_UP}

// AText 是否包含 ASubText

function AnsiContainsText(const AText, ASubText: string): Boolean;

begin

  Result := AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText)) > ;

end;

{$ENDIF}

// 比较 SubText 在两个字符串中出现的位置的大小，如果相等则比较字符串本身，忽略大小写

function CompareTextPos(const ASubText, AText1, AText2: string): TValueRelationship;

begin

  Result := ;

  if ASubText <> '' then

    Result := CompareValue(AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText1)),

      AnsiPos(AnsiUpperCase(ASubText), AnsiUpperCase(AText2)));

  if Result =  then

    Result := CompareText(AText1, AText2);

end;

// 创建备份文件

function CreateBakFile(const FileName, Ext: string): Boolean;

var

  BakFileName: string;

  AExt: string;

begin

  if (Ext <> '') and (Ext[] = '.') 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 =  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 =  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 := ;

  fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);

  while fr =  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 :=  to Screen.FormCount -  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 =  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 =  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.12

function 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, ); // 创建当前进程快照

  if hSnap <> INVALID_HANDLE_VALUE then

  try

    if Process32First(hSnap, ppe) then  // 取第一个进程信息

      repeat

        if AnsiCompareText(ExtractFileName(ppe.szExeFile), AName) =  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), );

  if not FileExists(FileName) then

    Exit;

  VersionInfoBufferSize := GetFileVersionInfoSize(PChar(FileName), dummyHandle);

  if VersionInfoBufferSize =  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 ;

    Result.Minor := FixedFileInfoPtr^.dwFileVersionMS;

    Result.Release := FixedFileInfoPtr^.dwFileVersionLS shr ;

    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) =  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 := -;

  GetFileInfo(FileName, Result, FileTime);

end;

// 取文件Delphi格式日期时间

function GetFileDateTime(const FileName: string): TDateTime;

var

  Size: Int64;

begin

  Result := ;

  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^ <> # 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, );

  R := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), );

  SetLength(Expanded, R);

  Result := ExpandEnvironmentStrings(PChar(Value), PChar(Expanded), R) <> ;

  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, );

  SetLength(Value, R);

  R := GetEnvironmentVariable(PChar(Name), PChar(Value), R);

  Result := R <> ;

  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 :=  to Vars.Count -  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 = ;

  E := Trunc( I );

end;

// 判断字符串是否可转换成整型

function IsInt(const s: String): Boolean;

var

  I: Integer;

  E: Integer;

begin

  Val(s, I, E);

  Result := E = ;

  E := Trunc( I );

end;

// 判断字符串是否可转换成 DateTime

function 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 := ;

  for i :=  to Length(s) do

  begin

    if s[i] = '@' then

    begin

      Inc(AtCount);

      if AtCount >  then

        Exit;

    end

    else if not (s[i] in [''..'', 'a'..'z', 'A'..'Z', '_', '.', '-']) then

      Exit;

  end;

  Result := AtCount = ;

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) > ;

end;

// 扩展整数转字符串函数，参数分别为目标数、长度、填充字符（默认为０）

function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = ''): string;

begin

  Result := IntToStr(Value);

  while Length(Result) < Len do

    Result := FillChar + Result;

end;

// 带分隔符的整数－字符转换

function IntToStrSp(Value: Integer; SpLen: Integer = ; Sp: Char = ','): string;

var

  s: string;

  i, j: Integer;

begin

  s := IntToStr(Value);

  Result := '';

  j := ;

  for i := Length(s) downto  do

  begin

    Result := s[i] + Result;

    Inc(j);

    if ((j mod SpLen) = ) and (i <> ) 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 + , Len);

end;

// 返回字符串左边的字符

function StrLeft(Str: string; Len: Integer): string;

begin

  if Len >= Length(Str) then

    Result := Str

  else

    Result := Copy(Str, , Len);

end;

// 字节转二进制串

function ByteToBin(Value: Byte): string;

const

  V: Byte = ;

var

  i: Integer;

begin

  for i :=  downto  do

    if (V shl i) and Value <>  then

      Result := Result + ''

    else

      Result := Result + '';

end;

// 返回字符串行

function GetLine(C: Char; Len: Integer): string;

begin

  Result := StringOfChar(C, Len);

end;

// 返回文本文件的行数

function GetTextFileLineCount(FileName: String): Integer;

var

  Lines: TStringList;

begin

  Result := ;

  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 > ) and (AInStr[iLen] in [''..'']) do Dec(iLen);

  AOutStr := Copy(AInStr, iLen + , MaxInt);

  if AOutStr = '' then

    AOutNum := -

  else

    AOutNum := StrToInt(AOutStr);

  AOutStr := Copy(AInStr, , 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 = ): Integer;

var

  I, J: Integer;

begin

  Result := ;

  if Counter <=  then Exit;

  if AStr <> '' then

  begin

    J := ;

    for I :=  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 := ;

  if AStr = '' then Exit;

  for I :=  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 = ##;

  csStrCR = '\n';

// 多行文本转单行（换行符转'\n'）

{$IFDEF COMPILER5}

function BoolToStr(B: Boolean; UseBoolStrs: Boolean = False): string;

const

  cSimpleBoolStrs: array [boolean] of String = ('', '-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, );

  for i :=  to Count -  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 :=  to Strings.Count -  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 $, version mod $

    div $, version mod $ div $, version mod $]);

end;

// 字符串转成版本号，如 '1.2.0.0' --> $01020000，如果格式不正确，返回 $01000000

function StrToVersion(s: string): DWORD;

var

  Strs: TStrings;

begin

  try

    Strs := TStringList.Create;

    try

      Strs.Text := StringReplace(s, '.', ##, [rfReplaceAll]);

      if Strs.Count =  then

        Result := StrToInt(Strs[]) * $ + StrToInt(Strs[]) * $ +

          StrToInt(Strs[]) * $ + StrToInt(Strs[])

      else

        Result := $;

    finally

      Strs.Free;

    end;

  except

    Result := $;

  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 := ;

    Year := ExtractSubstr(S, i, ['.', '/', '-']);

    Month := ExtractSubstr(S, i, ['.', '/', '-']);

    Day := ExtractSubstr(S, i, ['.', '/', '-']);

    Result := EncodeDate(StrToInt(Year), StrToInt(Month), StrToInt(Day));

  except

    Result := ;

  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, ) + IntToStrEx(Month, ) + IntToStrEx(Day, ) +

    IntToStrEx(Hour, ) + IntToStrEx(Min, ) + IntToStrEx(Sec, );

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) <>  then Exit;

    Year := StrToInt(Copy(Section, , ));

    Month := StrToInt(Copy(Section, , ));

    Day := StrToInt(Copy(Section, , ));

    Hour := StrToInt(Copy(Section, , ));

    Min := StrToInt(Copy(Section, , ));

    Sec := StrToInt(Copy(Section, , ));

    MSec := ;

    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 := ; // Wildcard position.

    FilePos := ; // 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 + ;

          // Anything after a * in the wildcard must match literally.

          while (l < Length(WildS)) and (WildS[l + ] <> '*') do

            Inc(l);

          // Check for the literal match immediately after the current position.

          p := Pos(Copy(WildS, WildPos + , l - WildPos), IstS);

          if p >  then

            FilePos := p -

          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 > ) 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 =  then

  begin

    // Assume .* if an extension is missing

    NameWild := FileWildcard;

    ExtWild := '*';

  end

  else

  begin

    NameWild := Copy(FileWildcard, , DotPos - );

    ExtWild := Copy(FileWildcard, DotPos + , Length(FileWildcard));

  end;

  // We could probably modify this to use ExtractFileExt, etc.

  DotPos := LastCharPos(FileName, '.');

  if DotPos =  then

    DotPos := Length(FileName) + ;

  NameFile := Copy(FileName, , DotPos - );

  ExtFile := Copy(FileName, DotPos + , 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) <  then

    C := C or $;

  if GetKeyState(VK_CONTROL) <  then

    C := C or $;

  if GetKeyState(VK_MENU) <  then

    C := C or $;

  for i := Low(Byte) to High(Byte) do

    if OemKeyScan(i) = C then

    begin

      Result := Char(i);

      Exit;

    end;

  Result := #;

end;

// 返回一个虚拟键是否 Dead key

function IsDeadKey(Key: Word): Boolean;

begin

  Result := MapVirtualKey(Key, ) and $ <> ;

end;

// 根据当前键盘状态将虚拟键转换成 ASCII 字符，可在 WM_KEYDOWN 等处使用

// 可能会导致 Accent Character 不正确

function VirtualKeyToAscii(Key: Word): Char;

var

  KeyState: TKeyboardState;

  ScanCode: Word;

  Buff: array[..] of Char;

begin

  Result := #;

  if not IsDeadKey(Key) then

  begin

    case Key of

      VK_SHIFT, VK_CONTROL, VK_MENU:

        ;

    else

      begin

        ScanCode := MapVirtualKey(Key, );

        GetKeyboardState(KeyState);

        if ToAscii(Key, ScanCode, KeyState, @Buff, ) =  then

          Result := Buff[];

      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('') + VKey - VK_NUMPAD0)

        else

          Result := #;

      VK_MULTIPLY: Result := '*';

      VK_ADD: Result := '+';

      VK_SEPARATOR: Result := #;

      VK_SUBTRACT: Result := '-';

      VK_DECIMAL: Result := '.';

      VK_DIVIDE: Result := '/';

    else

      Result := #;

    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 $) = $;

  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;

// 删除类名前缀 T

function RemoveClassPrefix(const ClassName: string): string;

begin

  Result := ClassName;

  if (Result <> '') and (UpperCase(Result[]) = 'T') then

    Delete(Result, , );

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 >  then

    begin

      Result := Trim(Copy(s, , i - ));

      Delete(s, , 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 + ##;

    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 = (, 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[..] of Char;

begin

  for I :=  to  do Buffer[I] := Chr(I + Ord('A'));

  for I :=  to  do Buffer[I + ] := Chr(I + Ord('a'));

  GetTextExtentPoint(Canvas.Handle, Buffer, , TSize(Result));

  Result.X := Result.X div ;

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(, DialogUnits.X, );

      ClientHeight := MulDiv(, DialogUnits.Y, );

      Position := poScreenCenter;

      Prompt := TLabel.Create(Form);

      with Prompt do

      begin

        Parent := Form;

        AutoSize := True;

        Left := MulDiv(, DialogUnits.X, );

        Top := MulDiv(, DialogUnits.Y, );

        Caption := APrompt;

      end;

      if Assigned(Ini) then

      begin

        ComboBox := TComboBox.Create(Form);

        with ComboBox do

        begin

          Parent := Form;

          Left := Prompt.Left;

          Top := MulDiv(, DialogUnits.Y, );

          Width := MulDiv(, DialogUnits.X, );

          MaxLength := ;

          ReadStringsFromIni(Ini, Section, ComboBox.Items);

          if (Value = '') and (ComboBox.Items.Count > ) then

            Text := ComboBox.Items[]

          else

            Text := Value;

          SelectAll;

        end;

      end

      else

      begin

        Edit := TEdit.Create(Form);

        with Edit do

        begin

          Parent := Form;

          Left := Prompt.Left;

          Top := MulDiv(, DialogUnits.Y, );

          Width := MulDiv(, DialogUnits.X, );

          MaxLength := ;

          Text := Value;

          SelectAll;

        end;

      end;

      ButtonTop := MulDiv(, DialogUnits.Y, );

      ButtonWidth := MulDiv(, DialogUnits.X, );

      ButtonHeight := MulDiv(, DialogUnits.Y, );

      with TButton.Create(Form) do

      begin

        Parent := Form;

        Caption := SCnMsgDlgOK;

        ModalResult := mrOk;

        Default := True;

        SetBounds(MulDiv(, DialogUnits.X, ), ButtonTop, ButtonWidth,

          ButtonHeight);

      end;

      with TButton.Create(Form) do

      begin

        Parent := Form;

        Caption := SCnMsgDlgCancel;

        ModalResult := mrCancel;

        Cancel := True;

        SetBounds(MulDiv(, DialogUnits.X, ), 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 ( shl Bit)

  else

    Value := Value and not ( shl Bit);

end;

procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean);

begin

  if IsSet then

    Value := Value or ( shl Bit)

  else

    Value := Value and not ( shl Bit);

end;

procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean);

begin

  if IsSet then

    Value := Value or ( shl Bit)

  else

    Value := Value and not ( shl Bit);

end;

// 取位

function GetBit(Value: Byte; Bit: TByteBit): Boolean;

begin

  Result := Value and ( shl Bit) <> ;

end;

function GetBit(Value: WORD; Bit: TWordBit): Boolean;

begin

  Result := Value and ( shl Bit) <> ;

end;

function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;

begin

  Result := Value and ( shl Bit) <> ;

end;

//------------------------------------------------------------------------------

// 系统功能函数

//------------------------------------------------------------------------------

// 移动鼠标到控件

procedure MoveMouseIntoControl(AWinControl: TControl);

var

  rtControl: TRect;

begin

  rtControl := AWinControl.BoundsRect;

  MapWindowPoints(AWinControl.Parent.Handle, , rtControl, );

  SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div ,

    rtControl.Top + (rtControl.Bottom - rtControl.Top) div );

end;

// 将 ComboBox 的文本内容增加到下拉列表中

procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = );

var

  Text: string;

begin

  if ComboBox.Text <> '' then

  begin

    Text := ComboBox.Text;

    if ComboBox.Items.IndexOf(ComboBox.Text) <  then

      ComboBox.Items.Insert(, ComboBox.Text)

    else

      ComboBox.Items.Move(ComboBox.Items.IndexOf(ComboBox.Text), );

    while (MaxItemsCount > ) and (ComboBox.Items.Count > MaxItemsCount) do

      ComboBox.Items.Delete(ComboBox.Items.Count - );

    ComboBox.Text := Text;

  end;

end;

// 动态设置分辨率

function DynamicResolution(x, y: WORD): Boolean;

var

  lpDevMode: TDeviceMode;

begin

  Result := EnumDisplaySettings(nil, , lpDevMode);

  if Result then

  begin

    lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;

    lpDevMode.dmPelsWidth := x;

    lpDevMode.dmPelsHeight := y;

    Result := ChangeDisplaySettings(lpDevMode, ) = 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], , , , , 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 := ;

  Result.Left := ;

  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, , @Result, );

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 > ) or

    ((Win32MajorVersion = ) and (Win32MinorVersion >= ));

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 <>  then

  try

    @pfDllVersion := GetProcAddress(hMod, 'DllGetVersion');

    if @pfDllVersion = nil then

      Exit;

    FillChar(DVI, SizeOf(TDLLVERSIONINFO2), );

    DVI.info1.cbSize := SizeOf(TDLLVERSIONINFO2);

    Result := pfDllVersion(DVI) and $ = ;

  finally

    FreeLibrary(hMod);

  end;

end;

// 返回操作系统标识串

function GetOSString: string;

var

  OSPlatform: string;

  BuildNumber: Integer;

begin

  Result := 'Unknown Windows Version';

  OSPlatform := 'Windows';

  BuildNumber := ;

  case Win32Platform of

    VER_PLATFORM_WIN32_WINDOWS:

      begin

        BuildNumber := Win32BuildNumber and $0000FFFF;

        case Win32MinorVersion of

          ..:

            begin

              if Trim(Win32CSDVersion) = 'B' then

                OSPlatform := 'Windows 95 OSR2'

              else

                OSPlatform := 'Windows 95';

            end;

          ..:

            begin

              if Trim(Win32CSDVersion) = 'A' then

                OSPlatform := 'Windows 98'

              else

                OSPlatform := 'Windows 98 SE';

            end;

          :

            OSPlatform := 'Windows Millennium';

        end;

      end;

    VER_PLATFORM_WIN32_NT:

      begin

        if Win32MajorVersion in [, ] then

          OSPlatform := 'Windows NT'

        else if Win32MajorVersion =  then

        begin

          case Win32MinorVersion of

            : OSPlatform := 'Windows 2000';

            : 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 [..] of Char;

begin

  Result := '';

  dwBuff := ;

  FillChar(aryCmpName, SizeOf(aryCmpName), );

  if GetComputerName(aryCmpName, dwBuff) then

    Result := StrPas(aryCmpName);

end;

// 得到本机用户名

function GetLocalUserName: string;

var

  Count: DWORD;

begin

  Count :=  + ; // 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 := ;

  for i :=  to Listbox.Items.Count -  do

  begin

    Width := Listbox.Canvas.TextWidth(Listbox.Items[i]) + ;

    if Width > MaxWidth then

      MaxWidth := Width;

  end;

  if ListBox is TCheckListBox then

    Inc(MaxWidth, GetSystemMetrics(SM_CXMENUCHECK) + );

  SendMessage(Listbox.Handle, LB_SETHORIZONTALEXTENT, MaxWidth, );

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 :=

  else if V1 < V2 then

    Result := -

  else // V1 = V2

    Result := ;

  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,

        JBE    @@OK

        MOV    EAX,

@@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;

// 比较两个Rect

function 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 := -;

  L := ;

  R := List.Count - ;

  if R < L then Exit;

  if SCompare(P, List[L]) <  then Exit;

  if SCompare(P, List[R]) >  then Exit;

  while True do

  begin

    M := (L + R) shr ;

    Res := SCompare(P, List[M]);

    if Res >  then

      L := M

    else if Res <  then

      R := M

    else

    begin

      Result := M;

      Exit;

    end;

    if L = R then

      Exit

    else if R - L =  then

    begin

      if SCompare(P, List[L]) =  then

        Result := L

      else if SCompare(P, List[R]) =  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 -  downto  do

    if SCompare(P, List[i]) =  then

      Result.tgFirst := i

    else

      Break;

  Result.tgLast := Idx;

  for i := Idx +  to List.Count -  do

    if SCompare(P, List[i]) =  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 = ; const Delay: WORD = );

const

  FREQ_SCALE = $;

var

  Temp: WORD;

begin

  Temp := FREQ_SCALE div Freq;

  asm

    in al,61h;

    or al,;

    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,$;

    and al,$fc;

    out $,al;

  end;

end;

function GetLastErrorMsg(IncludeErrorCode: Boolean): string;

var

  ErrNo: Integer;

  Buf: array[..] of Char;

begin

  ErrNo := GetLastError;

  FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, $, Buf, , nil);

  if Buf = '' then StrCopy(@Buf, PChar(SUnknowError));

  Result := Buf;

  if IncludeErrorCode then

    Result := Result + ## + 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[.., ..] of Integer = ((, ), (, ), (, ),

    (, ), (, ), (, ), (, ), (, ), (, ),

    (, ), (, ), (, ), (, ), (, ), (, ),

    (, ), (, ), (, ), (, ), (, ), (, ),

    (, ), (, ), (, ), (, ), (, ));

var

  i, j, HzOrd: Integer;

begin

  Result := '';

  i := ;

  while i <= Length(AHzStr) do

  begin

    if (AHzStr[i] >= #) and (AHzStr[i + ] >= #) then

    begin

      HzOrd := (Ord(AHzStr[i]) - ) *  + Ord(AHzStr[i + ]) - ;

      for j :=  to  do

      begin

        if (HzOrd >= ChinaCode[j][]) and (HzOrd <= ChinaCode[j][]) 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 <=  then

    Exit;

  with edt do

  begin

    Result := '';

    if SelLength <=  then

      Exit;

    stext := edt.Text;

    iSelStart := ;

    i := ;

    j := ;

    itemp := SelStart;

    while i < itemp do

    begin

      if ByteType(stext, j) <> mbLeadByte then

        Inc(i);

      Inc(iSelStart);

      Inc(j);

    end;

    Len := SelLength;

    i := ;

    j := ;

    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 -  downto  do

  begin

    AList[i] := Trim(AList[i]);

    if AList[i] = '' then

      AList.Delete(i);

  end;

end;

// 声卡是否存在

function SoundCardExist: Boolean;

begin

  Result := WaveOutGetNumDevs > ;

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, );

  PE32.dwSize := SizeOf(PE32);

  Ret := Process32First(SnapshotHandle, PE32);

  while Integer(Ret) <>  do

  begin

    Tmp := LowerCase(PE32.szExeFile);

    if Pos(S, Tmp) >  then

    begin

      Id := PE32.th32ProcessID;

      hh := OpenProcess(PROCESS_ALL_ACCESS, True,Id);

      TerminateProcess(hh, );

    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 =  then

  begin

    Result := GetPropInfo(Instance, PropName, AKinds);

  end

  else

  begin

    if GetPropInfo(Instance, Copy(PropName, , Dot - )) <> nil then

    begin

      AObject := GetObjectProp(Instance, Copy(PropName, , Dot - ));

      if AObject = nil then

        Result :=  nil

      else

      begin

        RestProp := Copy(PropName, Dot + , 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 =  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, , Dot - )) <> nil then

      AObject := GetObjectProp(Instance, Copy(PropName, , Dot - ));

    if AObject = nil then

      Result :=  Null

    else

    begin

      RestProp := Copy(PropName, Dot + , 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 =  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, , Dot - ));

    RestProp := Copy(PropName, Dot + , 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: ..SizeOf(Integer) *  - ;

  S: string;

  Strings: TStrings;

  i: Integer;

begin

  Result := ;

  S := Trim(Value);

  if S = '' then Exit;

  if S[] = '[' then

    Delete(S, , );

  if S = '' then Exit;

  if S[Length(S)] = ']' then

    Delete(S, Length(S), );

  EnumInfo := GetTypeData(PInfo).CompType^;

  Strings := TStringList.Create;

  try

    Strings.CommaText := S;

    for i :=  to Strings.Count -  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 则返回 False

function 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 属性，如果没有返回 nil

function 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 := -;

  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 := -;

  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.