CnPack开发包基础库

时间:2021-10-12 09:08:43
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 = 'tom@email.com;jack@email.com;Bill@email.net'
Result = 'Tom(tom@email.com)' + #13#10 +
'Jack(jack@email.com)' + #13#10 +
'Bill(bill@email.net)
|</PRE>} //------------------------------------------------------------------------------
// 扩展的对话框函数
//------------------------------------------------------------------------------ procedure InfoDlg(Mess: string; Caption: string = ''; Flags: Integer
= MB_OK + MB_ICONINFORMATION);
{* 显示提示窗口} function InfoOk(Mess: string; Caption: string = ''): Boolean;
{* 显示提示确认窗口} procedure ErrorDlg(Mess: string; Caption: string = '');
{* 显示错误窗口} procedure WarningDlg(Mess: string; Caption: string = '');
{* 显示警告窗口} function QueryDlg(Mess: string; DefaultNo: Boolean = False;
Caption: string = ''): Boolean;
{* 显示查询是否窗口} const
csDefComboBoxSection = 'History'; function CnInputQuery(const ACaption, APrompt: string;
var Value: string; Ini: TCustomIniFile = nil;
const Section: string = csDefComboBoxSection): Boolean;
{* 输入对话框} function CnInputBox(const ACaption, APrompt, ADefault: string;
Ini: TCustomIniFile = nil; const Section: string = csDefComboBoxSection): string;
{* 输入对话框} //------------------------------------------------------------------------------
// 扩展日期时间操作函数
//------------------------------------------------------------------------------ function GetYear(Date: TDate): Integer;
{* 取日期年份分量}
function GetMonth(Date: TDate): Integer;
{* 取日期月份分量}
function GetDay(Date: TDate): Integer;
{* 取日期天数分量}
function GetHour(Time: TTime): Integer;
{* 取时间小时分量}
function GetMinute(Time: TTime): Integer;
{* 取时间分钟分量}
function GetSecond(Time: TTime): Integer;
{* 取时间秒分量}
function GetMSecond(Time: TTime): Integer;
{* 取时间毫秒分量} //------------------------------------------------------------------------------
// 位操作函数
//------------------------------------------------------------------------------
type
TByteBit = ..;
{* 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; // 扩展整数转字符串函数,参数分别为目标数、长度、填充字符(默认为0)
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.