From 868daf94f29ce1ffdd799a68c07bb668cd373bcd Mon Sep 17 00:00:00 2001
From: HP\李良庭 <liliangting@lanpucloud.cn:1111>
Date: 星期二, 08 七月 2025 11:49:03 +0800
Subject: [PATCH] 提交分辨率自适应版本V3.1.0.1500
---
src/pub/PubUtils.pas | 3854 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
1 files changed, 3,854 insertions(+), 0 deletions(-)
diff --git a/src/pub/PubUtils.pas b/src/pub/PubUtils.pas
new file mode 100644
index 0000000..bb3d949
--- /dev/null
+++ b/src/pub/PubUtils.pas
@@ -0,0 +1,3854 @@
+{------------------------------------------------------------------------------}
+{项目名称：公共项目 }
+{单元名称：PubUtils.pas }
+{版本版次：3.3 }
+{模块名称：全局公共函数库 }
+{功能描述：维护通用公共函数调用 }
+{建立日期：2011-01-01 }
+{修改修改：2025-02-12 }
+{版权所有：李良庭 }
+{------------------------------------------------------------------------------}
+
+//2011-10-26 新增ComboBox_XPMan_KeyPress函数,解决ComboBox控件输入乱码问题,
+// 在KeyPress事件中执行ComboBox_XPMan_KeyPress即可解决。
+//2015-12-01 新增Base16Encode、Base16Decode、Delay、GetVersionInfo等功能函数。
+//2015-12-24 新增Excel操作函数，使用ADO方式连接Excel文件读写。
+//2017-10-15 新增屏幕截图保存为png文件，传入文件路径，静默保存至本地，使用Tpngimage组件.
+//2018-04-01 新增根据程序名称获取句柄的方法，支持跨进程发送消息。
+//2018-10-20 为数采开发平台新增Dll调用函数。
+//2018-10-30 优化公共函数库，去掉部分重复函数。
+//2019-01-17 基于DateUtils库，扩充 DateTimeToUnix()函数，减8小时变成格林威治时间
+//2022-09-20 增加科学计数法和浮点型数字互转，输入输出均使用string类型。
+//2023-11-01 增加检查串口是否存在的函数。
+//2025-02-12 增加整形转为布尔值的函数。
+
+unit PubUtils;
+
+interface
+
+uses
+ Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, StdCtrls, Masks,
+ Math, ShellApi, ShlObj, ComObj, ActiveX, Registry, Dialogs, StrUtils, Printers,
+ Winsock, TLHelp32, PsAPI, DateUtils, Global;
+
+// 字符串相关
+function IsInt(const S: string): Boolean;
+function IsFloat(const S: string): Boolean;
+function IsEmail(const S: string): Boolean;
+function PathWithSlash(const Path: string): string;
+function PathWithoutSlash(const Path: string): string;
+function CombineFileName(const Path, FileName: string): string;
+function FileExtWithDot(const FileExt: string): string;
+function FileExtWithoutDot(const FileExt: string): string;
+function AddNumberComma(Number: Int64): string;
+function ExtractFileMainName(const FileName: string): string;
+function ExtractUrlFilePath(const Url: string): string;
+function ExtractUrlFileName(const Url: string): string;
+function ValidateFileName(const FileName: string): string;
+function GetSizeString(Bytes: Int64; const Postfix: string = ' KB'): string;
+function GetPercentString(Position, Max: Int64; const Postfix: string = ' %'): string;
+function RestrictStrWidth(const S: WideString; Canvas: TCanvas; Width: Integer; const Suffix: string = '...'): WideString;
+function RestrictFileNameWidth(const FileName: string; MaxBytes: Integer): string;
+function LikeString(Value, Pattern: WideString; CaseInsensitive: Boolean): Boolean;
+procedure SplitString(S: string; Delimiter: Char; List: TStrings);
+function StartWith(const Source: string; const Left: string): Boolean;
+function EndWith(const Source: string; const Right: string): Boolean;
+function MyPos(c: Char; const str: string): Integer;
+
+// 系统相关
+function GetComputerName: string;
+function GetWinUserName: string;
+function GetWindowsDir: string;
+function GetWinTempDir: string;
+function GetWinTempFile(const PrefixStr: string = ''): string;
+function GetFullFileName(const FileName: string): string;
+function GetShortFileName(const FileName: string): string;
+function GetLongFileName(const FileName: string): string;
+function GetSpecialFolder(FolderID: Integer): string;
+function GetQuickLaunchPath: string;
+function GetSystemDrivePath: string;
+function GetEnvVar(const EnvVar: string): string;
+function GetWorkAreaRect: TRect;
+function SelectDir(ParentHWnd: HWND; const Caption: string; const Root: WideString; var Path: string): Boolean;
+function ExecuteFile(const FileName, Params, DefaultDir: string; ShowCmd: Integer): HWND;
+function OpenURL(const URL: string): Boolean;
+function OpenEmail(const Email: string): Boolean;
+procedure SetStayOnTop(Form : TCustomForm; StayOnTop: Boolean);
+procedure HideAppFromTaskBar;
+function CheckLangChinesePR: Boolean;
+function ShutdownWindows: Boolean;
+function RebootWindows: Boolean;
+function GetMouseCursorPos: TPoint;
+function CreateShortCut(const OriginalFileName, ShortcutFileName, Arguments,
+ WorkingDir, Description: string; ShowCmd: Integer; IsFolderShortcut: Boolean): Boolean;
+
+// 文件相关
+function GetFileSize(const FileName: string): Int64;
+function GetFolderSize(FolderName: string): Int64;
+function GetFileDate(const FileName: string): TDateTime;
+function SetFileDate(const FileName: string; CreationTime, LastWriteTime, LastAccessTime: TFileTime): Boolean;
+function CopyFileToFolder(FileName, BackupFolder: string): Boolean;
+function AutoRenameFileName(const FullName: string): string;
+function GetTempFileAtPath(const Path: string; const PrefixStr: string = ''): string;
+function IsFileReadOnly(const FileName: string): Boolean;
+function DeleteFileToRecycle(const FileName: string): Boolean;
+procedure DeleteFileEx(FileName:string);
+function DeleteDirectory(const Dir: string): Boolean;
+function IsEmptyDir(sDir: String): Boolean;
+function ReadFile(const sFile:String):String; //读文本文件,liliangting 2016-01-18
+function ReadLogFile(const sFile:String):String; //读文本文件,liliangting 2016-01-18
+procedure WriteLogFile(const sFile,sMsg: string); //写文本文件,liliangting 2016-01-18
+
+// 注册表相关, 增加注册表读写函数
+function SetAutoRunOnStartup(AutoRun, CurrentUser: Boolean; AppTitle: string = ''; AppName: string = ''; AppPara: string = ''): Boolean;
+procedure AutoRun(Flag: Boolean; title:String);
+function ReadReg(const Name: String; CurrentUser: Boolean=true):String;
+function WriteReg(const Name,Value: String; CurrentUser: Boolean=true):Boolean;
+function AssociateFile(const FileExt, FileKey, SoftName, FileDesc: string; IconIndex: Integer = 0; Flush: Boolean = False): Boolean;
+function SaveAppPath(const CompanyName, SoftName, Version: string): Boolean;
+function ReadAppPath(const CompanyName, SoftName, Version: string; var Path: string): Boolean;
+
+// 日期时间相关
+function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
+function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
+function GetDatePart(DateTime: TDateTime): TDate;
+function GetTimePart(DateTime: TDateTime): TTime;
+
+//获取硬件信息模块
+function GetCPUIDStr:String; //获取CPUID并输出字符串
+function GetMacAddress: string; //获取网卡MAC地址
+function GetMemUse: Cardinal; //获取内存使用量
+
+// 其它函数
+procedure BeginWait;
+procedure EndWait;
+function Iif(Value: Boolean; Value1, Value2: Variant): Variant;
+function Min(V1, V2: Integer): Integer;
+function Max(V1, V2: Integer): Integer;
+function TrimValue(Value, Min, Max: Integer): Integer;
+procedure Swap(var V1, V2: Integer);
+function GetTickDiff(const OldTickCount, NewTickCount: Cardinal): Cardinal;
+function RestrictRectInScr(Rect: TRect; AllVisible: Boolean): TRect;
+function GetModulePath: string;
+function GetModuleSubPath(const SubFolder: string = ''): string;
+function GetAppPath: string;
+function GetAppSubPath(const SubFolder: string = ''): string;
+function GetRectWidth(const R: TRect): Integer;
+function GetRectHeight(const R: TRect): Integer;
+procedure DrawStrokedText(Canvas: TCanvas; X, Y: Integer; const Text: string;
+ FontColor, StrokedColor, SmoothColor: TColor);
+
+//系统Bug修正
+function GetScreenWidth:Integer; //获取屏幕宽度和高度，即分辨率
+function GetScreenHeight:Integer;
+function GetDesktopWidth:Integer; //获取桌面宽度和高度
+function GetDesktopHeight:Integer;
+function IsBigInt(const S:String): Boolean; //2012-04-12增加
+function IsNTSystem:Boolean; //判断是否NT系统
+procedure ComboBox_XPMan_KeyPress(Sender:TObject;var Key: Char);//修正下拉选择框输入乱码
+Function formatNum(Number, Length: Integer): string; //扩展并转换字符长度
+Function Q(s1:string):string; //加单引号
+procedure Delay(MSecs: Longint); //无刷新延时函数
+procedure PreparePrinter(Width,Height:Integer); //自定义纸张打印程序
+procedure DeleteMe;
+procedure SetSystemDateFormat(sFormat:string='yyyy-MM-dd'); //设置系统日期格式
+
+//其他函数，liliangting 2015-12-01
+function Base16Encode(const Src: AnsiString): AnsiString; //Base编码字符串
+function Base16Decode(const Src: AnsiString): AnsiString; //Base解码字符串
+function GetGUID:string; //自动生成一条GUID
+procedure Delay1(MSecs: Longint); //定时器1
+procedure Delay2(MSecs: Longint); //定时器2
+procedure GetVersionInfo(AppExeName:string);
+procedure EnumComPorts(Ports: TStrings); //枚举系统COM口
+function CheckComPort(ComPortName: string; var ComPortList: Tstrings): boolean;
+function StrToHexStr(const S:string):string; //字符串转16进制字符串
+function StrToHexStr1(const S:string):string;
+function HexStrToStr(const S:string; bFlag:boolean=false):string; //16进制字符串转ASCII(支持中英文)
+function GetMemBytes(var X; size: Integer): string; //以十六进制方式查看内存的函数
+procedure GetFileList(FilePath, ExtMask: string; FileList: TStrings; SubDir: Boolean = True);
+procedure GetFileListEx(FilePath, ExtMask: string; FileList: TStrings; SubDir: Boolean = True);
+function DeleteDir(Path: string;IsDelDir: Boolean = False): Boolean;
+
+//Excel函数，liliangting 2015-12-24
+function GetInstalledWordVersion: Integer; //获取Office版本
+function RandomNum:String; //生成18位随机数
+
+//TStringList自定义排序参数，liliangting 2017-9-1
+function SortParam(List: TStringList; Index1, Index2: Integer): Integer;
+function RoundEx(const Value: Extended; const Digit: Byte = 0): Extended;
+
+//带中文的String转byte
+function UniCode2GB(S: string): string;
+function GB2UniCode(GB: string): string;
+
+//重写BoolToStr函数，True-1，liliangting 2022-11-14
+function BoolToHexStr(B: Boolean; UseBoolStrs: Boolean = False): string;
+function BoolToString(B: Boolean; UseBoolStrs: Boolean = False): string;
+function BoolToString1(B: Boolean; UseBoolStrs: Boolean = False): string;
+function BoolToString2(B: Boolean; UseBoolStrs: Boolean = False): string;
+function BoolToString3(B: Boolean; UseBoolStrs: Boolean = False): string;
+function BoolToString4(B: Boolean; UseBoolStrs: Boolean = False): string;
+//Int-->boolean，0-False，其他-True，liliangting 2025-02-12
+function IntToBool(AValue: Integer): Boolean;
+
+//将日期格式转换成Unix时间戳 , 长度8字节，liliangting 2017-10-19
+function DateTimeToUnixDate(const ADate: TDateTime): Longint;
+//将数值转成KB、MB、GB
+function FormatFileSize(size:Int64):String;
+//将数值转成#.##万、#.##亿
+function FormatNumberSize(num:Int64):String;
+function SplitStr(str:string;chr:char;i:Integer):string;
+function SplitStrCount(str:string; chr:char):Integer;
+
+//windows杀进程的两种方法
+procedure KillProgram(WindowTitle: string);
+function KillTask(ExeFileName: string): integer;
+//刷新任务栏图标的两种方法
+procedure RefreshTaskbarIcon;
+procedure RefreshTaskbarIcon2;
+
+//强行关闭计算机系统的方法，liliangting 2018-1-4
+function GetOperatingSystem(): string;
+
+//跨进程传递消息的过程方法，liliangting 2018-04-01
+function GetHWndByPID(const hPID: THandle): THandle;
+function GetHwndByAppName(const AppName: String): THandle;
+
+//-----------------------------------------------------------------------------
+//数采开发平台专用方法
+//liliangting 2018-10-20
+//-----------------------------------------------------------------------------
+//封装的动态Dll函数调用方法
+function CallFunc(dllname,funcname:string; const param:array of const):DWORD; //通用Dll调用方法
+function PingHost(HostIP: String): Boolean; //ping测试网络
+function SecondToTime(sec:Integer):String; //秒转时间字符串
+function SecondToTime1(second: Word): TDateTime; //秒转时间
+
+//扩充DateUtils库，增加北京时间转Int64时间格式，注意减去时区
+function DateTimeToUnixPro(const AValue: TDateTime): Int64;
+function UnixToDateTimePro(const AValue: Int64): TDateTime;
+
+//科学计数与浮点型数互转，'-1.4857E-02' <--> '-0.014857'
+function ExpToFloat(s:String):String;
+function FloatToExp(s:String):String;
+
+//------ 几种插值算法 ---------------------------------------------------------
+function LinearInterpolation(x0, y0, x1, y1, x: Double): Double; //线性插值算法
+function LagrangeInterpolation(x, y: array of Double; n: Integer; xi: Double): Double; //拉格朗日插值算法
+function NewtonInterpolation(x, fx: array of Double; n: Integer; t: Double): Double; //牛顿插值算法
+function LeastSquaresInterpolation(x, y: array of Double; n: Integer; t: Double): Double;//最小二乘法插值算法
+function BayesianInterpolation(x,y: array of Double; xi: Double; sigma: Double): Double; //贝叶斯插值算法
+//-----------------------------------------------------------------------------
+
+function GetMillisecondTimeStamp: Int64;
+
+function SwapHighLowWord(Value: Word): Word;
+
+implementation
+
+{$WARN SYMBOL_PLATFORM OFF}
+{$WARN SYMBOL_DEPRECATED OFF}
+
+type
+ TCPUID = array[1..4] of Longint;//使用CPU内置指令获取CPU编号的二进制
+
+//-----------------------------------------------------------------------------
+// 描述: 判断字符串 S 是不是一个整型数字
+//-----------------------------------------------------------------------------
+function IsInt(const S: string): Boolean;
+var
+ E, R: Integer;
+begin
+ Val(S, R, E);
+ Result := E = 0;
+ E := R; // avoid hints
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断字符串 S 是不是一个浮点型数字
+//-----------------------------------------------------------------------------
+function IsFloat(const S: string): boolean;
+var
+ V: Extended;
+begin
+ Result := TextToFloat(PChar(S), V, fvExtended);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断字符串 S 是不是一个 Email 地址
+//-----------------------------------------------------------------------------
+function IsEmail(const S: string): Boolean;
+begin
+ Result := True;
+ if Pos('@', S) = 0 then Result := False;
+ if Pos('.', S) = 0 then Result := False;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 补全路径字符串后面的 "\"
+//-----------------------------------------------------------------------------
+function PathWithSlash(const Path: string): string;
+begin
+ Result := Trim(Path);
+ if Length(Result) > 0 then
+ Result := IncludeTrailingPathDelimiter(Result);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 去掉路径字符串后面的 "\"
+//-----------------------------------------------------------------------------
+function PathWithoutSlash(const Path: string): string;
+begin
+ Result := Trim(Path);
+ if Length(Result) > 0 then
+ Result := ExcludeTrailingPathDelimiter(Result);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 将路径和文件名组合在一起
+//-----------------------------------------------------------------------------
+function CombineFileName(const Path, FileName: string): string;
+begin
+ Result := PathWithSlash(Path) + FileName;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 补全文件扩展名前面的 "."
+//-----------------------------------------------------------------------------
+function FileExtWithDot(const FileExt: string): string;
+begin
+ Result := FileExt;
+ if Length(Result) > 0 then
+ if Copy(Result, 1, 1) <> '.' then
+ Result := '.' + Result;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 去掉文件扩展名前面的 "."
+//-----------------------------------------------------------------------------
+function FileExtWithoutDot(const FileExt: string): string;
+begin
+ Result := FileExt;
+ if Length(Result) > 0 then
+ if Copy(Result, 1, 1) = '.' then
+ Delete(Result, 1, 1);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 给数字加上分隔逗号
+// 示例: 1234567 -> 1,234,567
+//-----------------------------------------------------------------------------
+function AddNumberComma(Number: Int64): string;
+var
+ Temp: Double;
+begin
+ Temp := Number;
+ Result := Format('%.0n', [Temp]);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得文件名的主文件名
+// 示例: "C:\test.dat" -> "test"
+//-----------------------------------------------------------------------------
+function ExtractFileMainName(const FileName: string): string;
+var
+ Ext: string;
+begin
+ Ext := ExtractFileExt(FileName);
+ Result := ExtractFileName(FileName);
+ Result := Copy(Result, 1, Length(Result) - Length(Ext));
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 返回URL中的文件路径
+// 示例:
+// ExtractUrlFileName('http://www.download.com/file.zip');
+// 此调用将返回 'http://www.download.com/'.
+//-----------------------------------------------------------------------------
+function ExtractUrlFilePath(const Url: string): string;
+var
+ I: Integer;
+begin
+ I := LastDelimiter('/\:', Url);
+ Result := Copy(Url, 1, I);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 返回URL中的文件名
+// 示例:
+// ExtractUrlFileName('http://www.download.com/file.zip');
+// 此调用将返回 'file.zip'.
+//-----------------------------------------------------------------------------
+function ExtractUrlFileName(const Url: string): string;
+var
+ I: Integer;
+begin
+ I := LastDelimiter('/\:', Url);
+ Result := Copy(Url, I + 1, MaxInt);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 去掉文件名中不合法的字符
+// 示例: "tes*t.dat?" -> "test.dat"
+//-----------------------------------------------------------------------------
+function ValidateFileName(const FileName: string): string;
+var
+ I: Integer;
+begin
+ Result := '';
+ for I := 1 to Length(FileName) do
+ begin
+ if not (AnsiChar(FileName[I]) in ['\', '/', ':', '*', '?', '"', '<', '>', '|']) and
+ not (Ord(FileName[I]) < 32) then
+ Result := Result + FileName[I];
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得一个用来描述字节数的字符串
+// 参数:
+// Bytes - 字节数
+// Postfix - 单位后缀，缺省为 " KB"
+//-----------------------------------------------------------------------------
+function GetSizeString(Bytes: Int64; const Postfix: string): string;
+var
+ Temp: Double;
+begin
+ if Bytes > 0 then
+ begin
+ Temp := Bytes div 1024;
+ if Bytes mod 1024 <> 0 then Temp := Temp + 1;
+ end else
+ Temp := 0;
+ Result := Format('%s%s', [Format('%.0n', [Temp]), Postfix]);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得一个用来描述百分比的字符串
+// 参数:
+// Position, Max - 当前值 和 最大值
+// Postfix - 后缀字符串，缺省为 " %"
+//-----------------------------------------------------------------------------
+function GetPercentString(Position, Max: Int64; const Postfix: string): string;
+begin
+ if Max > 0 then
+ Result := IntToStr(Trunc((Position / Max) * 100)) + Postfix
+ else
+ Result := '100' + Postfix;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 缩短字符串的长度以适应显示宽度
+// 参数:
+// S - 待缩短的字符串.
+// Canvas - 字符串所在的Canvas.
+// Width - 最大象素宽度
+// Suffix - 如果字符串被截断，则添加什么后缀
+// 返回:
+// 缩短之后的字符串
+//-----------------------------------------------------------------------------
+function RestrictStrWidth(const S: WideString; Canvas: TCanvas;
+ Width: Integer; const Suffix: string): WideString;
+var
+ Src: WideString;
+begin
+ Src := S;
+ Result := S;
+ while (Canvas.TextWidth(Result) > Width) and (Length(Result) > 0) do
+ begin
+ if Length(Src) > 1 then
+ begin
+ Delete(Src, Length(Src), 1);
+ Result := Src + Suffix;
+ end else
+ Delete(Result, Length(Result), 1);
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 缩短文件名的长度以适应最大字节数限制
+// 参数:
+// FileName - 待缩短的文件名(可以包含路径)
+// MaxBytes - 最大字节数
+// 返回:
+// 缩短之后的文件名字符串
+//-----------------------------------------------------------------------------
+function RestrictFileNameWidth(const FileName: string;
+ MaxBytes: Integer): string;
+
+ function GetBytes(const S: WideString): Integer;
+ var
+ AnsiStr: string;
+ begin
+ AnsiStr := S;
+ Result := Length(AnsiStr);
+ end;
+
+var
+ MainName, NewMainName: WideString;
+ Ext: string;
+ ExtLen: Integer;
+begin
+ if Length(FileName) <= MaxBytes then
+ begin
+ Result := FileName;
+ end else
+ begin
+ Ext := ExtractFileExt(FileName);
+ MainName := Copy(FileName, 1, Length(FileName) - Length(Ext));
+ ExtLen := Length(Ext);
+
+ NewMainName := MainName;
+ while (GetBytes(NewMainName) + ExtLen > MaxBytes) and (Length(NewMainName) > 0) do
+ begin
+ if Length(MainName) > 1 then
+ begin
+ Delete(MainName, Length(MainName), 1);
+ NewMainName := MainName + '...';
+ end else
+ Delete(NewMainName, Length(NewMainName), 1);
+ end;
+
+ Result := NewMainName + Ext;
+ if Length(Result) > MaxBytes then
+ Result := Copy(Result, 1, MaxBytes);
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述：计算通配符表达式，支持通配符'*' 和 '?'
+// 参数：
+// Value - 母串
+// Pattern - 子串
+// CaseInsensitive - 是否忽略大小写
+// 返回：
+// True - 匹配
+// False - 不匹配
+// 示例：
+// LikeString('abcdefg', 'abc*', True);
+//-----------------------------------------------------------------------------
+function LikeString(Value, Pattern: WideString; CaseInsensitive: Boolean): Boolean;
+const
+ MultiWildChar = '*';
+ SingleWildChar = '?';
+var
+ ValuePtr, PatternPtr: PWideChar;
+ I: Integer;
+ B: Boolean;
+begin
+ ValuePtr := PWideChar(Value);
+ PatternPtr := PWideChar(Pattern);
+
+ while True do
+ begin
+ if (CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT,
+ PatternPtr, Length(PatternPtr), WideChar(MultiWildChar), 1) - 2 = 0) then
+ begin
+ Result := True;
+ Exit;
+ end
+ else if (ValuePtr^ = #0) and (PatternPtr^ <> #0) then
+ begin
+ Result := False;
+ Exit;
+ end
+ else if (ValuePtr^ = #0) then
+ begin
+ Result := True;
+ Exit;
+ end else
+ begin
+ case PatternPtr^ of
+ MultiWildChar:
+ begin
+ for I := 0 to Length(ValuePtr) - 1 do
+ begin
+ if LikeString(ValuePtr + I, PatternPtr + 1, CaseInsensitive) then
+ begin
+ Result := True;
+ Exit;
+ end;
+ end;
+ Result := False;
+ Exit;
+ end;
+ SingleWildChar:
+ begin
+ Inc(ValuePtr);
+ Inc(PatternPtr);
+ end;
+ else
+ begin
+ B := False;
+ if CaseInsensitive then
+ begin
+ if (CompareStringW(LOCALE_USER_DEFAULT, NORM_IGNORECASE + SORT_STRINGSORT,
+ PatternPtr, 1, ValuePtr, 1) - 2 = 0) then
+ B := True;
+ end else
+ begin
+ if (CompareStringW(LOCALE_USER_DEFAULT, SORT_STRINGSORT,
+ PatternPtr, 1, ValuePtr, 1) - 2 = 0) then
+ B := True;
+ end;
+
+ if B then
+ begin
+ Inc(ValuePtr);
+ Inc(PatternPtr);
+ end else
+ begin
+ Result := False;
+ Exit;
+ end;
+ end;
+ end; // case
+ end;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 分割字符串
+//-----------------------------------------------------------------------------
+procedure SplitString(S: string; Delimiter: Char; List: TStrings);
+var
+ I: Integer;
+begin
+ List.Clear;
+ while Length(S) > 0 do
+ begin
+ I := Pos(Delimiter, S);
+ if I > 0 then
+ begin
+ List.Add(Copy(S, 1, I - 1));
+ Delete(S, 1, I);
+ end else
+ begin
+ List.Add(S);
+ Break;
+ end;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断字符串 Source 是不是以 Left 开始
+//-----------------------------------------------------------------------------
+function StartWith(const Source: string; const Left: string): Boolean;
+var
+ Start: string;
+ Len: Integer;
+begin
+ Len := Length(Left);
+ if (Source = '') or (Left = '') or (Length(Source) < Len) then
+ begin
+ Result := False;
+ end else
+ begin
+ Start := Copy(Source, 1, Len);
+ Result := Start = Left;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断字符串 Source 是不是以 Right 结束
+//-----------------------------------------------------------------------------
+function EndWith(const Source: string; const Right: string): Boolean;
+var
+ EndStr: string;
+ RightLen: Integer;
+ SourceLen: Integer;
+begin
+ RightLen := Length(Right);
+ SourceLen := Length(Source);
+
+ if (Source = '') or (Right = '') or (SourceLen < RightLen) then
+ begin
+ Result := False;
+ end else
+ begin
+ EndStr := Copy(Source, SourceLen - RightLen + 1, RightLen);
+ Result := EndStr = Right;
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 描述：Pos 函数，返回查找字符出现次数
+//------------------------------------------------------------------------------
+function MyPos(c: Char; const str: string): Integer;
+var
+ i,j: Integer;
+begin
+ j := 0;
+ for i := 1 to Length(str) do
+ if c = str[i] then inc(j);
+ Result:=j;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得计算机名
+//-----------------------------------------------------------------------------
+function GetComputerName: string;
+const
+ MaxSize = 256;
+var
+ Buffer: array[0..MaxSize-1] of Char;
+ Size: Cardinal;
+begin
+ Size := MaxSize;
+ Windows.GetComputerName(PChar(@Buffer[0]), Size);
+ Result := Buffer;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得当前系统用户名
+//-----------------------------------------------------------------------------
+function GetWinUserName: string;
+const
+ Size = 255;
+var
+ Buffer: array[0..Size] of Char;
+ Len: DWord;
+begin
+ Len := Size;
+ GetUserName(Buffer, Len);
+ Result := Buffer;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得 Windows 目录
+//-----------------------------------------------------------------------------
+function GetWindowsDir: string;
+var
+ Buffer: array[0..MAX_PATH] of Char;
+begin
+ GetWindowsDirectory(Buffer, MAX_PATH);
+ Result := PathWithSlash(Buffer);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得系统临时文件目录
+//-----------------------------------------------------------------------------
+function GetWinTempDir: string;
+const
+ Size = 1024;
+var
+ Buffer: array[0..Size] of Char;
+ LongName: string;
+begin
+ GetTempPath(Size, Buffer);
+ Result := PathWithSlash(Buffer);
+ LongName := GetLongFileName(Result);
+ if Length(LongName) >= Length(Result) then
+ Result := LongName;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得一个临时文件名(路径为系统临时目录)
+// 参数:
+// PrefixStr - 文件名前缀，前三个字符有效
+//-----------------------------------------------------------------------------
+function GetWinTempFile(const PrefixStr: string): string;
+var
+ FileName: array[0..MAX_PATH] of Char;
+ LongName: string;
+begin
+ Windows.GetTempFileName(PChar(GetWinTempDir), PChar(PrefixStr), 0, FileName);
+ Result := FileName;
+ LongName := GetLongFileName(Result);
+ if Length(LongName) >= Length(Result) then
+ Result := LongName;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 文件的全名(包含路径)
+// 示例:
+// "test.dat" -> "C:\test.dat"
+// "C:\a\..\test.dat" -> "C:\test.dat"
+//-----------------------------------------------------------------------------
+function GetFullFileName(const FileName: string): string;
+const
+ Size = 1024;
+var
+ Buffer: array[0..Size] of Char;
+ FileNamePtr: PChar;
+ Len: DWord;
+begin
+ Len := Size;
+ GetFullPathName(PChar(FileName), Len, Buffer, FileNamePtr);
+ Result := Buffer;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 长文件名 -> 短文件名(8.3)
+// 备注: FileName 可以是路径，也可以是文件名。
+// 示例:
+// "C:\Program Files" -> "C:\PROGRA~1"
+//-----------------------------------------------------------------------------
+function GetShortFileName(const FileName: string): string;
+const
+ Size = 1024;
+var
+ Buffer: array[0..Size] of Char;
+begin
+ GetShortPathName(PChar(FileName), Buffer, Size);
+ Result := Buffer;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 短文件名(8.3) -> 长文件名
+// 备注: FileName 可以是路径，也可以是文件名。
+// 示例:
+// "C:\PROGRA~1\COMMON~1\" -> "C:\Program Files\Common Files\"
+//-----------------------------------------------------------------------------
+function GetLongFileName(const FileName: string): string;
+var
+ Name, S: string;
+ SearchRec : TSearchRec;
+begin
+ S := ExcludeTrailingPathDelimiter(FileName);
+ if (Length(S) < 3) or (ExtractFilePath(S) = S) then
+ begin
+ Result := FileName;
+ Exit;
+ end;
+
+ if FindFirst(S, faAnyFile, SearchRec) = 0 then
+ Name := SearchRec.Name
+ else
+ Name := ExtractFileName(S);
+ FindClose(SearchRec);
+
+ Result := GetLongFileName(ExtractFilePath(S)) + Name;
+ if Length(S) <> Length(FileName) then Result := Result + '\';
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得特殊文件夹路径
+// 参数:
+// FolderID -
+// CSIDL_DESKTOP
+// CSIDL_PROGRAMS
+// CSIDL_RECENT
+// CSIDL_SENDTO
+// CSIDL_STARTMENU
+// CSIDL_STARTUP
+// CSIDL_TEMPLATES
+// CSIDL_APPDATA
+// 返回:
+// 若成功，返回带最后斜线(\)的路径；
+// 若失败，返回空字符串。
+// 备注:
+// 若要取"快速启动"的路径，可:
+// GetSpecialFolder(CSIDL_APPDATA) + 'Microsoft\Internet Explorer\Quick Launch\'.
+//-----------------------------------------------------------------------------
+function GetSpecialFolder(FolderID: Integer): string;
+var
+ PidL: PItemIDList;
+ Buffer: array[0..MAX_PATH] of Char;
+ Malloc: IMalloc;
+begin
+ Result := '';
+ if Failed(SHGetMalloc(Malloc)) then
+ Malloc := nil;
+ if Succeeded(SHGetSpecialFolderLocation(0, FolderID, PidL)) then
+ begin
+ if SHGetPathFromIDList(PidL, Buffer) then
+ Result := Buffer;
+ if Assigned(Malloc) then
+ Malloc.Free(PidL);
+ Result := PathWithSlash(Result);
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得 "快速启动" 的路径
+//-----------------------------------------------------------------------------
+function GetQuickLaunchPath: string;
+begin
+ Result := GetSpecialFolder(CSIDL_APPDATA) +
+ 'Microsoft\Internet Explorer\Quick Launch\';
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得 SystemDrive 的路径
+//-----------------------------------------------------------------------------
+function GetSystemDrivePath: string;
+begin
+ if Win32Platform = VER_PLATFORM_WIN32_NT then
+ Result := GetEnvVar('SystemDrive') {don't localize}
+ else
+ Result := '';
+
+ if Result = '' then
+ begin
+ Result := ExtractFileDrive(GetWindowsDir);
+ if Result = '' then
+ Result := 'C:';
+ end;
+
+ Result := PathWithSlash(Result);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得环境变量的值
+//-----------------------------------------------------------------------------
+function GetEnvVar(const EnvVar: string): string;
+
+ function AdjustLength(var S: string; const R: Cardinal): Boolean;
+ begin
+ Result := Integer(R) < Length(S);
+ SetLength(S, R);
+ end;
+
+const
+ MaxSize = 255;
+var
+ R: DWORD;
+begin
+ SetLength(Result, MaxSize);
+ repeat
+ R := GetEnvironmentVariable(PChar(EnvVar), PChar(Result), Length(Result));
+ if R = 0 then
+ begin
+ Result := '';
+ Break;
+ end;
+ until AdjustLength(Result, R);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得桌面上除任务栏以外的区域
+//-----------------------------------------------------------------------------
+function GetWorkAreaRect: TRect;
+begin
+ SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 浏览文件夹，可定位文件夹
+// 参数:
+// ParentHWnd - 父窗口的句柄
+// Caption - 浏览对话框的提示标题
+// Root - 根目录
+// Path - 存放用户最终选择的目录
+// 返回:
+// True - 用户点了确定
+// False - 用户点了取消
+//-----------------------------------------------------------------------------
+function SelectDir(ParentHWnd: HWND; const Caption: string;
+ const Root: WideString; var Path: string): Boolean;
+const
+{$WRITEABLECONST ON}
+ InitPath: string = '';
+{$WRITEABLECONST OFF}
+var
+ WindowList: Pointer;
+ BrowseInfo: TBrowseInfo;
+ Buffer: PChar;
+ RootItemIDList, ItemIDList: PItemIDList;
+ ShellMalloc: IMalloc;
+ IDesktopFolder: IShellFolder;
+ Eaten, Flags: LongWord;
+
+ function BrowseCallbackProc(hwnd: HWND; uMsg: UINT; lParam: Cardinal; lpData: Cardinal):Integer; stdcall;
+ var
+ R: TRect;
+ begin
+ if uMsg = BFFM_INITIALIZED then
+ begin
+ GetWindowRect(hwnd, R);
+ MoveWindow(hwnd,
+ (Screen.Width - (R.Right - R.Left)) div 2,
+ (Screen.Height - (R.Bottom - R.Top)) div 2,
+ R.Right - R.Left,
+ R.Bottom - R.Top,
+ True);
+ Result := SendMessage(hwnd, BFFM_SETSELECTION, Ord(TRUE), Longint(PChar(InitPath)))
+ end else
+ Result := 1;
+ end;
+
+begin
+ Result := False;
+ InitPath := Path;
+ FillChar(BrowseInfo, SizeOf(BrowseInfo), 0);
+ if (ShGetMalloc(ShellMalloc) = S_OK) and (ShellMalloc <> nil) then
+ begin
+ Buffer := ShellMalloc.Alloc(MAX_PATH);
+ try
+ RootItemIDList := nil;
+ if Root <> '' then
+ begin
+ SHGetDesktopFolder(IDesktopFolder);
+ IDesktopFolder.ParseDisplayName(Application.Handle, nil,
+ POleStr(Root), Eaten, RootItemIDList, Flags);
+ end;
+ with BrowseInfo do
+ begin
+ hwndOwner := ParentHWnd;
+ pidlRoot := RootItemIDList;
+ pszDisplayName := Buffer;
+ lpszTitle := PChar(Caption);
+ ulFlags := BIF_RETURNONLYFSDIRS;
+ lpfn :=@BrowseCallbackProc;
+ lParam :=BFFM_INITIALIZED;
+ end;
+ WindowList := DisableTaskWindows(0);
+ try
+ ItemIDList := ShBrowseForFolder(BrowseInfo);
+ finally
+ EnableTaskWindows(WindowList);
+ end;
+ Result := ItemIDList <> nil;
+ if Result then
+ begin
+ ShGetPathFromIDList(ItemIDList, Buffer);
+ ShellMalloc.Free(ItemIDList);
+ Path := Buffer;
+ end;
+ finally
+ ShellMalloc.Free(Buffer);
+ end;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 用系统 Shell 调用来打开一个文件
+//-----------------------------------------------------------------------------
+function ExecuteFile(const FileName, Params, DefaultDir: string; ShowCmd: Integer): HWND;
+begin
+ Result := ShellExecute(Application.Handle, nil,
+ PChar(FileName), PChar(Params), PChar(DefaultDir), ShowCmd);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 打开一个 URL
+// 示例:
+// OpenURL('http://www.abc.com');
+// OpenURL('www.abc.com');
+// OpenURL('file:///c:\');
+//-----------------------------------------------------------------------------
+function OpenURL(const URL: string): Boolean;
+begin
+ Result := ShellExecute(Application.Handle, 'Open', PChar(Trim(URL)), '', '', SW_SHOW) > 32;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 打开一个 Email 发送客户端
+//-----------------------------------------------------------------------------
+function OpenEmail(const Email: string): Boolean;
+const
+ SPrefix = 'mailto:';
+var
+ S: string;
+begin
+ S := Trim(Email);
+ if Pos(SPrefix, S) <> 1 then S := SPrefix + S;
+
+ Result := OpenURL(S);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 让窗口保持在最上层
+//-----------------------------------------------------------------------------
+procedure SetStayOnTop(Form : TCustomForm; StayOnTop: Boolean);
+begin
+ if StayOnTop Then
+ SetWindowPos(Form.Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)
+ else
+ SetWindowPos(Form.Handle, HWND_NOTOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 隐藏应用程序在任务栏上的选择按钮
+//-----------------------------------------------------------------------------
+procedure HideAppFromTaskBar;
+var
+ ExtendedStyle : Integer;
+begin
+ ExtendedStyle := GetWindowLong(Application.Handle, GWL_EXSTYLE);
+ SetWindowLong(Application.Handle, GWL_EXSTYLE,
+ (ExtendedStyle or WS_EX_TOOLWINDOW) and not WS_EX_APPWINDOW);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 检查当前系统语言是否简体中文
+//-----------------------------------------------------------------------------
+function CheckLangChinesePR: Boolean;
+const
+ // LCID Consts
+ LangChinesePR = (SUBLANG_CHINESE_SIMPLIFIED shl 10) or LANG_CHINESE;
+begin
+ Result := SysLocale.DefaultLCID = LangChinesePR;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 关机
+//-----------------------------------------------------------------------------
+function ShutdownWindows: Boolean;
+const
+ SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
+var
+ hToken: THandle;
+ tkp: TTokenPrivileges;
+ tkpo: TTokenPrivileges;
+ Zero: DWORD;
+begin
+ Result := True;
+ if Win32Platform = VER_PLATFORM_WIN32_NT then
+ begin
+ Zero := 0;
+ if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ if not LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, tkp.Privileges[0].Luid) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ tkp.PrivilegeCount := 1;
+ tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, False, tkp, SizeOf(TTokenPrivileges), tkpo, Zero);
+ if Boolean(GetLastError()) then
+ begin
+ Result := False;
+ Exit;
+ end else
+ ExitWindowsEx(EWX_SHUTDOWN or EWX_POWEROFF, 0);
+ end else
+ ExitWindowsEx(EWX_SHUTDOWN or EWX_POWEROFF, 0);
+end;
+
+//------------------------------------------------------------------------------
+// 描述：重启
+//------------------------------------------------------------------------------
+function RebootWindows: Boolean;
+const
+ SE_SHUTDOWN_NAME = 'SeShutdownPrivilege';
+var
+ hToken: THandle;
+ tkp: TTokenPrivileges;
+ tkpo: TTokenPrivileges;
+ Zero: DWORD;
+begin
+ Result := True;
+ if Win32Platform = VER_PLATFORM_WIN32_NT then
+ begin
+ Zero := 0;
+ if not OpenProcessToken(GetCurrentProcess(), TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ if not LookupPrivilegeValue(nil, SE_SHUTDOWN_NAME, tkp.Privileges[0].Luid) then
+ begin
+ Result := False;
+ Exit;
+ end;
+ tkp.PrivilegeCount := 1;
+ tkp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;
+
+ AdjustTokenPrivileges(hToken, False, tkp, SizeOf(TTokenPrivileges), tkpo, Zero);
+ if Boolean(GetLastError()) then
+ begin
+ Result := False;
+ Exit;
+ end else
+ ExitWindowsEx(EWX_SHUTDOWN or EWX_REBOOT, 0);
+ end else
+ ExitWindowsEx(EWX_SHUTDOWN or EWX_REBOOT, 0);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取鼠标的当前位置
+// 注意: Mouse.CursorPos 会在带密码保护的屏保启动时抛出异常。
+//-----------------------------------------------------------------------------
+function GetMouseCursorPos: TPoint;
+begin
+ if not Windows.GetCursorPos(Result) then
+ Result := Point(0, 0);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 创建快捷方式
+// 参数:
+// OriginalFileName - 原始文件名，含路径 (即快捷方式指向的文件)
+// ShortcutFileName - 快捷方式文件名，含路径，含扩展名(.lnk)
+// Arguments - 运行参数
+// WorkingDir - 工作目录
+// Description - 快捷方式描述
+// ShowCmd - 运行方式 (SW_SHOW, SW_MINIMIZE, SW_MAXIMIZE)
+// IsFolderShortcut - 是否文件夹快捷方式
+// 返回:
+// True - 成功
+// False - 失败
+//-----------------------------------------------------------------------------
+function CreateShortCut(const OriginalFileName, ShortcutFileName, Arguments,
+ WorkingDir, Description: string; ShowCmd: Integer;
+ IsFolderShortcut: Boolean): Boolean;
+
+ function IsWindowsXP: Boolean;
+ begin
+ Result := (Win32Platform >= VER_PLATFORM_WIN32_NT) and
+ (Win32MajorVersion >= 5) and (Win32MinorVersion >= 1);
+ end;
+
+const
+ CLSID_FolderShortcut: TGUID = (
+ D1:$0AFACED1; D2:$E828; D3:$11D1; D4:($91,$87,$B5,$32,$F1,$E9,$57,$5D));
+var
+ OleResult: HRESULT;
+ Obj: IUnknown;
+ SL: IShellLink;
+ PF: IPersistFile;
+ WideFileName: WideString;
+begin
+ if IsFolderShortcut then
+ begin
+ try
+ Obj := CreateComObject(CLSID_FolderShortcut);
+ except
+ { Folder shortcuts aren't supported prior to Windows 2000/Me.
+ Fall back to creating a normal shell link. }
+ Obj := nil;
+ end;
+ end;
+ if Obj = nil then
+ begin
+ IsFolderShortcut := False;
+ Obj := CreateComObject(CLSID_ShellLink);
+ end;
+ SL := Obj as IShellLink;
+ SL.SetPath(PChar(OriginalFileName));
+ SL.SetArguments(PChar(Arguments));
+ if WorkingDir <> '' then
+ SL.SetWorkingDirectory(PChar(WorkingDir));
+ SL.SetShowCmd(ShowCmd);
+ if Description <> '' then
+ SL.SetDescription(PChar(Description));
+
+ PF := SL as IPersistFile;
+ { When creating a folder shortcut on 2000/Me, IPersistFile::Save will strip
+ off everything past the last '.' in the ShortcutFileName, so we keep the .lnk
+ extension on to give it something harmless to strip off. XP doesn't do
+ that, so we must remove the .lnk extension ourself. }
+ if IsFolderShortcut and IsWindowsXP then
+ WideFileName := ChangeFileExt(ShortcutFileName, '')
+ else
+ WideFileName := ShortcutFileName;
+ OleResult := PF.Save(PWideChar(WideFileName), True);
+ Result := OleResult = S_OK;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得文件大小
+//-----------------------------------------------------------------------------
+function GetFileSize(const FileName: string): Int64;
+var
+ Handle: THandle;
+ FindData: TWin32FindData;
+begin
+ Result := -1;
+ Handle := FindFirstFile(PChar(FileName), FindData);
+ if Handle <> INVALID_HANDLE_VALUE then
+ begin
+ Windows.FindClose(Handle);
+ if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
+ begin
+ Int64Rec(Result).Lo := FindData.nFileSizeLow;
+ Int64Rec(Result).Hi := FindData.nFileSizeHigh;
+ end;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得文件夹大小
+//-----------------------------------------------------------------------------
+function GetFolderSize(FolderName: string): Int64;
+var
+ sr: TSearchRec;
+begin
+ Result := 0;
+ if RightStr(FolderName, 1) <> '\' then FolderName := FolderName + '\';
+ if FindFirst(FolderName + '*.* ', faAnyFile, sr) = 0 then
+ repeat
+ if (sr.Name <> '.') and (sr.Name <> '..') then begin
+ Result := Result + GetFileSize(FolderName + sr.Name);
+ if (sr.Attr and faDirectory) <> 0 then
+ Result := Result + GetFolderSize(FolderName + sr.Name + '\');
+ end;
+ until FindNext(sr) <> 0;
+ FindClose(sr);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得文件的修改时间
+//-----------------------------------------------------------------------------
+function GetFileDate(const FileName: string): TDateTime;
+var
+ FileDate: Integer;
+begin
+ FileDate := FileAge(FileName);
+ if FileDate = -1 then
+ Result := 0
+ else
+ Result := FileDateToDateTime(FileDate);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 设置文件的时间
+//-----------------------------------------------------------------------------
+function SetFileDate(const FileName: string;
+ CreationTime, LastWriteTime, LastAccessTime: TFileTime): Boolean;
+var
+ FileHandle : Integer;
+begin
+ FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
+ try
+ if FileHandle <> Integer(INVALID_HANDLE_VALUE) then
+ begin
+ SetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime);
+ Result := True;
+ end else
+ Result := False;
+ finally
+ FileClose(FileHandle);
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 复制文件到一个文件夹
+//-----------------------------------------------------------------------------
+function CopyFileToFolder(FileName, BackupFolder: string): Boolean;
+var
+ MainFileName: string;
+begin
+ BackupFolder := PathWithSlash(BackupFolder);
+ MainFileName := ExtractFileName(FileName);
+ ForceDirectories(BackupFolder);
+ Result := CopyFile(PChar(FileName), PChar(BackupFolder + MainFileName), False);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 自动调整文件名，防止文件名重复
+// 参数:
+// FullName - 文件的全路径名
+// 示例：
+// NewName := AutoRenameFileName('C:\Downloads\test.dat');
+// 如果 "C:\Downloads\" 下已经存在test.dat，则函数返回 "C:\Downloads\test(1).dat".
+//-----------------------------------------------------------------------------
+function AutoRenameFileName(const FullName: string): string;
+const
+ SLeftSym = '(';
+ SRightSym = ')';
+
+ // 若S='test(1)'，则返回'(1)'； 若S='test(a)'，则返回''。
+ function GetNumberSection(const S: string): string;
+ var
+ I: Integer;
+ begin
+ Result := '';
+ if Length(S) < 3 then Exit;
+ if S[Length(S)] = SRightSym then
+ begin
+ for I := Length(S) - 2 downto 1 do
+ if S[I] = SLeftSym then
+ begin
+ Result := Copy(S, I, MaxInt);
+ Break;
+ end;
+ end;
+ if Length(Result) > 0 then
+ begin
+ if not IsInt(Copy(Result, 2, Length(Result)-2)) then
+ Result := '';
+ end;
+ end;
+
+var
+ Number: Integer;
+ Name, Ext, NumSec: string;
+begin
+ Ext := ExtractFileExt(FullName);
+ Result := FullName;
+ while FileExists(Result) do
+ begin
+ Name := Copy(Result, 1, Length(Result) - Length(Ext));
+ NumSec := GetNumberSection(Name);
+ if Length(NumSec) = 0 then
+ begin
+ Result := Name + SLeftSym + '1' + SRightSym + Ext;
+ end else
+ begin
+ Number := StrToInt(Copy(NumSec, 2, Length(NumSec)-2));
+ Inc(Number);
+ Result := Copy(Name, 1, Length(Name) - Length(NumSec)) +
+ SLeftSym + IntToStr(Number) + SRightSym + Ext;
+ end;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得一个临时文件名
+// 参数:
+// Path - 临时文件所在路径
+// PrefixStr - 文件名前缀，前三个字符有效
+//-----------------------------------------------------------------------------
+function GetTempFileAtPath(const Path: string; const PrefixStr: string): string;
+var
+ I: Integer;
+begin
+ I := 1;
+ while True do
+ begin
+ Result := PathWithSlash(Path) + Copy(PrefixStr, 1, 3) + IntToStr(I) + '.tmp';
+ if FileExists(Result) then
+ Inc(I)
+ else
+ Break;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断文件是否具有只读属性
+//-----------------------------------------------------------------------------
+function IsFileReadOnly(const FileName: string): Boolean;
+begin
+ Result := (GetFileAttributes(PChar(FileName)) and FILE_ATTRIBUTE_READONLY) <> 0;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 删除文件到回收站
+//-----------------------------------------------------------------------------
+function DeleteFileToRecycle(const FileName: string): Boolean;
+var
+ OpStruct: TSHFileOpStruct;
+begin
+ FillChar(OpStruct, SizeOf(OpStruct), 0);
+ with OpStruct do
+ begin
+ Wnd := 0;
+ wFunc := FO_DELETE;
+ pFrom := PChar(FileName);
+ fFlags := FOF_ALLOWUNDO or FOF_NOCONFIRMATION or FOF_SILENT;
+ end;
+ Result := SHFileOperation(OpStruct) = 0;
+end;
+
+//------------------------------------------------------------------------------
+// 描述：模糊匹配删除文件
+//------------------------------------------------------------------------------
+procedure DeleteFileEx(FileName:string);
+var
+ FileDir:string;
+ FileStruct:TSHFileOpStruct;
+begin
+ FileDir := FileName;// 'C:\temp\*.txt';
+ FileStruct.Wnd :=0;
+ FileStruct.wFunc := FO_delete;
+ FileStruct.pFrom := Pchar(FileDir+#0);
+ FileStruct.fFlags:= FOF_NOCONFIRMATION;
+ FileStruct.pTo := ' ';
+ if SHFileOperation(FileStruct)=0 then
+ MessageBox(0,'注意: 综合测试台仪器测量数据已经清空!','提示',MB_OK+MB_ICONINFORMATION);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 删除空或非空目录
+//-----------------------------------------------------------------------------
+function DeleteDirectory(const Dir: string): Boolean;
+var
+ FileOp: TSHFileOpStruct;
+begin
+ FillChar(FileOp, SizeOf(FileOp), 0);
+ with FileOp do
+ begin
+ Wnd := 0;
+ wFunc := FO_DELETE;
+ pFrom := PChar(Dir + #0);
+ pTo := #0#0;
+ fFlags := FOF_NOCONFIRMATION + FOF_SILENT;
+ end;
+ Result := (SHFileOperation(FileOp) = 0);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断目录是否为空
+//-----------------------------------------------------------------------------
+function IsEmptyDir(sDir: String): Boolean;
+var
+ sr: TsearchRec;
+begin
+ Result := True;
+ if Copy(sDir, Length(sDir) - 1, 1) <> '\' then sDir := sDir + '\';
+ if FindFirst(sDir + '*.*', faAnyFile, sr) = 0 then
+ repeat
+ if (sr.Name <> '.') and (sr.Name <> '..') then
+ begin
+ Result := False;
+ break;
+ end;
+ until FindNext(sr) <> 0;
+ FindClose(sr);
+end;
+
+//------------------------------------------------------------------------------
+// 读取文本文件的一种方法
+//------------------------------------------------------------------------------
+function ReadFile(const sFile:String):String;
+var
+ sList: TStringlist;
+begin
+ sList := TStringList.Create;
+ try
+ if FileExists(sFile) then begin
+ sList.LoadFromFile(sFile);
+ Result := sList.GetText;
+ end;
+ finally
+ sList.Free;
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 读取文件：
+//1，关联文件：AssignFile(pMyFile,'c:\ttt.csv');
+//2，打开文件：Reset(pMyFile);
+//3，读取一行：Readln(pMyFile,pStr);
+//4，关闭文件：CloseFile(pMyFile);
+//------------------------------------------------------------------------------
+function ReadLogFile(const sFile:String):String;
+var
+ pMyFile:textfile;
+ pStr : string;
+begin
+ try
+ Assignfile(pMyFile,sFile);
+ if FileExists(sFile) then begin
+ Reset(pMyFile);
+ while not Eof(pMyFile) do begin
+ Readln(pMyFile,pStr);
+ //next;
+ end;
+ end;
+ finally
+ CloseFile(pMyFile);
+ end;
+ Result := pStr;
+end;
+
+//------------------------------------------------------------------------------
+// 写入文件：
+//1，关联文件：AssignFile(pMyFile,'c:\ttt.csv');
+//2，打开文件：ReWrite(pMyFile); //如果文件不存在,用ReWrite打开
+// Append(pMyFile); //如果文件已经存在,追加内容，用Append打开
+//3，写入一行：WriteLn(pMyFile,pStr);
+//4，关闭文件：CloseFile(pMyFile);
+//------------------------------------------------------------------------------
+procedure WriteLogFile(const sFile,sMsg: string);
+var
+ pMyFile: textFile;
+begin
+ try
+ AssignFile(pMyFile,sFile);
+ if FileExists(sFile) then
+ Append(pMyFile)
+ else
+ ReWrite(pMyFile);
+ WriteLn(pMyFile,sMsg);
+ finally
+ CloseFile(pMyFile);
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 设置自启动
+// 参数:
+// AutoRun - 是否自启动
+// CurrentUser - 是否只对当前用户有效
+// AppTitle - 应用程序的标题，如 "MSN"
+// AppPara - 自启动的命令行参数，如 "/min"
+//-----------------------------------------------------------------------------
+function SetAutoRunOnStartup(AutoRun, CurrentUser: Boolean;
+ AppTitle, AppName, AppPara: string): Boolean;
+var
+ R: TRegistry;
+ Key : string;
+begin
+ Result := True;
+ try
+ R := TRegistry.Create;
+ try
+ if CurrentUser then
+ R.RootKey := HKEY_CURRENT_USER
+ else
+ R.RootKey := HKEY_LOCAL_MACHINE;
+ Key := '\Software\Microsoft\Windows\CurrentVersion\Run\';
+
+ if AppTitle = '' then AppTitle := Application.Title;
+ if AppName = '' then AppName := Application.ExeName;
+ if AppPara <> '' then AppName := AppName + ' ' + AppPara;
+
+ if R.OpenKey(Key, True) then
+ begin
+ if AutoRun then
+ R.WriteString(AppTitle, AppName)
+ else
+ R.DeleteValue(AppTitle);
+ end;
+ finally
+ R.Free;
+ end;
+ except
+ Result := False;
+ end;
+end;
+
+{开机运行。}
+procedure AutoRun(Flag: Boolean; title:String);
+var
+ tempreg: TRegistry;
+begin
+ tempreg := TRegistry.Create;
+ try
+ tempreg.RootKey := HKEY_CURRENT_USER;
+ tempreg.OpenKey('SOFTWARE\Microsoft\Windows\CurrentVersion\Run', True);
+ if Flag then
+ tempreg.WriteString(title, '"' + ParamStr(0) + '"')
+ else begin
+ tempreg.DeleteValue(title);
+ end;
+ finally
+ tempreg.Closekey;
+ tempreg.Free;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 读注册表指定键
+// 参数:
+// CurrentUser - 是否只对当前用户有效
+// Name - 应用程序的标题，如 "MSN"
+// 返回：Value - 返回Name对应值
+//-----------------------------------------------------------------------------
+function ReadReg(const Name: String; CurrentUser: Boolean=true):String;
+var
+ R: TRegistry;
+ Key : String;
+begin
+ Result := '';
+ R := TRegistry.Create;
+ try
+ if CurrentUser then
+ R.RootKey := HKEY_CURRENT_USER
+ else
+ R.RootKey := HKEY_LOCAL_MACHINE;
+ Key := '\Software\liliangting\';
+
+ if R.OpenKey(Key,True) then
+ Result := R.ReadString(Name);
+ finally
+ R.Free;
+ end;
+end;
+
+//写注册表指定值
+function WriteReg(const Name,Value: String; CurrentUser: Boolean=true):Boolean;
+var
+ R: TRegistry;
+ Key : String;
+begin
+ Result := false;
+ R := TRegistry.Create;
+ try
+ if CurrentUser then
+ R.RootKey := HKEY_CURRENT_USER
+ else
+ R.RootKey := HKEY_LOCAL_MACHINE;
+ Key := '\Software\liliangting\';
+
+ if R.OpenKey(Key,True) then begin
+ R.WriteString(Name, Value);
+ Result := true;
+ end;
+ finally
+ R.Free;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 文件关联
+// 参数:
+// FileExt - 文件扩展名
+// FileKey - 该文件类型的英文符号
+// SoftName - 软件的名字 (用于显示在资源管理器的右键菜单上)
+// FileDesc - 文件类型的描述
+// IconIndex - 图标序号(0-based)
+// Flush - 是否刷新Windows缓冲
+// 示例:
+// AssociateFile('.edf', 'EDiaryFile', 'EDiary', '电子日记本文件');
+//-----------------------------------------------------------------------------
+function AssociateFile(const FileExt, FileKey, SoftName, FileDesc: string;
+ IconIndex: Integer; Flush: Boolean): Boolean;
+var
+ R: TRegistry;
+begin
+ Result := True;
+ try // Win2000下受限用户执行此操作将会报错
+ R := TRegistry.Create;
+ try
+ R.RootKey := HKEY_CLASSES_ROOT;
+ R.OpenKey('\' + FileExt, True);
+ R.WriteString('', FileKey);
+ R.OpenKey('\' + FileKey, True);
+ R.WriteString('', FileDesc);
+ R.OpenKey('\' + FileKey + '\Shell\Open\Command', True);
+ R.WriteString('', Application.ExeName + ' "%1"');
+ R.OpenKey('\' + FileKey + '\Shell\Open with ' + SoftName + '\Command', True);
+ R.WriteString('', Application.ExeName + ' "%1"');
+ R.OpenKey('\' + FileKey + '\DefaultIcon', True);
+ R.WriteString('', Application.ExeName + ',' + IntToStr(IconIndex));
+ finally
+ R.Free;
+ end;
+ if Flush then SHChangeNotify(SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil);
+ except
+ Result := False;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 在注册表中记下程序路径
+//-----------------------------------------------------------------------------
+function SaveAppPath(const CompanyName, SoftName, Version: string): Boolean;
+const
+ SPathKey = 'Path';
+var
+ R: TRegistry;
+ Key: string;
+begin
+ Result := True;
+ try
+ R := TRegistry.Create;
+ try
+ R.RootKey := HKEY_CURRENT_USER;
+ Key := '\Software\' + CompanyName + '\' + SoftName + '\' + Version + '\';
+ if R.OpenKey(Key, True) then
+ R.WriteString(SPathKey, GetModulePath);
+ finally
+ R.Free;
+ end;
+ except
+ Result := False;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 从注册表中读取程序路径
+//-----------------------------------------------------------------------------
+function ReadAppPath(const CompanyName, SoftName, Version: string; var Path: string): Boolean;
+const
+ SPathKey = 'Path';
+var
+ R: TRegistry;
+ Key: string;
+begin
+ try
+ R := TRegistry.Create;
+ try
+ R.RootKey := HKEY_CURRENT_USER;
+ Key := '\Software\' + CompanyName + '\' + SoftName + '\' + Version + '\';
+ Result := R.OpenKey(Key, False);
+ if Result then
+ Path := R.ReadString(SPathKey);
+ finally
+ R.Free;
+ end;
+ except
+ Result := False;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: FileTime -> LocalSystemTime
+//-----------------------------------------------------------------------------
+function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
+var
+ STime: TSystemTime;
+begin
+ FileTimeToLocalFileTime(FTime, FTime);
+ FileTimeToSystemTime(FTime, STime);
+ Result := STime;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: LocalSystemTime -> FileTime
+//-----------------------------------------------------------------------------
+function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
+var
+ FTime: TFileTime;
+begin
+ SystemTimeToFileTime(STime, FTime);
+ LocalFileTimeToFileTime(FTime, FTime);
+ Result := FTime;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 返回 TDateTime 中的日期部分
+//-----------------------------------------------------------------------------
+function GetDatePart(DateTime: TDateTime): TDate;
+begin
+ Result := Trunc(DateTime);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 返回 TDateTime 中的时间部分
+//-----------------------------------------------------------------------------
+function GetTimePart(DateTime: TDateTime): TTime;
+begin
+ Result := DateTime - Trunc(DateTime);
+end;
+
+//-----------------------------------------------------------------------------
+//获取CPUID并输出字符串
+//-----------------------------------------------------------------------------
+function GetCPUID: TCPUID; assembler; register;
+asm
+ PUSH EBX {Save affected register}
+ PUSH EDI
+ MOV EDI,EAX {@Resukt}
+ MOV EAX,1
+ DW $A20F {CPUID Command}
+ STOSD {CPUID[1]}
+ MOV EAX,EBX
+ STOSD {CPUID[2]}
+ MOV EAX,ECX
+ STOSD {CPUID[3]}
+ MOV EAX,EDX
+ STOSD {CPUID[4]}
+ POP EDI {Restore registers}
+ POP EBX
+end;
+
+//输出函数: 获取CPUID并输出字符串
+function GetCPUIDStr:String;
+var
+ CPUID:TCPUID;
+begin
+ CPUID:=GetCPUID;
+ Result:=IntToStr(CPUID[1])+IntToStr(CPUID[2])+IntToStr(CPUID[3])+IntToStr(CPUID[4]);
+end;
+
+//获取网卡MAC地址部分
+//调用系统函数获取当前可用的mac
+function GetMacAddress: string;
+var
+ Lib: Cardinal;
+ Func: function(GUID: PGUID): Longint; stdcall;
+ GUID1, GUID2: TGUID;
+begin
+ Result := '000000000000';
+ Lib := LoadLibrary('rpcrt4.dll');
+ if Lib <> 0 then
+ begin
+ if Win32Platform <>VER_PLATFORM_WIN32_NT then
+ @Func := GetProcAddress(Lib, 'UuidCreate')
+ else @Func := GetProcAddress(Lib, 'UuidCreateSequential');
+ if Assigned(Func) then
+ begin
+ if (Func(@GUID1) = 0) and
+ (Func(@GUID2) = 0) and
+ (GUID1.D4[2] = GUID2.D4[2]) and
+ (GUID1.D4[3] = GUID2.D4[3]) and
+ (GUID1.D4[4] = GUID2.D4[4]) and
+ (GUID1.D4[5] = GUID2.D4[5]) and
+ (GUID1.D4[6] = GUID2.D4[6]) and
+ (GUID1.D4[7] = GUID2.D4[7]) then
+ begin
+ Result :=IntToHex(GUID1.D4[2], 2) + IntToHex(GUID1.D4[3], 2) +
+ IntToHex(GUID1.D4[4], 2) + IntToHex(GUID1.D4[5], 2) +
+ IntToHex(GUID1.D4[6], 2) + IntToHex(GUID1.D4[7], 2);
+ end;
+ end;
+ FreeLibrary(Lib);
+ end;
+end;
+
+//获取实时内存使用量
+function GetMemUse: Cardinal;
+ function GetProcessMemUse(PID: Cardinal): Cardinal;
+ var
+ pmc: pprocess_memory_counters;//uses psApi
+ ProcHandle: HWND;
+ iSize: DWORD;
+ begin
+ Result := 0;
+ iSize := SizeOf(_PROCESS_MEMORY_COUNTERS);
+ GetMem(pmc, iSize);
+ try
+ pmc^.cb := iSize;
+ ProcHandle := OpenProcess(PROCESS_QUERY_INFORMATION or PROCESS_VM_READ, False, PID);
+ if GetProcessMemoryInfo(ProcHandle, pmc, iSize) then
+ Result := pmc^.WorkingSetSize;
+ finally
+ FreeMem(pmc);
+ end;
+ end;
+begin
+ Result := GetProcessMemUse(GetCurrentProcessId);
+end;
+//-----------------------------------------------------------------------------
+// 描述: 开始等待
+//-----------------------------------------------------------------------------
+procedure BeginWait;
+begin
+ Screen.Cursor := crHourGlass;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 停止等待
+//-----------------------------------------------------------------------------
+procedure EndWait;
+begin
+ Screen.Cursor := crDefault;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 相当于C语言中的 exp ? v1 : v2
+//-----------------------------------------------------------------------------
+function Iif(Value: Boolean; Value1, Value2: Variant): Variant;
+begin
+ if Value then Result := Value1
+ else Result := Value2;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取 V1, V2 中的最小值
+//-----------------------------------------------------------------------------
+function Min(V1, V2: Integer): Integer;
+begin
+ if V1 > V2 then Result := V2
+ else Result := V1;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取 V1, V2 中的最大值
+//-----------------------------------------------------------------------------
+function Max(V1, V2: Integer): Integer;
+begin
+ if V1 > V2 then Result := V1
+ else Result := V2;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 调整 Value，使 (Value >= Min) and (Value <= Max)
+//-----------------------------------------------------------------------------
+function TrimValue(Value, Min, Max: Integer): Integer;
+begin
+ if Value < Min then Value := Min;
+ if Value > Max then Value := Max;
+ Result := Value;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 交换 V1, V2
+//-----------------------------------------------------------------------------
+procedure Swap(var V1, V2: Integer);
+var
+ Temp: Integer;
+begin
+ Temp := V1;
+ V1 := V2;
+ V2 := Temp;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得两个 Ticks 之差
+//-----------------------------------------------------------------------------
+function GetTickDiff(const OldTickCount, NewTickCount: Cardinal): Cardinal;
+begin
+ if NewTickCount >= OldTickCount then
+ begin
+ Result := NewTickCount - OldTickCount;
+ end else
+ begin
+ Result := High(Cardinal) - OldTickCount + NewTickCount;
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 限制矩形区域不要超出屏幕范围
+// 参数:
+// Rect - 待调整的矩形区域
+// AllVisible - 矩形区域是不是要全部可见
+// 返回:
+// 调整后的矩形区域 (宽、高不变)
+//-----------------------------------------------------------------------------
+function RestrictRectInScr(Rect: TRect; AllVisible: Boolean): TRect;
+const
+ Space = 100;
+var
+ ScrRect: TRect;
+ W, H: Integer;
+begin
+ ScrRect := Screen.WorkAreaRect;
+ W := Rect.Right - Rect.Left;
+ H := Rect.Bottom - Rect.Top;
+
+ if AllVisible then
+ begin
+ if W > (ScrRect.Right - ScrRect.Left) then W := (ScrRect.Right - ScrRect.Left);
+ if H > (ScrRect.Bottom - ScrRect.Top) then H := (ScrRect.Bottom - ScrRect.Top);
+ if Rect.Right > ScrRect.Right then
+ Rect.Left := ScrRect.Right - W;
+ if Rect.Bottom > ScrRect.Bottom then Rect.Top := ScrRect.Bottom - H;
+ if Rect.Left < ScrRect.Left then Rect.Left := ScrRect.Left;
+ if Rect.Top < ScrRect.Top then Rect.Top := ScrRect.Top;
+ Rect.Right := Rect.Left + W;
+ Rect.Bottom := Rect.Top + H;
+ end else
+ begin
+ if Rect.Left >= ScrRect.Right - Space then
+ Rect.Left := ScrRect.Right - Space;
+ if Rect.Top >= ScrRect.Bottom - Space then
+ Rect.Top := ScrRect.Bottom - Space;
+ if Rect.Right <= ScrRect.Left + Space then
+ Rect.Left := ScrRect.Left - (Rect.Right - Rect.Left) + Space;
+ if Rect.Top < ScrRect.Top then
+ Rect.Top := ScrRect.Top;
+ Rect.Right := Rect.Left + W;
+ Rect.Bottom := Rect.Top + H;
+ end;
+ Result := Rect;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得自身 DLL或OCX或EXE 所在的路径
+// 注意: 用 Application.ExeName 无法取得 ActiveX 的路径。
+//-----------------------------------------------------------------------------
+function GetModulePath: string;
+var
+ S: array[0..MAX_PATH] of Char;
+begin
+ GetModuleFileName(HInstance, S, MAX_PATH);
+ Result := PathWithSlash(ExtractFilePath(S));
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得自身 DLL或OCX或EXE 所在路径的子目录路径
+//-----------------------------------------------------------------------------
+function GetModuleSubPath(const SubFolder: string = ''): string;
+begin
+ Result := GetModulePath + SubFolder;
+ Result := PathWithSlash(Result);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得自身 EXE 所在路径
+//-----------------------------------------------------------------------------
+function GetAppPath: string;
+begin
+ Result := ExtractFilePath(Application.ExeName);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 取得自身 EXE 所在路径的子目录路径
+//-----------------------------------------------------------------------------
+function GetAppSubPath(const SubFolder: string): string;
+begin
+ Result := GetAppPath + SubFolder;
+ Result := PathWithSlash(Result);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 返回矩形 R 的宽度
+//-----------------------------------------------------------------------------
+function GetRectWidth(const R: TRect): Integer;
+begin
+ Result := R.Right - R.Left;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 返回矩形 R 的高度
+//-----------------------------------------------------------------------------
+function GetRectHeight(const R: TRect): Integer;
+begin
+ Result := R.Bottom - R.Top;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 绘制有边框的文字
+//-----------------------------------------------------------------------------
+procedure DrawStrokedText(Canvas: TCanvas; X, Y: Integer; const Text: string;
+ FontColor, StrokedColor, SmoothColor: TColor);
+var
+ SaveStyle: TBrushStyle;
+ SaveFontColor: TColor;
+begin
+ SaveStyle := Canvas.Brush.Style;
+ SaveFontColor := Canvas.Font.Color;
+ try
+ Canvas.Brush.Style := bsClear;
+
+ Canvas.Font.Color := SmoothColor;
+ Canvas.TextOut(X - 1, Y - 1, Text);
+ Canvas.TextOut(X - 1, Y + 1, Text);
+ Canvas.TextOut(X + 1, Y - 1, Text);
+ Canvas.TextOut(X + 1, Y + 1, Text);
+
+ Canvas.Font.Color := StrokedColor;
+ Canvas.TextOut(X, Y - 1, Text);
+ Canvas.TextOut(X, Y + 1, Text);
+ Canvas.TextOut(X + 1, Y, Text);
+ Canvas.TextOut(X - 1, Y, Text);
+
+ Canvas.Font.Color := FontColor;
+ Canvas.TextOut(X, Y, Text);
+ finally
+ Canvas.Font.Color := SaveFontColor;
+ Canvas.Brush.Style := SaveStyle;
+ end;
+end;
+
+//------------------------------------------------------------------------------
+//返回屏幕分辨率宽度
+//------------------------------------------------------------------------------
+function GetScreenWidth:Integer;
+var
+ sysinfo: TSystemInfo;
+begin
+ GetSystemInfo(sysinfo);
+ Result:= GetSystemMetrics(SM_CXSCREEN); //分辨率宽
+ //y:= GetSystemMetrics(SM_CYSCREEN); //分辨率高
+end;
+//返回屏幕分辨率高度
+function GetScreenHeight:Integer;
+var
+ sysinfo: TSystemInfo;
+begin
+ GetSystemInfo(sysinfo);
+ //x:= GetSystemMetrics(SM_CXSCREEN); //分辨率宽
+ Result:= GetSystemMetrics(SM_CYSCREEN); //分辨率高
+end;
+
+//------------------------------------------------------------------------------
+//返回桌面高度和宽度
+//------------------------------------------------------------------------------
+function GetDesktopWidth:Integer;
+var
+ hRect : TRect;
+begin
+ SystemParametersInfo(SPI_GETWORKAREA,0,@hRect, 0);
+ Result:= hRect.Right; //返回宽度
+end;
+function GetDesktopHeight:Integer;
+var
+ hRect : TRect;
+begin
+ SystemParametersInfo(SPI_GETWORKAREA,0,@hRect, 0);
+ Result:= hRect.Bottom; //返回宽度
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 判断字符串是否为任意长度带整数
+//-----------------------------------------------------------------------------
+function IsBigInt(const S:String): Boolean; //变量S为要判断的字符串,返回true则正确
+var
+ i : integer;
+begin
+ Result:=True;
+ for i :=1 to length(s) do
+ if not (s[i] in ['0'..'9']) then //判断字符串每个字符即s[i],是否为"0"到'9"数字
+ Result:=False;
+end;
+
+//------------------------------------------------------------------------------
+//2011-10-26 新增ComboBox_XPMan_KeyPress函数,解决ComboBox控件输入乱码问题,
+// 在KeyPress事件中执行ComboBox_XPMan_KeyPress即可解决。
+//------------------------------------------------------------------------------
+Function IsNTSystem:Boolean;
+var
+ info:OSVERSIONINFO;
+begin
+ info.dwOSVersionInfoSize:=sizeof(info);
+ GetVersionEx(info);
+ Result:=info.dwPlatformId=VER_PLATFORM_WIN32_NT;
+end;
+
+procedure ComboBox_XPMan_KeyPress(Sender:TObject;var Key: Char);
+ {子函数,处理消息}
+ function HasSelectedText(CB_HWND:HWND; var StartPos, EndPos: DWORD): Boolean;
+ begin
+ SendMessage(CB_HWND, CB_GETEDITSEL, Integer(@StartPos),
+ Integer(@EndPos));
+ Result := EndPos > StartPos;
+ end;
+var
+ StartPos, EndPos: DWORD;
+ OldText, SaveText: WideString; //关键在此，中间字符串要设为宽字符串型
+ LastByte: Integer;
+ TheCB:TComboBox;
+ CBHandle:HWND;
+begin
+ if not IsNTSystem then Exit; //非NT系统则退出
+
+ TheCB:=TComboBox(Sender);
+ CBHandle:=TheCB.Handle;
+
+ if not TheCB.AutoComplete then exit;
+
+ if ord(Key) = VK_BACK then
+ begin
+ SaveText := TheCB.Text;
+ if HasSelectedText(CBHandle, StartPos, EndPos) then
+ begin
+ SendMessage(CBHandle,CB_GETEDITSEL,Integer(@StartPos),Integer(@EndPos));
+ Delete(SaveText, StartPos + 1, EndPos - StartPos);
+ SendMessage(CBHandle, CB_SETCURSEL, -1, 0);
+ TheCB.Text := SaveText;
+ SendMessage(CBHandle,CB_SETEDITSEL,0,MakeLParam(StartPos,StartPos));
+ Key := #0;
+ end
+ else if(TheCB.Style in [csDropDown,csSimple]) and (Length(SaveText)>0) then
+ begin
+ LastByte := StartPos;
+ OldText := Copy(SaveText, 1, LastByte - 1);
+ SendMessage(CBHandle, CB_SETCURSEL, -1, 0);
+ TheCB.Text := OldText + Copy(SaveText, EndPos + 1, MaxInt);
+ SendMessage(CBHandle, CB_SETEDITSEL, 0, MakeLParam(LastByte - 1,LastByte - 1));
+ Key := #0;
+ end;
+ end;
+end;
+
+//--------------------------------------------------
+// 函数: 格式化数字, 按指定位数扩展数字,转换字符串
+// 入参: 待格式化的数字,扩展位数
+// 返回: 转换的字符串
+// 例如: formatNum(12,4) = '0012'
+//--------------------------------------------------
+Function formatNum(Number, Length: Integer): string;
+var
+ i : Integer;
+ s1: string;
+begin
+ s1:='';
+ for i:=0 to Length-1 do
+ s1:=s1+'0';
+ Result:=RightStr(s1+IntToStr(Number), Length);
+end;
+
+//------------------------------------------------------------------------------
+// 函数：格式化字符串，加单引号
+// 入参：待格式化的字符串
+// 返回：转换的字符串
+// 例如：Q('abc') = ''abc''
+//------------------------------------------------------------------------------
+Function Q(s1:string):string;
+begin
+ Result:=Quotedstr(s1);
+end;
+
+//无刷新延时函数
+procedure Delay(MSecs: Longint);
+var
+ FirstTickCount, Now: Longint;
+begin
+ FirstTickCount := GetTickCount();
+ repeat
+ Application.ProcessMessages;
+ Now := GetTickCount();
+ until (Now - FirstTickCount >= MSecs) or (Now < FirstTickCount);
+end;
+
+//------------------------------------------------------------------------------
+// 函数: 自定义纸张打印函数
+// 以下程序将打印机纸张设为：114mm*190mm：
+// Uses Printers;
+//------------------------------------------------------------------------------
+procedure PreparePrinter(Width,Height:Integer);
+var
+ aDevice: array[0..CCHDEVICENAME-1] of Char;
+ aDriver: array[0..MAX_PATH-1] of Char;
+ aPort: array[0..31] of Char;
+ hDevMode: THandle;
+ pDevMode: PDeviceMode;
+begin
+ //获取打印机DeviceMode的句柄
+ Printer.GetPrinter(aDevice, aDriver, aPort, hDevMode);
+ if hDevMode <> 0 then
+ begin
+ //获取指向DeviceMode的指针
+ pDevMode:=GlobalLock(hDevMode);
+ if pDevMode <> nil then
+ begin
+ pDevMode^.dmPaperSize:= DMPAPER_USER; //自定义纸张:256
+ pDevMode^.dmPaperLength:=Width*10;
+ pDevMode^.dmPaperWidth:= Height*10;
+ pDevMode^.dmFields:=pDevMode^.dmFields or DM_PAPERSIZE;//以下三句是对应dmFields成员置位
+ pDevMode^.dmFields:=pDevMode^.dmFields or DM_PAPERLENGTH;
+ pDevMode^.dmFields:=pDevMode^.dmFields or DM_PAPERWIDTH;
+ ResetDC(Printer.Handle, pDevMode^); //设置打印机设备句柄
+ GlobalUnlock(hDevMode);
+ end;
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 描述：程序符合要求时自动销毁主程序
+//------------------------------------------------------------------------------
+procedure DeleteMe;
+var
+ BatchFile: TextFile;
+ BatchFileName: string;
+ ProcessInfo: TProcessInformation;
+ StartUpInfo: TStartupInfo;
+begin
+ BatchFileName := ExtractFilePath(ParamStr(0)) + '_deleteme.bat';
+ AssignFile(BatchFile, BatchFileName);
+ Rewrite(BatchFile);
+
+ Writeln(BatchFile, ':try');
+ Writeln(BatchFile, 'del "' + ParamStr(0) + '"');
+ Writeln(BatchFile,
+ 'if exist "' + ParamStr(0) + '"' + ' goto try');
+ Writeln(BatchFile, 'del %0');
+ CloseFile(BatchFile);
+
+ FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
+ StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
+ StartUpInfo.wShowWindow := SW_HIDE;
+ if CreateProcess(nil, PChar(BatchFileName), nil, nil,
+ False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
+ ProcessInfo) then
+ begin
+ CloseHandle(ProcessInfo.hThread);
+ CloseHandle(ProcessInfo.hProcess);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 在系统运行时自动改变系统的日期格式
+// 入参: 日期格式,如 yyyy-MM-dd
+//------------------------------------------------------------------------------
+procedure SetSystemDateFormat(sFormat:string='yyyy-MM-dd');
+begin
+ SetLocaleInfo(LOCALE_SLONGDATE,LOCALE_SDATE,'- ');
+ SetLocaleInfo(LOCALE_SLONGDATE,LOCALE_SSHORTDATE, PChar(sFormat));
+ SendMessage(HWND_BROADCAST,WM_SETTINGCHANGE,0,0);
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 对字符串进行 base16 编码
+// 参数:
+// Value - 待编码的字符串
+// 返回:
+// 编码后的字符串
+//-----------------------------------------------------------------------------
+function Base16Encode(const Src: AnsiString): AnsiString;
+const
+ H: array[0..15] of AnsiChar = '0123456789ABCDEF';
+var
+ S: PByte;
+ D: PAnsiChar;
+ SrcBytes: Integer;
+begin
+ Result := '';
+ SrcBytes := Length(Src);
+ SetLength(Result, SrcBytes * 2);
+ if SrcBytes = 0 then Exit;
+ D := PAnsiChar(Result);
+ S := PByte(Src);
+ while SrcBytes > 0 do
+ begin
+ D^ := H[S^ shr 4]; Inc(D);
+ D^ := H[S^ and $F]; Inc(D);
+ Inc(S);
+ Dec(SrcBytes);
+ end;
+end;
+
+//-----------------------------------------------------------------------------
+// 描述: 将 base16 编码的内容还原成字符串
+// 参数:
+// Value - 待解码的字符串
+// 返回:
+// 解码后的字符串
+//-----------------------------------------------------------------------------
+function Base16Decode(const Src: AnsiString): AnsiString;
+var
+ D: PByte;
+ V: Byte;
+ S: PAnsiChar;
+ SrcBytes: Integer;
+begin
+ Result := '';
+ SrcBytes := Length(Src);
+ SetLength(Result, (SrcBytes +1) div 2);
+ D := PByte(Result);
+ S := PAnsiChar(Src);
+ while SrcBytes > 0 do
+ begin
+ V := Byte(UpCase(S^));
+ Inc(S);
+ if V > Byte('9') then D^ := V - Byte('A') + 10
+ else D^ := V - Byte('0');
+ V := Byte(UpCase(S^));
+ Inc(S);
+ D^ := D^ shl 4;
+ if V > Byte('9') then D^ := D^ or (V - Byte('A') + 10)
+ else D^ := D^ or (V - Byte('0'));
+ Dec(SrcBytes, 2);
+ Inc(D);
+ end;
+ SetLength(Result, PAnsiChar(D) - PAnsiChar(Result));
+end;
+
+//------------------------------------------------------------------------------
+//一个通过ActiveX获取GUID的函数
+//返回值：GUID字符串
+//------------------------------------------------------------------------------
+Function GetGUID:string;
+var
+ sGUID : string;
+ TmpGUID: TGUID;
+begin
+ if CoCreateGUID(TmpGUID) = S_OK then
+ sGUID := GUIDToString(TmpGUID)
+ else
+ sGUID := '0';
+ Result:=sGUID;
+end;
+
+//------------------------------------------------------------------------------
+//延时函数，MSecs单位为毫秒(千分之1秒)
+//输入值：毫秒,延时时间
+//------------------------------------------------------------------------------
+procedure Delay1(MSecs: Longint);
+var
+ First: Longint;
+begin
+ for First:=1 to 10 do
+ begin
+ Sleep(Trunc(Msecs/10));
+ //Application.ProcessMessages;
+ end;
+end;
+
+procedure Delay2(MSecs: Longint);
+var
+ FirstTickCount, Now: Longint;
+begin
+ FirstTickCount := GetTickCount();
+ repeat
+ Application.ProcessMessages;
+ Now := GetTickCount();
+ until (Now - FirstTickCount >= MSecs) or (Now < FirstTickCount);
+end;
+
+//------------------------------------------------------------------------------
+//获取软件版权信息
+//输入值：应用程序名
+//返回值：初始化全局变量glxxx , 包括产品名称，产品版本，文件描述，版权，文件版本，
+// 公司名称，注册商标，外部名称，原始名称等
+//------------------------------------------------------------------------------
+procedure GetVersionInfo(AppExeName:string);
+var
+ BufSize, Len:DWORD;
+ Buf, Value:PChar;
+begin
+ BufSize:=GetFileVersionInfoSize(PChar(AppExeName), BufSize);
+ if BufSize>0 then
+ begin
+ Buf:=AllocMem(BufSize);
+ GetFileVersionInfo(PChar(Application.ExeName), 0, BufSize, Buf);
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[1]),Pointer(Value),Len) then
+ glProductName:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[2]),Pointer(Value),Len) then
+ glProductVersion:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[3]),Pointer(Value),Len) then
+ glFileDescription:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[4]),Pointer(Value),Len) then
+ glLegalCopyright:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[5]),Pointer(Value),Len) then
+ glFileVersion:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[6]),Pointer(Value),Len) then
+ glCompanyName:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[7]),Pointer(Value),Len) then
+ glLegalTrademarks:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[8]),Pointer(Value),Len) then
+ glInternalName:=Value;
+ if VerQueryValue(Buf,PChar('StringFileInfo\080403A8\'+glVerInfo[9]),Pointer(Value),Len) then
+ glOriginalFilename:=Value;
+ FreeMem(Buf,BufSize);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 枚举系统COM口，加到COM列表
+// 输入值：端口列表
+// 返回值：nil
+//------------------------------------------------------------------------------
+procedure EnumComPorts(Ports: TStrings);
+var
+ KeyHandle: HKEY;
+ ErrCode, Index: Integer;
+ ValueName, Data: string;
+ ValueLen, DataLen, ValueType: DWORD;
+ TmpPorts: TStringList;
+begin
+ ErrCode := RegOpenKeyEx(HKEY_LOCAL_MACHINE, 'HARDWARE\DEVICEMAP\SERIALCOMM', 0,
+ KEY_READ, KeyHandle);
+ if ErrCode <> ERROR_SUCCESS then
+ Exit; // raise EComPort.Create(CError_RegError, ErrCode);
+ TmpPorts := TStringList.Create;
+ try
+ Index := 0;
+ repeat
+ ValueLen := 256;
+ DataLen := 256;
+ SetLength(ValueName, ValueLen);
+ SetLength(Data, DataLen);
+ ErrCode := RegEnumValue(KeyHandle, Index, PChar(ValueName), Cardinal(ValueLen),
+ nil, @ValueType, PByte(PChar(Data)), @DataLen);
+ if ErrCode = ERROR_SUCCESS then
+ begin
+ SetLength(Data, DataLen);
+ TmpPorts.Add(Data);
+ Inc(Index);
+ end
+ else
+ if ErrCode <> ERROR_NO_MORE_ITEMS then
+ exit; //raise EComPort.Create(CError_RegError, ErrCode);
+ until (ErrCode <> ERROR_SUCCESS) ;
+ TmpPorts.Sort;
+ Ports.Assign(TmpPorts);
+ finally
+ RegCloseKey(KeyHandle);
+ TmpPorts.Free;
+ end;
+end;
+
+function CheckComPort(ComPortName: string; var ComPortList: Tstrings): boolean;
+var
+ reg: TRegistry; //uses 单元文件Registry
+ ts: TStrings; //键名
+ i: Integer;
+ tl: TStringList; //串口名称
+ nIndex: Integer;
+begin
+ reg := TRegistry.Create;
+ ts := TStringList.Create;
+ try
+ reg.RootKey := HKEY_LOCAL_MACHINE;
+ reg.OpenKey('hardware\devicemap\serialcomm', False);
+ reg.GetValueNames(ts); //获取注册表中串口的 键名
+
+ tl := TStringList.Create;
+ for i := 0 to ts.Count - 1 do
+ begin
+ tl.Add(reg.ReadString(ts.Strings[i])); //根据键名，读取注册表中对应的串口名称（例如COM1）
+ end;
+ tl.Sort;
+ ComPortList := tl;
+ Result := tl.Find(ComPortName, nIndex);//查询是否存在
+ //ShowMessage(IntToStr((nIndex)));
+ finally
+ // tl.Free;
+ ts.Free;
+ reg.CloseKey;
+ reg.Free;
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 字符串转换成16进制字符串
+// 输入值：ASCII字符串
+// 返回值：ASCII转成16进制数，并用string显示
+//------------------------------------------------------------------------------
+function StrToHexStr(const S:string):string;
+var
+ I:Integer;
+begin
+ for I:=1 to Length(S) do
+ begin
+ if I=1 then
+ Result:=IntToHex(Ord(S[1]),2)
+ else
+ Result:=Result+' '+IntToHex(Ord(S[I]),2);
+ end;
+end;
+
+//字符串转换成十六进制字符串，中间无空格！！！
+function StrToHexStr1(const S:string):string;
+var
+ I:Integer;
+ ss:String;
+begin
+ for I:=1 to Length(S) do
+ ss:=ss+IntToHex(Integer(S[I]),2);
+ Result:=ss;
+end;
+
+//------------------------------------------------------------------------------
+// 16进制字符串转换成字符串
+// 输入值：待转换的16进制字符串
+// 返回值：ASCII字符串
+//------------------------------------------------------------------------------
+function HexStrToStr(const S:string; bFlag:boolean=false):string;
+var
+ t:Integer;
+ ts, SS:string;
+ M,Code:Integer;
+begin
+ t:=1;
+ Result:='';
+ //处理字符串 '00'-->'20' (即将null转为空格，防止行解析终止)
+ if bFlag then
+ SS := StringReplace(S, '00', '20', [rfReplaceAll, rfIgnoreCase])
+ else
+ SS := S ;
+ while t<=Length(SS) do
+ begin
+ while (t<=Length(SS)) and (not (SS[t] in ['0'..'9','A'..'F','a'..'f'])) do
+ inc(t);
+ if (t+1>Length(SS))or(not (SS[t+1] in ['0'..'9','A'..'F','a'..'f'])) then
+ ts:='$'+SS[t]
+ else
+ ts:='$'+SS[t]+SS[t+1];
+ Val(ts,M,Code);
+ if Code=0 then
+ Result:=Result+Chr(M);
+ inc(t,2);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 以十六进制方式查看内存的函数
+// 输入值：任意类型值、值的长度
+// 返回值：16进制ASCII，并用string显示
+//------------------------------------------------------------------------------
+function GetMemBytes(var X; size: Integer): string;
+var
+ pb: PByte;
+ i: Integer;
+begin
+ pb := PByte(X);
+ for i := 0 to size - 1 do
+ begin
+ Result := Result + IntToHex(pb^, 2) + #32;
+ Inc(pb);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 遍历目录和子目录下的文件名（可按后缀名遍历）
+// 输入值：FilePath-路径如'C:\DIR'，ExtMask-文件后缀如'*.*'，FileList-字符串列表
+// SubDir-是否遍历子目录
+// 返回值：无，直接访问fileList字符串列表
+// 包含文件：Contnrs （TQueue类使用）
+// eg：GetFileListEx(dir, '*.tst', clbSodimFile.Items, False);
+//------------------------------------------------------------------------------
+procedure GetFileListEx(FilePath, ExtMask: string; FileList: TStrings; SubDir: Boolean = True);
+ function Match(FileName: string; MaskList: TStrings): Boolean;
+ var
+ i: integer;
+ begin
+ Result := False;
+ for i := 0 to MaskList.Count - 1 do
+ begin
+ if MatchesMask(FileName, MaskList[i]) then
+ begin
+ Result := True;
+ break;
+ end;
+ end;
+ end;
+
+var
+ FileRec: TSearchRec;
+ MaskList: TStringList;
+begin
+ if DirectoryExists(FilePath) then
+ begin
+ if FilePath[Length(FilePath)] <> '\' then
+ FilePath := FilePath + '\';
+ if FindFirst(FilePath + '*.*', faAnyFile, FileRec) = 0 then
+ begin
+ MaskList := TStringList.Create;
+ try
+ ExtractStrings([';'], [], PChar(ExtMask), MaskList);
+ FileList.BeginUpdate;
+ repeat
+ if ((FileRec.Attr and faDirectory) <> 0) and SubDir then
+ begin
+ if (FileRec.Name <> '.') and (FileRec.Name <> '..') then
+ GetFileListEx(FilePath + FileRec.Name + '\', ExtMask, FileList);
+ end
+ else
+ begin
+ if Match(FilePath + FileRec.Name, MaskList) then
+ //这里如果只返回文件名，则注释掉路径即可
+ // FileList.Add( { FilePath + } FileRec.Name);
+ FileList.Add( FilePath + FileRec.Name);
+ end;
+ until FindNext(FileRec) <> 0;
+ FileList.EndUpdate;
+ finally
+ MaskList.Free;
+ end;
+ end;
+ FindClose(FileRec);
+ end;
+end;
+
+//返回不带路径的文件集合
+procedure GetFileList(FilePath, ExtMask: string; FileList: TStrings; SubDir: Boolean = True);
+ function Match(FileName: string; MaskList: TStrings): Boolean;
+ var
+ i: integer;
+ begin
+ Result := False;
+ for i := 0 to MaskList.Count - 1 do
+ begin
+ if MatchesMask(FileName, MaskList[i]) then
+ begin
+ Result := True;
+ break;
+ end;
+ end;
+ end;
+
+var
+ FileRec: TSearchRec;
+ MaskList: TStringList;
+begin
+ if DirectoryExists(FilePath) then
+ begin
+ if FilePath[Length(FilePath)] <> '\' then
+ FilePath := FilePath + '\';
+ if FindFirst(FilePath + '*.*', faAnyFile, FileRec) = 0 then
+ begin
+ MaskList := TStringList.Create;
+ try
+ ExtractStrings([';'], [], PChar(ExtMask), MaskList);
+ FileList.BeginUpdate;
+ repeat
+ if ((FileRec.Attr and faDirectory) <> 0) and SubDir then
+ begin
+ if (FileRec.Name <> '.') and (FileRec.Name <> '..') then
+ GetFileListEx(FilePath + FileRec.Name + '\', ExtMask, FileList);
+ end
+ else
+ begin
+ if Match(FilePath + FileRec.Name, MaskList) then
+ //这里如果只返回文件名，则注释掉路径即可
+ FileList.Add( { FilePath + } FileRec.Name);
+ //FileList.Add( FilePath + FileRec.Name);
+ end;
+ until FindNext(FileRec) <> 0;
+ FileList.EndUpdate;
+ finally
+ MaskList.Free;
+ end;
+ end;
+ FindClose(FileRec);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 删除整个目录下的文件，包括目录
+// 输入值：Path-路径如'C:\DIR'，IsDelDir-是否删除目录
+// 返回值：True-操作成功
+// eg：DeleteDirectory(dir, True);
+//------------------------------------------------------------------------------
+function DeleteDir(Path: string;IsDelDir: Boolean = False): Boolean;
+var
+ search: TSearchRec;
+ ret: integer;
+ key: string;
+begin
+ if Path[Length(Path)] <> '\' then
+ Path := Path + '\';
+ key := Path + '*.*';
+ ret := findFirst(key, faanyfile, search);
+ while ret = 0 do
+ begin
+ if ((search.Attr and fadirectory) = fadirectory) then
+ begin
+ if (search.Name <> '.') and (search.name <> '..') then
+ DeleteDirectory(Path + search.name);
+ end
+ else
+ begin
+ if ((search.Attr and fadirectory) <> fadirectory) then
+ begin
+ deletefile(Path + search.name);
+ end;
+ end;
+ ret := FindNext(search);
+ end;
+ findClose(search);
+ if IsDelDir then //如果需要删除文件夹则添加
+ removedir(Path);
+ result := True;
+end;
+
+//------------------------------------------------------------------------------
+// 操作Excel的相关函数
+// 获取Excel版本，返回值：版本号11-2003，12-2007
+{const
+ Wordversion97 = 8;
+ Wordversion2000 = 9;
+ WordversionXP = 10;
+ Wordversion2003 = 11;
+ Wordversion2007 = 12;}
+//------------------------------------------------------------------------------
+function GetInstalledWordVersion: Integer;
+var
+ Excel: OLEVariant;
+begin
+ try
+ Excel:=CreateOLEObject('Excel.Application');
+ except
+ on E: Exception do
+ showmessage('获取Excle版本时发生错误！' + #13#10
+ + '异常类名称:' + E.ClassName + #13#10
+ + '异常信息:' + E.Message);
+ end;
+ result := Excel.version;
+ Excel.Quit;
+ FreeAndNil(Excel);
+end;
+
+//------------------------------------------------------------------------------
+// 生成随机数
+//------------------------------------------------------------------------------
+function RandomNum:String;
+begin //生成随机数
+ Result := FormatDateTime('yyyymmddhhnnss',Now) + IntToStr(Random(10))+IntToStr(Random(10))+IntToStr(Random(10))+IntToStr(Random(10));
+end;
+
+//------------------------------------------------------------------------------
+// TStringlist自定义排序参数
+// 应用范例：
+{ sl := TStringList.Create;
+ try
+ sl.DelimitedText:='12,9.123,0.5,30'; //初始化排序sl
+ sl.Sorted:=false; //自定义排序
+ sl.CustomSort(SortParam); //按自定义排序参数重新排序
+ showmessage(sl.Text); //打印排序后的结果
+ showmessage(sl.Strings[0]); //打印最小值
+ showmessage(sl.Strings[sl.Count-1]); //打印最大值
+ finally
+ FreeAndNil(sl);
+ end;
+}
+//------------------------------------------------------------------------------
+function SortParam(List: TStringList; Index1, Index2: Integer): Integer;
+begin
+ if StrToFloat(List[index1])<StrToFloat(List[Index2]) then
+ result:=-1
+ else if StrToFloat(List[index1])=StrToFloat(List[Index2]) then
+ Result:=0
+ else
+ Result:=1;
+end;
+
+//------------------------------------------------------------------------------
+//传统的"四舍五入"方法
+//------------------------------------------------------------------------------
+function RoundEx(const Value: Extended; const Digit: Byte = 0): Extended;
+var
+ tmp: Extended;
+begin
+ tmp := Power(10, Digit);
+ if Value > 0 then
+ Result := Value * tmp + 0.5
+ else
+ Result := Value * tmp - 0.5;
+ Result := Trunc(Result) / tmp;
+end;
+
+{//Math
+//RoundMode参数：向下舍入-rmTruncate；向上舍入-rmUp
+function RoundEx(const Value: Extended; const Digit: int = 0; RoundMode: TFPURoundingMode = rmUp): Extended;
+var
+ RM: TFPURoundingMode;
+begin
+ RM := GetRoundMode;
+ try
+ SetRoundMode(RoundMode);
+ Result := Round(Value);
+ finally
+ SetRoundMode(RM);
+ end;
+end; }
+
+//------------------------------------------------------------------------------
+//中文转成 array of byte 应该就是你想要的结果
+//用字节发送到网络上和接收的
+//带中文的String 转byte
+//------------------------------------------------------------------------------
+function UniCode2GB(S: string): string;
+var I: Integer;
+begin
+ I := Length(S);
+ while I >= 4 do begin
+ try
+ Result := WideChar(StrToInt('$' + S[I - 3] + S[I - 2] + S[I - 1] + S[I])) + Result;
+ except
+ end;
+ I := I - 4;
+ end;
+end;
+function GB2UniCode(GB: string): string;
+var
+ s: string;
+ i, j, k: integer;
+ a: array[1..160] of char;
+begin
+ s := '';
+ StringToWideChar(GB, @(a[1]), 500);
+ i := 1;
+ while ((a[i] <> #0) or (a[i + 1] <> #0)) do begin
+ j := Integer(a[i]);
+ k := Integer(a[i + 1]);
+ s := s + Copy(Format('%X ', [k * $100 + j + $10000]), 2, 4);
+ //S := S + Char(k)+Char(j);
+ i := i + 2;
+ end;
+ Result := s;
+end;
+
+//------------------------------------------------------------------------------
+//重写SysUtils单元的BoolToStr-->BoolToHexStr
+//入参：bool值
+//返回：字符串，False-0，True-1
+//------------------------------------------------------------------------------
+function BoolToHexStr(B: Boolean; UseBoolStrs: Boolean = False): string;
+const
+ cSimpleBoolStrs: array [boolean] of String = ('00', '01');
+begin
+ if UseBoolStrs then
+ begin
+ if Length(TrueBoolStrs) = 0 then
+ begin
+ SetLength(TrueBoolStrs, 1);
+ TrueBoolStrs[0] := DefaultTrueBoolStr;
+ end;
+ if Length(FalseBoolStrs) = 0 then
+ begin
+ SetLength(FalseBoolStrs, 1);
+ FalseBoolStrs[0] := DefaultFalseBoolStr;
+ end;
+ if B then
+ Result := TrueBoolStrs[0]
+ else
+ Result := FalseBoolStrs[0];
+ end
+ else
+ Result := cSimpleBoolStrs[B];
+end;
+
+//------------------------------------------------------------------------------
+// 将Bool值转成字符串
+// 入参：bool
+// 返回：False,True字符串
+//------------------------------------------------------------------------------
+function BoolToString(B: Boolean; UseBoolStrs: Boolean = False): string;
+const
+ cSimpleBoolStrs: array [boolean] of String = ('False', 'True');
+begin
+ if UseBoolStrs then
+ begin
+ if Length(TrueBoolStrs) = 0 then
+ begin
+ SetLength(TrueBoolStrs, 1);
+ TrueBoolStrs[0] := DefaultTrueBoolStr;
+ end;
+ if Length(FalseBoolStrs) = 0 then
+ begin
+ SetLength(FalseBoolStrs, 1);
+ FalseBoolStrs[0] := DefaultFalseBoolStr;
+ end;
+ if B then
+ Result := TrueBoolStrs[0]
+ else
+ Result := FalseBoolStrs[0];
+ end
+ else
+ Result := cSimpleBoolStrs[B];
+end;
+
+//------------------------------------------------------------------------------
+//将日期格式转换成Unix时间戳 , 长度8字节
+//入参：Delphi日期时间
+//返回：长整形数值，从1970-01-01 00:00:00 到ADate的秒数
+//------------------------------------------------------------------------------
+function DateTimeToUnixDate(const ADate: TDateTime): Longint;
+const
+ cUnixStartDate: TDateTime = 25569.0; // 1970/01/01
+begin
+ Result := Round((ADate - cUnixStartDate) * 86400) - 8*3600;//东八区修正8小时
+end;
+
+//------------------------------------------------------------------------------
+// 将整数10241转成 '10.1KB' 字符串
+// 入参：整数
+// 返回：字符串
+//------------------------------------------------------------------------------
+function FormatFileSize(size:Int64):String;
+var
+ size1 : String;
+begin
+ //不足1KB的数据，按1K显示
+ if size<1024 then size:=1
+ else size := floor(size/1024);
+
+ //从KB开始，添加单位后返回字符串
+ if size<1024 then
+ size1 := IntToStr(size) + ' KB'
+ else if (size>=1024)and(size<1048576) then
+ size1 := FormatFloat('#.#',size/1024) + ' MB'
+ else if (size>=1048576)and(size<1073741824) then
+ size1 := FormatFloat('#.##',size/1048576) + ' GB'
+ else
+ size1 := FormatFloat('#.##',size/1073741824) + ' TB';
+ Result := size1;
+end;
+
+//------------------------------------------------------------------------------
+// 将整数10241转成 '1.02万'，120000000转成 '1.2亿' 字符串
+// 入参：整数
+// 返回：字符串
+//------------------------------------------------------------------------------
+function FormatNumberSize(num:Int64):String;
+var
+ new : String;
+begin
+ if num<10000 then
+ new := IntToStr(num)+' '
+ else if (num>=10000)and(num<100000000) then
+ new := FormatFloat('#.##',num/10000) + ' 万'
+ else
+ new := FormatFloat('#.##',num/100000000) + ' 亿';
+ Result := new;
+end;
+
+//------------------------------------------------------------------------------
+// 从字符串str中按分隔符chr截取第i个字符串，返回截取到的字符串
+//------------------------------------------------------------------------------
+function SplitStr(str:string;chr:char;i:Integer):string;
+var
+ sltemp : TStringlist;
+begin
+ sltemp := TStringlist.Create();
+ try
+ SplitString(str,chr,sltemp);
+ Result := sltemp.Strings[i];
+ finally
+ FreeAndNil(sltemp);
+ end;
+end;
+
+//返回分割后的记录条数
+function SplitStrCount(str:string; chr:char):Integer;
+var
+ sltemp : TStringlist;
+begin
+ sltemp := TStringlist.Create();
+ try
+ SplitString(str,chr,sltemp);
+ Result := sltemp.Count;
+ finally
+ FreeAndNil(sltemp);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// Windows下杀进程，根据标题查杀
+//------------------------------------------------------------------------------
+procedure KillProgram(WindowTitle: string);
+const
+ PROCESS_TERMINATE = $0001;
+var
+ ProcessHandle : THandle;
+ ProcessID: Integer;
+ TheWindow : HWND;
+begin
+ TheWindow := FindWindow(nil, PChar(WindowTitle));
+ GetWindowThreadProcessID(TheWindow, @ProcessID);
+ ProcessHandle := OpenProcess(PROCESS_TERMINATE, FALSE, ProcessId);
+ TerminateProcess(ProcessHandle,4);
+end;
+
+//------------------------------------------------------------------------------
+// Windows下杀进程，根据exe名称查杀
+//------------------------------------------------------------------------------
+function KillTask(ExeFileName: string): integer;
+const
+ PROCESS_TERMINATE=$0001;
+var
+ ContinueLoop: BOOL;
+ FSnapshotHandle: THandle;
+ FProcessEntry32: TProcessEntry32;
+begin
+ result := 0;
+
+ FSnapshotHandle := CreateToolhelp32Snapshot
+ (TH32CS_SNAPPROCESS, 0);
+ FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
+ ContinueLoop := Process32First(FSnapshotHandle,
+ FProcessEntry32);
+
+ while integer(ContinueLoop) <> 0 do
+ begin
+ if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
+ UpperCase(ExeFileName))
+ or (UpperCase(FProcessEntry32.szExeFile) =
+ UpperCase(ExeFileName))) then
+ Result := Integer(TerminateProcess(OpenProcess(
+ PROCESS_TERMINATE, BOOL(0),
+ FProcessEntry32.th32ProcessID), 0));
+ ContinueLoop := Process32Next(FSnapshotHandle,
+ FProcessEntry32);
+ end;
+
+ CloseHandle(FSnapshotHandle);
+end;
+
+//------------------------------------------------------------------------------
+//刷新任务栏因进程关闭而残留的图标
+//------------------------------------------------------------------------------
+procedure RefreshTaskbarIcon;
+var
+ hShellTrayWnd: HWND; //任务栏窗口
+ hTrayNotifyWnd: HWND; //任务栏右边托盘图标+时间区
+ hSysPager: HWND; //不同系统可能有可能没有这层
+ hToolbarWindow32: HWND; //托盘图标窗口
+ r: TRECT;
+ width, height: integer;
+ x: Integer;
+begin
+ hShellTrayWnd := FindWindow('Shell_TrayWnd',nil);
+ hTrayNotifyWnd := FindWindowEx(hShellTrayWnd,0,'TrayNotifyWnd',nil);
+ hSysPager := FindWindowEx(hTrayNotifyWnd,0,'SysPager',nil);
+ if (hSysPager <> 0) then
+ hToolbarWindow32 := FindWindowEx(hSysPager,0,'ToolbarWindow32',nil)
+ else
+ hToolbarWindow32 := FindWindowEx(hTrayNotifyWnd,0,'ToolbarWindow32',nil);
+
+ if (hToolbarWindow32 <> 0) then
+ begin
+ GetWindowRect(hToolbarWindow32,r);
+ width := r.right - r.left;
+ height := r.bottom - r.top;
+ //从任务栏中间从左到右 MOUSEMOVE一遍，所有图标状态会被更新
+ for x := 1 to width-1 do
+ SendMessage(hToolbarWindow32,WM_MOUSEMOVE,0,MAKELPARAM(x,trunc(height/2)));
+ end;
+end;
+//另一种刷新任务栏图标的方法
+procedure RefreshTaskbarIcon2;
+var
+ TrayWindow : HWnd;
+ WindowRect : TRect;
+ SmallIconWidth : Integer;
+ SmallIconHeight : Integer;
+ CursorPos : TPoint;
+ Row : Integer;
+ Col : Integer;
+begin
+ { 获得任务栏句柄和边框}
+ TrayWindow := FindWindowEx(FindWindow('Shell_TrayWnd',NIL),0,'TrayNotifyWnd',NIL);
+ if not GetWindowRect(TrayWindow,WindowRect) then
+ Exit;
+ { 获得小图标大小}
+ SmallIconWidth := GetSystemMetrics(SM_CXSMICON);
+ SmallIconHeight := GetSystemMetrics(SM_CYSMICON);
+ { 保存当前鼠标位置}
+ GetCursorPos(CursorPos);
+ { 使鼠标快速划过每个图标 }
+ with WindowRect do
+ begin
+ for Row := 0 to (Bottom - Top) DIV SmallIconHeight do
+ begin
+ for Col := 0 to (Right - Left) DIV SmallIconWidth do
+ begin
+ SetCursorPos(Left + Col * SmallIconWidth, Top + Row * SmallIconHeight);
+ Sleep(10); //发现这个地方参数为 0 的时候，有时候是不够的
+ end;
+ end;
+ end;
+ {恢复鼠标位置}
+ SetCursorPos(CursorPos.X,CursorPos.Y);
+ { 重画任务栏 }
+ RedrawWindow(TrayWindow,NIL,0,RDW_INVALIDATE OR RDW_ERASE OR RDW_UPDATENOW);
+end;
+
+//------------------------------------------------------------------------------
+//强行关闭操作系统的函数
+//------------------------------------------------------------------------------
+{procedure RebootSystem();
+begin
+ if GetOperatingSystem() = 'Windows NT/2000/XP' then
+ begin
+ Get_Shutdown_Privilege();
+ //调用此函数会出现系统关机提示窗口，并允许用户取消关机动作，去掉就不显示提示窗口
+ //InitiateSystemShutDown(nil, '关机提示', 3, True, False);
+ //ExitWindowsEx(EWX_SHUTDOWN+EWX_FORCE+EWX_POWEROFF+EWX_FORCEIFHUNG,0);
+ ExitWindowsEx(EWX_REBOOT+EWX_FORCE+EWX_POWEROFF+EWX_FORCEIFHUNG, $FFFF);
+ end
+ else
+ begin
+ ExitWindowsEx(EWX_REBOOT+EWX_FORCE+EWX_POWEROFF+EWX_FORCEIFHUNG, $FFFF);
+ end;
+end; }
+//获取操作系统信息
+function GetOperatingSystem(): string;
+var
+ osVerInfo: TOSVersionInfo;
+begin
+ Result:= '';
+ osVerInfo.dwOSVersionInfoSize:= SizeOf(TOSVersionInfo);
+
+ if GetVersionEx(osVerInfo) then
+ case osVerInfo.dwPlatformId of
+ VER_PLATFORM_WIN32_NT:
+ begin
+ Result:= 'Windows NT/2000/XP'
+ end;
+ VER_PLATFORM_WIN32_WINDOWS:
+ begin
+ Result := 'Windows 95/98/98SE/Me';
+ end;
+ end;
+end;
+//获得用户关机特权，仅对Windows NT/2000/XP
+{procedure Get_Shutdown_Privilege();
+var
+ rl: Cardinal;
+ hToken: Cardinal;
+ tkp: TOKEN_PRIVILEGES;
+begin
+ OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken);
+
+ if LookupPrivilegeValue(nil, 'SeShutdownPrivilege', tkp.Privileges[0].Luid) then
+ begin
+ tkp.Privileges[0].Attributes:= SE_PRIVILEGE_ENABLED;
+ tkp.PrivilegeCount:= 1;
+ AdjustTokenPrivileges(hToken, False, tkp, 0, nil, rl);
+ end;
+end; }
+
+//----------------------------------------------------------------------------//
+// 根据程序名称获取 HWND的方法 //
+// 1.GetHWndByPID()获取PID；2.GetHwndByAppName()获取HWND //
+//----------------------------------------------------------------------------//
+//根据 ProcessId获取进程的窗口句柄如下：
+//1.通过EnumWindows枚举所有窗口
+//2.使用GetWindowThreadProcessID，通过窗口句柄获取进程ID
+//3.比较获取的进程ID与当前已知的进程ID，判断是否为需要的窗口
+//跟据ProcessId获取进程的窗口句柄
+function GetHWndByPID(const hPID: THandle): THandle;
+ type
+ PEnumInfo = ^TEnumInfo;
+ TEnumInfo = record
+ ProcessID: DWORD;
+ HWND: THandle;
+ end;
+
+ function EnumWindowsProc(Wnd: DWORD; var EI: TEnumInfo): Bool; stdcall;
+ var
+ PID: DWORD;
+ begin
+ GetWindowThreadProcessID(Wnd, @PID);
+ Result := (PID <> EI.ProcessID) or
+ (not IsWindowVisible(WND)) or
+ (not IsWindowEnabled(WND));
+
+ if not Result then EI.HWND := WND;
+ end;
+
+ function FindMainWindow(PID: DWORD): DWORD;
+ var
+ EI: TEnumInfo;
+ begin
+ EI.ProcessID := PID;
+ EI.HWND := 0;
+ EnumWindows(@EnumWindowsProc, Integer(@EI));
+ Result := EI.HWND;
+ end;
+begin
+ if hPID<>0 then
+ Result:=FindMainWindow(hPID)
+ else
+ Result:=0;
+end;
+
+//-----------------------------------------------------------------------------
+//根据 AppName获取程序HWND
+//入参 = '应用程序名.exe'
+//返回 = 程序句柄
+//-----------------------------------------------------------------------------
+function GetHwndByAppName(const AppName: String): THandle;
+var
+ pName : string; //进程名
+ hSnapshot : THandle; //进程快照句柄
+ tPE : TProcessEntry32; //进程入口的结构体信息
+ flag : BOOL;
+begin
+ Result := 0;
+ hSnapshot := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS,0); //创建一个进程快照
+ tPE.dwSize:= Sizeof(tPE);
+ flag := Process32First(hSnapshot, tPE); //得到系统中第一个进程
+ //循环例举
+ while flag do begin
+ pName := tPE.szExeFile;
+ if(pName = AppName) then
+ Result := GetHWndByPID(tPE.th32ProcessID);
+ flag := Process32Next(hSnapshot, tPE);
+ end;
+ CloseHandle(hSnapshot); // 释放快照句柄
+end;
+
+
+//-----------------------------------------------------------------------------
+//封装的动态Dll函数调用方法
+//CallFunc('user32.dll', 'MessageBoxA', [0, 'hello world', 'title', MB_OK]);
+//CallFunc('user32.dll', 'MessageBeep', []);
+//CallFunc('kernel32.dll', 'Sleep', [1000]);
+//-----------------------------------------------------------------------------
+function CallFunc(dllname, funcname: string; const param: array of const): DWORD;
+var
+ hLib: THandle;
+ pFunc: Pointer;
+ intSize: Integer;
+begin
+ Result := 0;
+
+ hLib := LoadLibrary(PChar(dllname));
+ if hLib <> 0 then
+ begin
+ pFunc := GetProcAddress(hLib, PChar(funcname));
+ if pFunc <> nil then
+ begin
+ // 获取参数大小
+ intSize := Length(param);
+
+ // 自动完成函数调用, asm实现
+ asm
+ push ecx
+ push esi
+
+ mov ecx, intSize; // 参数的个数
+ mov esi, param
+
+ test ecx, ecx // 判断是否有参数
+ je @call // 如果没有参数则跳转到函数调用处
+
+ @again:
+ dec ecx
+ push dword ptr [esi + ecx * 8] // 循环把参数压入堆栈
+ cmp ecx, 0
+ jnz @again // 一直循环到 ecx 为0
+
+ @call:
+ call pFunc // 调用函数
+ mov @Result, eax // 返回值
+
+ pop esi
+ pop ecx
+ end;
+ end;
+
+ FreeLibrary(hLib);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 调用windows系统 ping 测试网络是否通畅
+// 包含文件 Winsock
+// 入参：IP地址
+// 返回：false or true
+//------------------------------------------------------------------------------
+function PingHost(HostIP: String): Boolean;
+type
+ PIPOptionInformation = ^TIPOptionInformation;
+ TIPOptionInformation = packed record
+ TTL:Byte;
+ TOS:Byte;
+ Flags:Byte;
+ OptionsSize:Byte;
+ OptionsData:PChar;
+ end;
+
+ PIcmpEchoReply= ^TIcmpEchoReply;
+ TIcmpEchoReply = packed record
+ Address: DWORD;
+ Status:DWORD;
+ RTT:DWORD;
+ DataSize:Word;
+ Reserved:Word;
+ Data:Pointer;
+ Options:TIPOptionInformation;
+ end;
+ TIcmpCreateFile = function:THandle;stdcall;
+ TIcmpCloseHandle= function(IcmpHandle:THandle):Boolean;stdcall;
+ TIcmpSendEcho=function(IcmpHandle:THandle;
+ DestinationAddress: DWORD;
+ RequestData: Pointer;
+ RequestSize: Word;
+ RequestOptions: PIPOptionInformation;
+ ReplyBuffer: Pointer;
+ ReplySize: DWord;
+ Timeout: DWord
+ ):DWord;stdcall;
+var
+ hICMP:THandle;
+ hICMPdll:THandle;
+ IcmpCreateFile:TIcmpCreateFile;
+ IcmpCloseHandle:TIcmpCloseHandle;
+ IcmpSendEcho:TIcmpSendEcho;
+ pIPE:PIcmpEchoReply;// ICMP Echo reply buffer
+ FIPAddress:DWORD;
+ FSize:DWORD;
+ FTimeOut:DWORD;
+ BufferSize:DWORD;
+ pReqData,pRevData:PChar;
+ MyString:string;
+begin
+ Result:=False;
+ hICMPdll:=LoadLibrary('icmp.dll');
+ if hICMPdll=0 then exit;
+
+ @ICMPCreateFile:=GetProcAddress(hICMPdll,'IcmpCreateFile');
+ @IcmpCloseHandle:=GetProcAddress(hICMPdll,'IcmpCloseHandle');
+ @IcmpSendEcho:=GetProcAddress(hICMPdll, 'IcmpSendEcho');
+ hICMP := IcmpCreateFile;
+ if (hICMP=INVALID_HANDLE_VALUE) then exit;
+ FIPAddress:=inet_addr(PChar(HostIP));
+ MyString := 'Hello,World'; //send data buffer
+ pReqData:=PChar(MyString);
+
+ FSize:=40; //receive data buffer
+ BufferSize:=SizeOf(TICMPEchoReply)+FSize;
+ GetMem(pIPE,BufferSize);
+ FillChar(pIPE^,SizeOf(pIPE^), 0);
+ GetMem(pRevData,FSize);
+ pIPE^.Data:=pRevData;
+ FTimeOut:=500;
+ try
+ Result:=IcmpSendEcho(hICMP,
+ FIPAddress,
+ pReqData,
+ Length(MyString),
+ nil,
+ pIPE,
+ BufferSize,
+ FTimeOut)>0;
+ finally
+ IcmpCloseHandle(hICMP);
+ FreeLibrary(hICMPdll);
+ FreeMem(pRevData);
+ FreeMem(pIPE);
+ end;
+end;
+
+//------------------------------------------------------------------------------
+// 描述：秒转时间字符串
+// 入参：Integer-秒
+// 返回：String-HH:MM:SS格式字符串
+//------------------------------------------------------------------------------
+function SecondToTime(sec:Integer):String;
+begin
+ Result := TimeToStr(sec/86400);
+end;
+
+// 描述：秒转换成TDateTIme格式
+function SecondToTime1(second: Word): TDateTime;
+var
+ Hour, Min, Sec: Word;
+begin
+ Hour := second div 3600;
+ Min := (second div 60) mod 60;
+ Sec := second mod 60;
+ Result := EncodeTime(Hour, Min, Sec, 0);
+end;
+
+//------------------------------------------------------------------------------
+// 扩充DateUtils库，增加北京时间转Int64时间格式，注意减去时区
+// 说明：
+{uses DateUtils;
+ DateTimeToUnix(Now)可以转换到unix时间，但是注意的是，它得到的时间
+ 比c语言中time()得到的时间大了8*60*60
+ 因为Now是当前时区的时间，c语言中time()是按格林威治时间计算的，
+ 北京时间比格林威治时间多了8小时
+ DateTimeToUnix(Now)-8*60*60 就和c语言中time()得到的一样了}
+//------------------------------------------------------------------------------
+// 使用示例：DateTimeToUnixPro(VarToDateTime(edit1.Text))
+function DateTimeToUnixPro(const AValue: TDateTime): Int64;
+begin
+ Result := DateTimeToUnix(AValue)- 8*60*60 ;
+end;
+
+function UnixToDateTimePro(const AValue: Int64): TDateTime;
+begin
+ Result := UnixToDateTime(floor(AValue/1000) + 8*60*60);
+end;
+
+//------------------------------------------------------------------------------
+// 科学计数法与浮点型数字互转，采用字符串输入输出
+// uses SysUtils
+//
+// eg: '-1.4857E-02' --> '-0.014857'
+//------------------------------------------------------------------------------
+//科学计数转浮点型，'-1.4857E-02' --> '-0.014857'
+function ExpToFloat(s:String):String;
+var
+ f : Extended;
+begin
+ f := StrToFloatDef(s,0);
+ Result := FloatToStr(f);
+end;
+//浮点型转科学计数，'-0.014857' --> '-1.4857E-02'
+function FloatToExp(s:String):String;
+var
+ f : Extended;
+begin
+ f := StrToFloatDef(s,0);
+ Result := FloatToStrF(f, ffExponent,7,2);
+end;
+
+//------------------------------------------------------------------------------
+// 将Bool值转成开关字符
+// 入参：bool
+// 返回：开启,关闭字符串
+//------------------------------------------------------------------------------
+function BoolToString1(B: Boolean; UseBoolStrs: Boolean = False): string;
+const
+ cSimpleBoolStrs: array [boolean] of String = ('关闭', '开启');
+begin
+ if UseBoolStrs then
+ begin
+ if Length(TrueBoolStrs) = 0 then
+ begin
+ SetLength(TrueBoolStrs, 1);
+ TrueBoolStrs[0] := '开启';
+ end;
+ if Length(FalseBoolStrs) = 0 then
+ begin
+ SetLength(FalseBoolStrs, 1);
+ FalseBoolStrs[0] := '关闭';
+ end;
+ if B then
+ Result := TrueBoolStrs[0]
+ else
+ Result := FalseBoolStrs[0];
+ end
+ else
+ Result := cSimpleBoolStrs[B];
+end;
+
+//------------------------------------------------------------------------------
+// 将Bool值转成开关字符
+// 入参：bool
+// 返回：开,关字符串
+//------------------------------------------------------------------------------
+function BoolToString3(B: Boolean; UseBoolStrs: Boolean = False): string;
+const
+ cSimpleBoolStrs: array [boolean] of String = ('关', '开');
+begin
+ if UseBoolStrs then
+ begin
+ if Length(TrueBoolStrs) = 0 then
+ begin
+ SetLength(TrueBoolStrs, 1);
+ TrueBoolStrs[0] := '开';
+ end;
+ if Length(FalseBoolStrs) = 0 then
+ begin
+ SetLength(FalseBoolStrs, 1);
+ FalseBoolStrs[0] := '关';
+ end;
+ if B then
+ Result := TrueBoolStrs[0]
+ else
+ Result := FalseBoolStrs[0];
+ end
+ else
+ Result := cSimpleBoolStrs[B];
+end;
+
+//------------------------------------------------------------------------------
+// 将Bool值转成开关字符
+// 入参：bool
+// 返回：0,1字符串
+//------------------------------------------------------------------------------
+function BoolToString2(B: Boolean; UseBoolStrs: Boolean = False): string;
+const
+ cSimpleBoolStrs: array [boolean] of String = ('0', '1');
+begin
+ if UseBoolStrs then
+ begin
+ if Length(TrueBoolStrs) = 0 then
+ begin
+ SetLength(TrueBoolStrs, 1);
+ TrueBoolStrs[0] := '1';
+ end;
+ if Length(FalseBoolStrs) = 0 then
+ begin
+ SetLength(FalseBoolStrs, 1);
+ FalseBoolStrs[0] := '0';
+ end;
+ if B then
+ Result := TrueBoolStrs[0]
+ else
+ Result := FalseBoolStrs[0];
+ end
+ else
+ Result := cSimpleBoolStrs[B];
+end;
+
+function BoolToString4(B: Boolean; UseBoolStrs: Boolean = False): string;
+const
+ cSimpleBoolStrs: array [boolean] of String = ('false', 'true');
+begin
+ if UseBoolStrs then
+ begin
+ if Length(TrueBoolStrs) = 0 then
+ begin
+ SetLength(TrueBoolStrs, 1);
+ TrueBoolStrs[0] := DefaultTrueBoolStr;
+ end;
+ if Length(FalseBoolStrs) = 0 then
+ begin
+ SetLength(FalseBoolStrs, 1);
+ FalseBoolStrs[0] := DefaultFalseBoolStr;
+ end;
+ if B then
+ Result := TrueBoolStrs[0]
+ else
+ Result := FalseBoolStrs[0];
+ end
+ else
+ Result := cSimpleBoolStrs[B];
+end;
+
+//------------------------------------------------------------------------
+// 整形转为布尔值
+// 输入：integer
+// 输出：True/False
+// 说明：如果AValue不等于0，则Result为True，否则为False。
+//------------------------------------------------------------------------
+function IntToBool(AValue: Integer): Boolean;
+begin
+ Result := AValue <> 0; // 如果AValue不等于0，则Result为True，否则为False。
+end;
+
+//------------------------------------------------------------------------
+// 线性插值算法
+// 输入：（x0、y0)(x1、y1)，及需要插值的目标点x的值
+// 输出：x对应的插值y值
+// 说明：该函数的实现原理是根据线性插值的公式，计算目标点x对应的y值。
+// 函数首先计算出目标点x在数据点x0和x1之间的位置占比，即(x - x0) / (x1 - x0)，
+// 然后将该比例乘以y1 - y0，并加上y0，即可得到目标点x对应的插值y值。
+//------------------------------------------------------------------------
+function LinearInterpolation(x0, y0, x1, y1, x: Double): Double;
+begin
+ Result := y0 + (y1 - y0) * (x - x0) / (x1 - x0);
+end;
+
+//------------------------------------------------------------------------------
+// 拉格朗日插值算法
+// 入参：x：表示给定的一组 x 坐标，是一个实数数组。
+// y：表示给定的一组 y 坐标，也是一个实数数组，与 x 数组一一对应。
+// n：表示 x 和 y 数组中的数据点个数。
+// xi：表示要求解的 x 坐标，即要求在 x 轴上找到与之对应的 y 坐标。
+// 返回值：返回 xi 对应的 y 坐标。
+// 函数实现：定了两个循环变量 i 和 j，用于遍历 x 和 y 数组。然后在外层循环中，
+// 遍历每个数据点 i，计算对应的 Lagrange 插值多项式 L，将每个数据点
+// Lagrange 多项式 L 与对应的 y 坐标相乘，并求和得到 p。
+// 最后返回 p，即为所求的 xi 对应的 y 坐标。
+//------------------------------------------------------------------------------
+function LagrangeInterpolation(x, y: array of Double; n: Integer; xi: Double): Double;
+var
+ i, j: Integer;
+ p, L: Double;
+begin
+ p := 0.0;
+ for i := 0 to n do
+ begin
+ L := 1.0;
+ for j := 0 to n do
+ if j <> i then
+ L := L * (xi - x[j]) / (x[i] - x[j]);
+ p := p + y[i] * L;
+ end;
+ Result := p;
+end;
+
+//------------------------------------------------------------------------------
+// 牛顿插值算法
+// 入参：x：表示给定的一组 x 坐标，是一个实数数组。
+// fx：表示给定的一组 y 坐标，也是一个实数数组，与 x 数组一一对应。
+// n：表示 x 和 y 数组中的数据点个数。
+// t：表示要求解的 x 坐标，即要求在 x 轴上找到与之对应的 y 坐标。
+// 返回值：返回 t 对应的 y 坐标。
+//------------------------------------------------------------------------------
+function NewtonInterpolation(x, fx: array of Double; n: Integer; t: Double): Double;
+var
+ i, j: Integer;
+ c: array of Double;
+ sum: Double;
+begin
+ SetLength(c, n);
+ for i := 0 to n - 1 do
+ c[i] := fx[i];
+ for i := 1 to n - 1 do
+ begin
+ for j := n - 1 downto i do
+ c[j] := (c[j] - c[j - 1]) / (x[j] - x[j - i]);
+ end;
+ sum := c[n - 1];
+ for i := n - 2 downto 0 do
+ begin
+ sum := c[i] + (t - x[i]) * sum;
+ end;
+ Result := sum;
+end;
+
+//------------------------------------------------------------------------------
+// 最小二乘法插值算法
+// 入参：数组 x 和 y
+// 数组长度 n
+// 参数 t表示要插值的位置
+// 返回：插值结果
+// 公式：f(t) = a * t + b + (y[i] - a * x[i] - b) * sum[(x[i] - t)^2] / sum[(x[i] - t)^2]
+// 解释：其中，a 和 b 是最小二乘法的系数，y[i] 和 x[i] 分别是输入数组的第 i 个
+// 元素的值。sum[] 表示求和符号。函数通过计算 a 和 b，然后计算 f(t) 来获得插值结果。
+//------------------------------------------------------------------------------
+function LeastSquaresInterpolation(x, y: array of Double; n: Integer; t: Double): Double;
+ function dot2(a, b: array of Double): Double;
+ var
+ i: Integer;
+ begin
+ Result := 0;
+ for i := 0 to Length(a) - 1 do
+ Result := Result + a[i] * b[i];
+ end;
+ function dot1(a: array of Double): Double;
+ begin
+ Result := dot2(a, a);
+ end;
+var
+ i : Integer;
+ a, b, c, d, s, ss: Double;
+begin
+ if n < 2 then
+ begin
+ Result := 0;
+ Exit;
+ end;
+
+ s := 0;
+ ss := 0;
+ for i := 0 to n - 1 do
+ begin
+ s := s + y[i];
+ ss := ss + sqr(y[i]);
+ end;
+
+ a := (n * dot2(x, y) - dot1(x) * s) / (n * dot2(x, x) - sqr(dot1(x)));
+ b := (s - a * dot1(x)) / n;
+
+ c := 0;
+ d := 0;
+ for i := 0 to n - 1 do
+ begin
+ c := c + (y[i] - a * x[i] - b) * sqr(x[i] - t);
+ d := d + sqr(x[i] - t);
+ end;
+
+ Result := a * t + b + c / d;
+end;
+
+//------------------------------------------------------------------------
+// 贝叶斯插值算法
+// 入参：x和y是已知的数据点，xi是插值的位置，sigma是高斯核函数的带宽参数
+// 输出：
+// 说明：该算法使用高斯核函数来对输入数据进行加权，以便生成插值结果。其中，
+// GaussianKernel()计算两点之间的高斯核函数值，BayesianInterpolation()
+// 计算加权平均值并返回插值结果。
+//------------------------------------------------------------------------
+function BayesianInterpolation(x,y: array of Double; xi: Double; sigma: Double): Double;
+ function GaussianKernel(x, xi, sigma: Double): Double;
+ begin
+ GaussianKernel := exp(-(x - xi) * (x - xi) / (2 * sigma * sigma));
+ end;
+var
+ n, i: Integer;
+ k, W, Wsum, yfit: Double;
+begin
+ n := Length(x);
+ Wsum := 0;
+ yfit := 0;
+ for i := 0 to n - 1 do
+ begin
+ k := GaussianKernel(x[i], xi, sigma);
+ W := k / sigma;
+ Wsum := Wsum + W;
+ yfit := yfit + W * y[i];
+ end;
+ BayesianInterpolation := yfit / Wsum;
+end;
+
+
+//------------------------------------------------------------------------------
+// 获取13位Int64格式毫秒
+// 入参：当前时间-1970-1-1 00:00:00
+// 返回：Int64格式毫秒
+//------------------------------------------------------------------------------
+function GetTimeStampMilliseconds:string;
+var
+ SysTime:TsystemTime;
+ timen,time2:TDateTime;
+ ss2,ss3:int64;
+ str2:string;
+
+begin
+ GetLocalTime(SysTime);
+ timen:= SystemTimeToDateTime(SysTime);
+ time2 := EncodeDateTime( 1970, 1, 1, 0, 0, 0, 0 );
+
+ ss2 := 28800000;
+ ss3 := MilliSecondsBetween( timen, time2 );
+ ss3 :=ss3- ss2;
+
+ str2 := IntToStr(ss3);
+ result:=str2;
+end;
+
+function GetMillisecondTimeStamp: Int64;
+var
+ st: TDateTime;
+begin
+ st := EncodeDateTime( 1970, 1, 1, 0, 0, 0, 0 );
+ Result := MilliSecondsBetween( Now, st )-8*60*60*1000;
+end;
+
+//交换16进制数的高低位
+// ABCD--> CDAB
+function SwapHighLowWord(Value: Word): Word;
+begin
+ // 交换高低位
+ Result := (Value and $FF) shl 8 or (Value and $FF00) shr 8;
+end;
+
+end.
+
--
Gitblit v1.9.3