Delphi:公共运行时间库单元

Communal.pas

{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎} 
{▎                                                                          ▎} 
{▎   大家都是程序员 没有必要重复一些无聊的事情 我的这些函数能给大家带来方便 ▎}
{▎     如果觉得还一般 请关注 WWW.cdsunco.com/www.ccemove.com  QQ:35013354   ▎}
{▎                            系统公用函数及过程                            ▎} 
{▎                                                                          ▎} 
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎} 
{▎ 软件名称：  开发包基础库                                                 ▎} 
{▎ 单元名称：  公共运行时间库单元                                           ▎} 
{▎ 单元版本：  V1.0                                                         ▎} 
{▎ 备    注：  该单元定义了组件包的基础类库                                 ▎} 
{▎ 开发平台：  PWin98SE + Delphi 6.0                                        ▎} 
{▎ 兼容测试：  PWin9X/2000/XP + Delphi  6.0                                 ▎} 
{▎ 本 地 化：  该单元中的字符串均符合本地化处理方式                         ▎} 
{▎ 更新记录：  2002.07.03 V2.0                                              ▎} 
{▎                 整理单元，重设版本号                                     ▎} 
{▎             2002.03.17 V0.02                                             ▎} 
{▎                 新增部分函数，并部分修改                                 ▎} 
{▎             2002.01.30 V0.01                                             ▎} 
{▎                 创建单元（整理而来）                                     ▎} 
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎} 
{▎       ①:  扩展的字符串操作函数                                          ▎} 
{▎       ②:  扩展的日期时间操作函数                                        ▎} 
{▎       ③:  扩展的位操作函数                                              ▎} 
{▎       ④:  扩展的文件及目录操作函数                                      ▎} 
{▎       ⑤:  扩展的对话框函数                                              ▎} 
{▎       ⑥:  系统功能函数                                                  ▎} 
{▎       ⑦:  硬件功能函数                                                  ▎} 
{▎       ⑧:  网络功能函数                                                  ▎} 
{▎       ⑨:  汉字拼音函数及过程                                            ▎} 
{▎       ⑩:  数据库功能函数                                                ▎} 
{▎       ⑾:  进制功能函数                                                  ▎} 
{▎       ⑿:  其它功能函数                                                  ▎} 
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎} 

unit Communal; 
{* |<PRE> 
|</PRE>} 

interface 

{$I CnPack.inc} 


uses 
 Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
 FileCtrl, ShellAPI, CommDlg, MMSystem, WinSock, IniFiles, DBTables, BDE, 
 StdCtrls, ComObj, ADODB, Imm, DbCtrls, Db, Registry; 

const 

 // 公共信息 
{$IFDEF GB2312} 
 SCnInformation = '提示'; 
 SCnWarning = '警告'; 
 SCnError = '错误'; 
{$ELSE} 
 SCnInformation = 'Information'; 
 SCnWarning = 'Warning'; 
 SCnError = 'Error'; 
{$ENDIF} 

 C1=52845; //字符串加密算法的公匙 
 C2=22719; //字符串加密算法的公匙 

resourcestring 

{$IFDEF GB2312} 
 SUnknowError = '未知错误'; 
 SErrorCode = '错误代码：'; 
{$ELSE} 
 SUnknowError = 'Unknow error'; 
 SErrorCode = 'Error code:'; 
{$ENDIF} 

type 
  EDBUpdateErr = class(Exception);//修改表结构时触发的错误句柄 

 

//▎============================================================▎// 
//▎================① 扩展的字符串操作函数  ===================▎// 
//▎============================================================▎// 

//从文件中返回Ado连接字串。 
function GetConnectionString(DataBaseName:string):string; 
//返回服务器的机器名称. 
function GetRemoteServerName:string; 

function InStr(const sShort: string; const sLong: string): Boolean;     {测试通过} 
{* 判断s1是否包含在s2中} 

function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;  {测试通过} 
{* 扩展整数转字符串函数  Example:   IntToStrEx(1,5,'0');   返回："00001"} 

function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;  {测试通过} 
{* 带分隔符的整数－字符转换} 

function ByteToBin(Value: Byte): string; {测试通过} 
{* 字节转二进制串} 

function StrRight(Str: string; Len: Integer): string;  {测试通过} 
{* 返回字符串右边的字符   Examples: StrRight('ABCEDFG',3);   返回:'DFG' } 

function StrLeft(Str: string; Len: Integer): string; {测试通过} 
{* 返回字符串左边的字符} 

function Spc(Len: Integer): string;  {测试通过} 
{* 返回空格串} 

function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string;  {测试通过} 
{* 返回将指定字符s1用字符串s2替换后的字符串，可支持大小写敏感由CaseSensitive操作} 
{example: replace('We know what we want','we','I',false) = 'I Know what I want'} 

function Replicate(pcChar:Char; piCount:integer):string; 
{在一个字符串中查找某个字符串的位置} 

function StrNum(ShortStr:string;LongString:string):Integer;     {测试通过} 
{* 返回某个字符串中某个字符串中出现的次数} 

function FindStr(ShortStr:String;LongStrIng:String):Integer;     {测试通过} 
{* 返回某个字符串中查找某个字符串的位置} 

function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String;     {测试通过} 
{* 返回从位置BeginPlace开始切取长度为CatLeng字符串} 

function LeftStr(psInput:String; CutLeng:Integer):String;     {测试通过} 
{* 返回从左边第一为开始切取 CutLeng长度的字符串} 

function RightStr(psInput:String; CutLeng:Integer):String;       {测试通过} 
{* 返回从右边第一为开始切取 CutLeng长度的字符串} 

function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;        {测试通过} 
{* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串} 

function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;       {测试通过} 
{* 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串} 

function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;        {测试通过} 
{* 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串} 

function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String;        {测试通过} 
{* 返回替换后字符串[替换单个字符] Examples: ChrTran('abCdEgdlkh','d','#')； 返回'abC#Eg#lkh'} 

function StrTran(psInput:String; psSearch:String; psTranWith:String):String;        {测试通过} 
{* 返回替换后字符串[替换字符串] Examples: StrTran('aruyfbn','ruy','=====');； 返回'a=====fbn'} 

function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String; 
{ *返回替换后字符串[替换字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345')；返回'AB12345GHI'} 

procedure SwapStr(var s1, s2: string);  {测试通过} 
{* 交换字串} 

function LinesToStr(const Lines: string): string;   {测试通过} 
{* 多行文本转单行（换行符转'\n'）} 

function StrToLines(const Str: string): string;    {测试通过} 
{* 单行文本转多行（'\n'转换行符）} 

function Encrypt(const S: String; Key: Word): String; 
{* 字符串加密函数} 

function Decrypt(const S: String; Key: Word): String; 
{* 字符串解密函数} 

function varIIF(aTest: Boolean; TrueValue, FalseValue: Variant): Variant; 
function varToStr(const V: Variant): string; 
{* VarIIF及VartoStr为变体函数} 

function IsDigital(Value: string): boolean; 
{功能说明：判断string是否全是数字} 

function RandomStr(aLength : Longint) : String; 
{随机字符串函数} 

//▎============================================================▎// 
//▎================② 扩展的日期时间操作函数  =================▎// 
//▎============================================================▎// 

function GetYear(Date: TDate): Integer;   {测试通过} 
{* 取日期年份分量} 
function GetMonth(Date: TDate): Integer;   {测试通过} 
{* 取日期月份分量} 
function GetDay(Date: TDate): Integer;   {测试通过} 
{* 取日期天数分量} 
function GetHour(Time: TTime): Integer;   {测试通过} 
{* 取时间小时分量} 
function GetMinute(Time: TTime): Integer;   {测试通过} 
{* 取时间分钟分量} 
function GetSecond(Time: TTime): Integer;   {测试通过} 
{* 取时间秒分量} 
function GetMSecond(Time: TTime): Integer;   {测试通过} 
{* 取时间毫秒分量} 
function GetMonthLastDay(Cs_Year,Cs_Month:string):string; 
{ *传入年、月，得到该月份最后一天} 
function IsLeapYear( nYear: Integer ): Boolean; 
{*/判断某年是否为闰年} 
function MaxDateTime(const Values: array of TDateTime): TDateTime; 
{//两个日期取较大的日期} 
function MinDateTime(const Values: array of TDateTime): TDateTime; 
{//两个日期取较小的日期} 
function dateBeginOfMonth(D: TDateTime): TDateTime; 
{//得到本月的第一天} 
function DateEndOfMonth(D: TDateTime): TDateTime; 
{//得到本月的最后一天} 
function DateEndOfYear(D: TDateTime): TDateTime; 
{//得到本年的最后一天} 
function DaysBetween(Date1, Date2: TDateTime): integer; 
{//得到两个日期相隔的天数} 

//▎============================================================▎// 
//▎===================③ 扩展的位操作函数  ====================▎// 
//▎============================================================▎// 

type 
 TByteBit = 0..7; 
 {* Byte类型位数范围} 
 TWordBit = 0..15; 
 {* Word类型位数范围} 
 TDWordBit = 0..31; 
 {* DWord类型位数范围} 

procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload; 
{* 设置二进制位} 
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload; 
{* 设置二进制位} 
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload; 
{* 设置二进制位} 

function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload; 
{* 取二进制位} 
function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload; 
{* 取二进制位} 
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload; 
{* 取二进制位} 

//▎============================================================▎// 
//▎=================④扩展的文件及目录操作函数=================▎// 
//▎============================================================▎// 

function MoveFile(const sName, dName: string): Boolean;  {测试通过} 
{* 移动文件、目录，参数为源、目标名} 

procedure FileProperties(const FName: string); {测试通过} 
{* 打开文件属性窗口} 

function OpenDialog(var FileName: string; Title: string; Filter: string; 
 Ext: string): Boolean; 
{* 打开文件框} 

function FormatPath(APath: string; Width: Integer): string; {测试通过} 
{* 缩短显示不下的长路径名} 

function GetRelativePath(Source, Dest: string): string;  {测试通过} 
{* 取两个目录的相对路径,注意串尾不能是'\'字符！} 

procedure RunFile(const FName: string; Handle: THandle = 0; 
 const Param: string = '');   {测试通过} 
{* 运行一个文件} 

function WinExecAndWait32(FileName: string; Visibility: Integer = SW_NORMAL): 
 Integer; {测试通过} 
{* 运行一个文件并等待其结束} 

function AppPath: string; {测试通过} 
{* 应用程序路径} 

function GetWindowsDir: string; {测试通过} 
{* 取Windows系统目录} 

function GetWinTempDir: string;  {测试通过} 
{* 取临时文件目录} 

function AddDirSuffix(Dir: string): string;  {测试通过} 
{* 目录尾加'\'修正} 

function MakePath(Dir: string): string;  {测试通过} 
{* 目录尾加'\'修正} 

function IsFileInUse(FName: string): Boolean;   {测试通过} 
{* 判断文件是否正在使用} 

function GetFileSize(FileName: string): Integer;   {测试通过} 
{* 取文件长度} 

function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime: 
 TFileTime): Boolean;     {测试通过} 
{* 设置文件时间 Example:    FileSetDate('c:\Test\Test1.exe',753160662);    } 

function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime: 
 TFileTime): Boolean;     {测试通过} 
{* 取文件时间} 

function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;  {测试通过} 
{* 文件时间转本地时间} 

function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;  {测试通过} 
{* 本地时间转文件时间} 

function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;   {测试通过} 
{* 取得与文件相关的图标，成功则返回True} 

function CreateBakFile(FileName, Ext: string): Boolean;   {测试通过} 
{* 创建备份文件} 

function Deltree(Dir: string): Boolean;    {测试通过} 
{* 删除整个目录} 

function GetDirFiles(Dir: string): Integer;    {测试通过} 
{* 取文件夹文件数} 

type 
 TFindCallBack = procedure(const FileName: string; const Info: TSearchRec; 
   var Abort: Boolean); 
{* 查找指定目录下文件的回调函数} 

procedure FindFile(const Path: string; const FileName: string = '*.*'; 
 Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True); 
{* 查找指定目录下文件} 

procedure FindFileList(Path,Filter:string;FileList:TStrings;ContainSubDir:Boolean); 
{ 功能说明：查找一个路径下的所有文件。 
 参数： path:路径,filter:文件扩展名过滤,FileList:文件列表, ContainSubDir:是否包含子目录} 

function Txtline(const txt: string): integer; 
{* 返回一文本文件的行数} 

function Html2Txt(htmlfilename: string): string; 
{* Html文件转化成文本文件} 

function OpenWith(const FileName: string): Integer;     {测试通过} 
{* 文件打开方式} 

//▎============================================================▎// 
//▎====================⑤扩展的对话框函数======================▎// 
//▎============================================================▎// 

procedure InfoDlg(Mess: string; Caption: string = SCnInformation; Flags: Integer 
 = MB_OK + MB_ICONINFORMATION);  {测试通过} 
{* 显示提示窗口} 

function InfoOk(Mess: string; Caption: string = SCnInformation): Boolean;   {测试通过} 
{* 显示提示确认窗口} 

procedure ErrorDlg(Mess: string; Caption: string = SCnError);    {测试通过} 
{* 显示错误窗口} 

procedure WarningDlg(Mess: string; Caption: string = SCnWarning);  {测试通过} 
{* 显示警告窗口} 

function QueryDlg(Mess: string; Caption: string = SCnInformation): Boolean;   {测试通过} 
{* 显示查询是否窗口} 

procedure SetWindowAnimate(Sender : TForm; IsSetAni : bool); 

//▎============================================================▎// 
//▎=====================⑥系统功能函数=========================▎// 
//▎============================================================▎// 

procedure MoveMouseIntoControl(AWinControl: TControl);   {测试通过} 
{* 移动鼠标到控件} 

function DynamicResolution(x, y: WORD): Boolean;    {测试通过} 
{* 动态设置分辨率} 

procedure StayOnTop(Handle: HWND; OnTop: Boolean);   {测试通过} 
{* 窗口最上方显示} 

procedure SetHidden(Hide: Boolean);    {测试通过} 
{* 设置程序是否出现在任务栏} 

procedure SetTaskBarVisible(Visible: Boolean);    {测试通过} 
{* 设置任务栏是否可见} 

procedure SetDesktopVisible(Visible: Boolean);    {测试通过} 
{* 设置桌面是否可见} 

procedure BeginWait;    {测试通过} 
{* 显示等待光标} 

procedure EndWait;    {测试通过} 
{* 结束等待光标} 

function CheckWindows9598NT: string;  {测试通过} 
{* 检测是否Win95/98/NT平台} 

function GetOSInfo : String;   {测试通过} 
{* 取得当前操作平台是 Windows 95/98 还是NT} 

function GetCurrentUserName : string; 
{*获取当前Windows登录名的用户} 

function GetRegistryOrg_User(UserKeyType:string):string; 
{*获取当前注册的单位及用户名称} 

function GetSysVersion:string; 
{*//获取操作系统版本号} 

function WinBootMode:string; 
{//Windows启动模式} 

type 
  PShutType = (UPowerOff, UShutdown, UReboot, ULogOff, USuspend, UHibernate); 
procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean); 
{//Windows ShutDown等} 

//▎============================================================▎// 
//▎=====================⑦硬件功能函数=========================▎// 
//▎============================================================▎// 

function GetClientGUID:string; 
{ 功能描述：在本机上得到一个GUID.去掉两端的大括号和中间的横线 
 返回值：去掉两端的大括号和中间的横线的一个GUID 
 适用范围：windows 
} 

function SoundCardExist: Boolean;       {测试通过} 
{* 声卡是否存在} 

function GetDiskSerial(DiskChar: Char): string; 
{* 获取磁盘序列号} 

function DiskReady(Root: string) : Boolean; 
{*检查磁盘准备是否就绪} 

procedure WritePortB( wPort : Word; bValue : Byte ); 
{* 写串口} 

function ReadPortB( wPort : Word ) : Byte; 
{*读串口} 

function CPUSpeed: Double; 
{* 获知当前机器CPU的速率（MHz）} 

type 
TCPUID = array[1..4] of Longint; 
function GetCPUID : TCPUID; assembler; register; 
{*获取CPU的标识ID号*} 

function GetMemoryTotalPhys : Dword; 
{*获取计算机的物理内存} 

type 
  TDriveState = (DSNODISK, DSUNFORMATTEDDISK, DSEMPTYDISK, DSDISK_WITHFILES); 
function DriveState (driveletter: Char) : TDriveState; 
{* 检查驱动器A中磁盘是否有效} 

//▎============================================================▎// 
//▎=====================⑧网络功能函数=========================▎// 
//▎============================================================▎// 
function GetComputerName:string; 
{* 获取网络计算机名称} 
function GetHostIP:string; 
{* 获取计算机的IP地址} 
function NetUserChangePassword(Domain:PWideChar; UserName:PWideChar; OldPassword:PWideChar; NewPassword:PWideChar): LongInt; stdcall; external 'netapi32.dll' name 'NetUserChangePassword'; 
{* // 运行平台：Windows NT/2000/XP 
{* // Windows 95/98/Me平台：可以用该函数修改用户的Windows登录密码} 


//▎============================================================▎// 
//▎=====================⑨汉字拼音功能函数=====================▎// 
//▎============================================================▎// 
function GetHzPy(const AHzStr: string): string;       {测试通过} 
{* 取汉字的拼音} 

function HowManyChineseChar(Const s:String):Integer; 
{* 判断一个字符串中有多少各汉字} 

//▎============================================================▎// 
//▎===================⑩数据库功能函数及过程===================▎// 
//▎============================================================▎// 
{function PackDbDbf(Var StatusMsg: String): Boolean;} 
{* 物理删除数据库(Db，Dbf)中的数据[着了删除标记的记录]} 


procedure RepairDb(DbName: string); 
{* 修复Access表} 

function CreateODBCCfgInRegistry(ODBCSourceName:WideString;ServerName, DataBaseDescription:String):boolean; 
{* 通过注册表创建ODBC配置[创建在系统DSN页下]} 

function ADOConnectSysBase(Const Adocon:TadoConnection):boolean; 
{* 用Ado连接SysBase数据库函数} 

function ADOConnectLocalDB(Const Adocon:TadoConnection;Const Dbname,DbServerName:string;ValidateMode:Integer):boolean; 
{* 用Ado连接数据库函数} 

function ADOODBCConnectLocalDB(Const Adocon:TadoConnection;Const Dbname:string;ValidateMode:Integer):boolean; 
{* 用Ado与ODBC共同连接数据库函数} 

function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean; 
{* //建立新表} 

function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string; 
{*//在表中添加字段} 

function KillField(LpFieldName:string):String; 
{* //在表中删除字段} 

function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean; 
{* //修改表结构} 

function GetSQLSentence(LpTableName,LpSQLsentence:string): string; 
{* /修改、添加、删除表结构时的SQL句体} 


//▎============================================================▎// 
//▎======================⑾进制函数及过程======================▎// 
//▎============================================================▎// 

function StrToHex(AStr: string): string; 
{* 字符转化成十六进制} 

function HexToStr(AStr: string): string; 
{* 十六进制转化成字符} 

function TransChar(AChar: Char): Integer; 

//▎============================================================▎// 
//▎=====================⑿其它函数及过程=======================▎// 
//▎============================================================▎// 

function TrimInt(Value, Min, Max: Integer): Integer; overload;    {测试通过} 
{* 输出限制在Min..Max之间} 

function IntToByte(Value: Integer): Byte; overload;   {测试通过} 
{* 输出限制在0..255之间} 

function InBound(Value: Integer; Min, Max: Integer): Boolean;    {测试通过} 
{* 判断整数Value是否在Min和Max之间} 

procedure CnSwap(var A, B: Byte); overload; 
{* 交换两个数} 
procedure CnSwap(var A, B: Integer); overload; 
{* 交换两个数} 
procedure CnSwap(var A, B: Single); overload; 
{* 交换两个数} 
procedure CnSwap(var A, B: Double); overload; 
{* 交换两个数} 

function RectEqu(Rect1, Rect2: TRect): Boolean; 
{* 比较两个Rect是否相等} 

procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer); 
{* 分解一个TRect为左上角坐标x, y和宽度Width、高度Height} 

function EnSize(cx, cy: Integer): TSize; 
{* 返回一个TSize类型} 

function RectWidth(Rect: TRect): Integer; 
{* 计算TRect的宽度} 

function RectHeight(Rect: TRect): Integer; 
{* 计算TRect的高度} 

procedure Delay(const uDelay: DWORD);     {测试通过} 
{* 延时} 

procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);     {Win9X下测试通过} 
{* 只能在Win9X下让喇叭发声} 

procedure ShowLastError;       {测试通过} 
{* 显示Win32 Api运行结果信息} 

function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string; 
{* 将字体Font.Style写入INI文件} 

function readFontStyle(inifile: string): TFontStyles; 
{* 从INI文件中读取字体Font.Style文件} 

//function ReadCursorPos(SourceMemo: TMemo): TPoint; 
function ReadCursorPos(SourceMemo: TMemo): string; 
{* 取得TMemo 控件当前光标的行和列信息到Tpoint中} 

function CanUndo(AMemo: TMemo): Boolean; 
{* 检查Tmemo控件能否Undo} 

procedure Undo(Amemo: Tmemo); 
{*实现Undo功能} 

procedure AutoListDisplay(ACombox:TComboBox); 
{* 实现ComBoBox自动下拉} 

function UpperMoney(small:real):string; 
{* 小写金额转换为大写 } 

function Myrandom(Num: Integer): integer; 
{*利用系统时间产生随机数)} 

procedure OpenIME(ImeName: string); 
{*打开输入法} 

procedure CloseIME; 
{*关闭输入法} 

procedure ToChinese(hWindows: THandle; bChinese: boolean); 
{*打开中文输入法} 

//数据备份 
procedure BackUpData(LpBackDispMessTitle:String); 


implementation  {▎=======函数及过程体开始==========▎} 

//▎============================================================▎// 
//▎==================①扩展的字符串操作函数====================▎// 
//▎============================================================▎// 

// 判断s1是否包含在s2中 
function InStr(const sShort: string; const sLong: string): Boolean; 
var 
 s1, s2: string; 
begin 
 s1 := LowerCase(sShort); 
 s2 := LowerCase(sLong); 
 Result := Pos(s1, s2) > 0; 
end; 

// 扩展整数转字符串函数，参数分别为目标数、长度、填充字符（默认为０） 
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string; 
begin 
 Result := IntToStr(Value); 
 while Length(Result) < Len do 
   Result := FillChar + Result; 
end; 

// 带分隔符的整数－字符转换 
function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string; 
var 
 s: string; 
 i, j: Integer; 
begin 
 s := IntToStr(Value); 
 Result := ''; 
 j := 0; 
 for i := Length(s) downto 1 do 
 begin 
   Result := s[i] + Result; 
   Inc(j); 
   try 
      if ((j mod SpLen) = 0) and (i <> 1) then 
         Result := Sp + Result; 
   except 
      MessageBox(Application.Handle,' IntToStrSp函数的第二个参数值不能为数字0 ！',SCnError,16); 
      exit; 
   end 
 end; 
end; 

// 返回字符串右边的字符 
function StrRight(Str: string; Len: Integer): string; 
begin 
 if Len >= Length(Str) then 
   Result := Str 
 else 
   Result := Copy(Str, Length(Str) - Len + 1, Len); 
end; 

// 返回字符串左边的字符 
function StrLeft(Str: string; Len: Integer): string; 
begin 
 if Len >= Length(Str) then 
   Result := Str 
 else 
   Result := Copy(Str, 1, Len); 
end; 

// 字节转二进制串 
function ByteToBin(Value: Byte): string; 
const 
 V: Byte = 1; 
var 
 i: Integer; 
begin 
 for i := 7 downto 0 do 
   if (V shl i) and Value <> 0 then 
     Result := Result + '1' 
   else 
     Result := Result + '0'; 
end; 

// 返回空格串 
function Spc(Len: Integer): string; 
var 
 i: Integer; 
begin 
 Result := ''; 
 for i := 0 to Len - 1 do 
   Result := Result + ' '; 
end; 

// 返回将指定字符s1用字符串s2替换后的字符串，可支持大小写敏感由CaseSensitive操作} 
function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string; 
var 
  i:integer; 
  s,t:string; 
begin 
  s:=''; 
  t:=str; 
  repeat 
     if casesensitive then 
        i:=pos(s1,t) 
     else 
        i:=pos(lowercase(s1),lowercase(t)); 
        if i>0 then 
           begin 
              s:=s+Copy(t,1,i-1)+s2; 
              t:=Copy(t,i+Length(s1),MaxInt); 
           end 
        else 
           s:=s+t; 
  until i<=0; 
  result:=s; 
end; 

function Replicate(pcChar:Char; piCount:integer):string; 
begin 
Result:=''; 
SetLength(Result,piCount); 
fillChar(Pointer(Result)^,piCount,pcChar) 
end; 

// 返回某个字符串中某个字符串中出现的次数} 
function StrNum(ShortStr:string;LongString:string):Integer;     {测试通过} 
var 
  i:Integer; 
begin 
  i:=0; 
  while pos(ShortStr,LongString)>0 do 
     begin 
        i:=i+1; 
        LongString:=Substr(LongString,(FindStr(ShortStr,LongString))+1,Length(LongString)-FindStr(ShortStr,LongString)) 
     end; 
  Result:=i; 
end; 

// 返回某个字符串中查找某个字符串的位置} 
function FindStr(ShortStr:String;LongStrIng:String):Integer;//在一个字符串中找某个字符的位置 
var 
  locality:integer; 
begin 
  locality:=Pos(ShortStr,LongStrIng); 
  if locality=0 then 
     Result:=0 
  else 
     Result:=locality; 
end; 

// 返回从位置BeginPlace开始切取长度为CatLeng字符串} 
function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String; 
begin 
Result:=Copy(psInput,BeginPlace,CutLeng) 
end; 

// 返回从左边第一为开始切取 CutLeng长度的字符串 
function LeftStr(psInput:String; CutLeng:Integer):String; 
begin 
Result:=Copy(psInput,1,CutLeng) 
end; 

// 返回从左边第一为开始切取 CutLeng长度的字符串 
function RightStr(psInput:String; CutLeng:Integer):String; 
begin 
Result:=Copy(psInput,Length(psInput)-CutLeng+1,CutLeng) 
end; 

{* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串} 
function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; 
begin 
Result:=Replicate(pcPadWith,piWidth-Length(psInput))+psInput 
end; 

{* 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串} 
function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; 
begin 
Result:=psInput+Replicate(pcPadWith,piWidth-Length(psInput)) 
end; 

{* 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串} 
function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; 
var 
liHalf :integer; 
begin 
liHalf:=(piWidth-Length(psInput))div 2; 
Result:=Replicate(pcPadWith,liHalf)+psInput+Replicate(pcPadWith,piWidth-Length(psInput)-liHalf) 
end; 

{* 返回替换后字符串 Examples: ChrTran('abCdEgdlkh','d','#')； 返回'bC#Eg#lkh'} 
function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String; 
var 
i,j:integer; 
begin 
j:=Length(psInput); 
for i:=1 to j do 
 begin 
if psInput[i]=pcSearch then 
psInput[i]:=pcTranWith 
 end; 
Result:=psInput 
end; 

{* 返回替换后字符串 Examples: StrTran('aruyfbn','ruy','====='); 返回'a=====fbn'} 
function StrTran(psInput:String; psSearch:String; psTranWith:String):String; 
var 
liPosition,liLenOfSrch,liLenOfIn:integer; 
begin 
liPosition:=Pos(psSearch,psInput); 
liLenOfSrch:=Length(psSearch); 
liLenOfIn:=Length(psInput); 
while liPosition>0 do 
begin 
psInput:=Copy(psInput,1,liPosition-1) 
+psTranWith 
     +Copy(psInput,liPosition+liLenOfSrch,liLenOfIn); 
liPosition:=Pos(psSearch,psInput) 
end; 
Result:=psInput 
end; 

{ *返回替换后字符串[替换字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345')；返回'AB12345GHI'} 
function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String; 
begin 
Result:=Copy(psInput,1,piBeginPlace-1)+ 
psStuffWith+ 
   Copy(psInput,piBeginPlace+piCount,Length(psInput)) 
end; 

// 交换字串 
procedure SwapStr(var s1, s2: string); 
var 
 tempstr: string; 
begin 
 tempstr := s1; 
 s1 := s2; 
 s2 := tempstr; 
end; 

const 
 csLinesCR = #13#10; 
 csStrCR = '\n'; 

// 多行文本转单行（换行符转'\n'） 
function LinesToStr(const Lines: string): string; 
var 
 i: Integer; 
begin 
 Result := Lines; 
 i := Pos(csLinesCR, Result); 
 while i > 0 do 
 begin 
   system.Delete(Result, i, Length(csLinesCR)); 
   system.insert(csStrCR, Result, i); 
   i := Pos(csLinesCR, Result); 
 end; 
end; 

// 单行文本转多行（'\n'转换行符） 
function StrToLines(const Str: string): string; 
var 
 i: Integer; 
begin 
 Result := Str; 
 i := Pos(csStrCR, Result); 
 while i > 0 do 
 begin 
   system.Delete(Result, i, Length(csStrCR)); 
   system.insert(csLinesCR, Result, i); 
   i := Pos(csStrCR, Result); 
 end; 
end; 

//字符串加密函数 
function Encrypt(const S: String; Key: Word): String; 
var 
  I : Integer; 
begin 
     Result := S; 
     for I := 1 to Length(S) do 
     begin 
        Result[I] := char(byte(S[I]) xor (Key shr 8)); 
        Key := (byte(Result[I]) + Key) * C1 + C2; 
        if Result[I] = Chr(0) then 
           Result[I] := S[I]; 
     end; 
     Result := StrToHex(Result); 
end; 

//字符串解密函数 
function Decrypt(const S: String; Key: Word): String; 
var 
  I: Integer; 
  S1: string; 
begin 
  S1 := HexToStr(S); 
  Result := S1; 
  for I := 1 to Length(S1) do 
  begin 
     if char(byte(S1[I]) xor (Key shr 8)) = Chr(0) then 
        begin 
           Result[I] := S1[I]; 
           Key := (byte(Chr(0)) + Key) * C1 + C2; //保证Key的正确性　　 
        end 
     else 
        begin 
           Result[I] := char(byte(S1[I]) xor (Key shr 8)); 
           Key := (byte(S1[I]) + Key) * C1 + C2; 
        end; 
  end; 
end; 

///VarIIF,VarTostr为变体函数 
function varIIF(aTest: Boolean; TrueValue, FalseValue: Variant): Variant; 
begin 
 if aTest then Result := TrueValue else Result := FalseValue; 
end; 

function varToStr(const V: Variant): string; 
begin 
 case TVarData(v).vType of 
   varSmallInt: Result := IntToStr(TVarData(v).VSmallInt); 
   varInteger: Result := IntToStr(TVarData(v).VInteger); 
   varSingle: Result := FloatToStr(TVarData(v).VSingle); 
   varDouble: Result := FloatToStr(TVarData(v).VDouble); 
   varCurrency: Result := FloatToStr(TVarData(v).VCurrency); 
   varDate: Result := DateToStr(TVarData(v).VDate); 
   varBoolean: Result := varIIf(TVarData(v).VBoolean, 'True', 'False'); 
   varByte: Result := IntToStr(TVarData(v).VByte); 
   varString: Result := StrPas(TVarData(v).VString); 
   varEmpty, 
     varNull, 
     varVariant, 
     varUnknown, 
     varTypeMask, 
     varArray, 
     varByRef, 
     varDispatch, 
     varError: Result := ''; 
 end; 
end; 

{功能说明：判断string是否全是数字} 
function IsDigital(Value: string): boolean; 
var 
 i, j: integer; 
 str: char; 
begin 
 result := true; 
 Value := trim(Value); 
 j := Length(Value); 
 if j = 0 then 
 begin 
   result := false; 
   exit; 
 end; 
 for i := 1 to j do 
 begin 
   str := Value[i]; 
   if not (str in ['0'..'9']) then 
   begin 
     result := false; 
     exit; 
   end; 
 end; 
end; 

{随机字符串函数} 
function RandomStr(aLength : Longint) : String; 
var 
 X : Longint; 
begin 
 if aLength <= 0 then exit; 
 SetLength(Result, aLength); 
 for X:=1 to aLength do 
   Result[X] := Chr(Random(26) + 65); 
end; 

//▎============================================================▎// 
//▎==================②扩展日期时间操作函数====================▎// 
//▎============================================================▎// 

function GetYear(Date: TDate): Integer; 
var 
 y, m, d: WORD; 
begin 
 DecodeDate(Date, y, m, d); 
 Result := y; 
end; 

function GetMonth(Date: TDate): Integer; 
var 
 y, m, d: WORD; 
begin 
 DecodeDate(Date, y, m, d); 
 Result := m; 
end; 

function GetDay(Date: TDate): Integer; 
var 
 y, m, d: WORD; 
begin 
 DecodeDate(Date, y, m, d); 
 Result := d; 
end; 

function GetHour(Time: TTime): Integer; 
var 
 h, m, s, ms: WORD; 
begin 
 DecodeTime(Time, h, m, s, ms); 
 Result := h; 
end; 

function GetMinute(Time: TTime): Integer; 
var 
 h, m, s, ms: WORD; 
begin 
 DecodeTime(Time, h, m, s, ms); 
 Result := m; 
end; 

function GetSecond(Time: TTime): Integer; 
var 
 h, m, s, ms: WORD; 
begin 
 DecodeTime(Time, h, m, s, ms); 
 Result := s; 
end; 

function GetMSecond(Time: TTime): Integer; 
var 
 h, m, s, ms: WORD; 
begin 
 DecodeTime(Time, h, m, s, ms); 
 Result := ms; 
end; 

//传入年、月，得到该月份最后一天 
function GetMonthLastDay(Cs_Year,Cs_Month:string):string; 
Var 
  V_date:Tdate; 
  V_year,V_month,V_day:word; 
begin 
  V_year:=strtoint(Cs_year); 
  V_month:=strtoint(Cs_month); 
  if V_month=12 then 
  begin 
    V_month:=1; 
      inc(V_year); 
  end 
  else 
  inc(V_month); 
V_date:=EncodeDate(V_year,V_month,1); 
V_date:=V_date-1; 
DecodeDate(V_date,V_year,V_month,V_day); 
Result:=DateToStr(EncodeDate(V_year,V_month,V_day)); 
end; 

//判断某年是否为闰年 
function IsLeapYear( nYear: Integer ): Boolean; 
begin 
 Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod 400 = 0)); 
end; 

//两个日期取较大的日期 
function MaxDateTime(const Values: array of TDateTime): TDateTime; 
var 
 I: Cardinal; 
begin 
 Result := Values[0]; 
 for I := 0 to Low(Values) do 
   if Values[I] < Result then Result := Values[I]; 
end; 

//两个日期取较小的日期 
function MinDateTime(const Values: array of TDateTime): TDateTime; 
var 
 I: Cardinal; 
begin 
 Result := Values[0]; 
 for I := 0 to High(Values) do 
   if Values[I] < Result then Result := Values[I]; 
end; 

//得到本月的第一一天 
function dateBeginOfMonth(D: TDateTime): TDateTime; 
var 
 Year, Month, Day: Word; 
begin 
 DecodeDate(D, Year, Month, Day); 
 Result := EncodeDate(Year, Month, 1); 
end; 

//得到本月的最后一天 
function dateEndOfMonth(D: TDateTime): TDateTime; 
var 
 Year, Month, Day: Word; 
begin 
 DecodeDate(D, Year, Month, Day); 
 if Month = 12 then 
 begin 
   Inc(Year); 
   Month := 1; 
 end else 
   Inc(Month); 
 Result := EncodeDate(Year, Month, 1) - 1; 
end; 

//得到本年的最后一天 
function dateEndOfYear(D: TDateTime): TDateTime; 
var 
 Year, Month, Day: Word; 
begin 
 DecodeDate(D, Year, Month, Day); 
 Result := EncodeDate(Year, 12, 31); 
end; 

//得到两个日期相隔的天数 
function DaysBetween(Date1, Date2: TDateTime): integer; 
begin 
 Result := Trunc(Date2) - Trunc(Date1) + 1; 
 if Result < 0 then Result := 0; 
end; 
//▎============================================================▎// 
//▎=====================③位操作函数===========================▎// 
//▎============================================================▎// 

// 设置位 
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); 
begin 
 if IsSet then 
   Value := Value or (1 shl Bit) 
 else 
   Value := Value and not (1 shl Bit); 
end; 

procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); 
begin 
 if IsSet then 
   Value := Value or (1 shl Bit) 
 else 
   Value := Value and not (1 shl Bit); 
end; 

procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); 
begin 
 if IsSet then 
   Value := Value or (1 shl Bit) 
 else 
   Value := Value and not (1 shl Bit); 
end; 

// 取位 
function GetBit(Value: Byte; Bit: TByteBit): Boolean; 
begin 
 Result := Value and (1 shl Bit) <> 0; 
end; 

function GetBit(Value: WORD; Bit: TWordBit): Boolean; 
begin 
 Result := Value and (1 shl Bit) <> 0; 
end; 

function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; 
begin 
 Result := Value and (1 shl Bit) <> 0; 
end; 

//▎============================================================▎// 
//▎=================④扩展的文件及目录操作函数=================▎// 
//▎============================================================▎// 

// 移动文件、目录 
function MoveFile(const sName, dName: string): Boolean; 
var 
 s1, s2: AnsiString; 
 lpFileOp: TSHFileOpStruct; 
begin 
 s1 := PChar(sName) + #0#0; 
 s2 := PChar(dName) + #0#0; 
 with lpFileOp do 
 begin 
   Wnd := Application.Handle; 
   wFunc := FO_MOVE; 
   pFrom := PChar(s1); 
   pTo := PChar(s2); 
   fFlags := FOF_ALLOWUNDO; 
   hNameMappings := nil; 
   lpszProgressTitle := nil; 
   fAnyOperationsAborted := True; 
 end; 
 Result := SHFileOperation(lpFileOp) = 0; 
end; 

// 打开文件属性窗口 
procedure FileProperties(const FName: string); 
var 
 SEI: SHELLEXECUTEINFO; 
begin 
 with SEI do 
 begin 
   cbSize := SizeOf(SEI); 
   fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or 
     SEE_MASK_FLAG_NO_UI; 
   Wnd := Application.Handle; 
   lpVerb := 'properties'; 
   lpFile := PChar(FName); 
   lpParameters := nil; 
   lpDirectory := nil; 
   nShow := 0; 
   hInstApp := 0; 
   lpIDList := nil; 
 end; 
 ShellExecuteEx(@SEI); 
end; 

// 缩短显示不下的长路径名 
function FormatPath(APath: string; Width: Integer): string; 
var 
 SLen: Integer; 
 i, j: Integer; 
 TString: string; 
begin 
 SLen := Length(APath); 
 if (SLen <= Width) or (Width <= 6) then 
 begin 
   Result := APath; 
   Exit 
 end 
 else 
 begin 
   i := SLen; 
   TString := APath; 
   for j := 1 to 2 do 
   begin 
     while (TString[i] <> '\') and (SLen - i < Width - 8) do 
       i := i - 1; 
     i := i - 1; 
   end; 
   for j := SLen - i - 1 downto 0 do 
     TString[Width - j] := TString[SLen - j]; 
   for j := SLen - i to SLen - i + 2 do 
     TString[Width - j] := '.'; 
   Delete(TString, Width + 1, 255); 
   Result := TString; 
 end; 
end; 

// 打开文件框 
function OpenDialog(var FileName: string; Title: string; Filter: string; 
 Ext: string): Boolean; 
var 
 OpenName: TOPENFILENAME; 
 TempFilename, ReturnFile: string; 
begin 
 with OpenName do 
 begin 
   lStructSize := SizeOf(OpenName); 
   hWndOwner := GetModuleHandle(''); 
   Hinstance := SysInit.Hinstance; 
   lpstrFilter := PChar(Filter + #0 + Ext + #0#0); 
   lpstrCustomFilter := ''; 
   nMaxCustFilter := 0; 
   nFilterIndex := 1; 
   nMaxFile := MAX_PATH; 
   SetLength(TempFilename, nMaxFile + 2); 
   lpstrFile := PChar(TempFilename); 
   FillChar(lpstrFile^, MAX_PATH, 0); 
   SetLength(TempFilename, nMaxFile + 2); 
   nMaxFileTitle := MAX_PATH; 
   SetLength(ReturnFile, MAX_PATH + 2); 
   lpstrFileTitle := PChar(ReturnFile); 
   FillChar(lpstrFile^, MAX_PATH, 0); 
   lpstrInitialDir := '.'; 
   lpstrTitle := PChar(Title); 
   Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING; 
   nFileOffset := 0; 
   nFileExtension := 0; 
   lpstrDefExt := PChar(Ext); 
   lCustData := 0; 
   lpfnHook := nil; 
   lpTemplateName := ''; 
 end; 
 Result := GetOpenFileName(OpenName); 
 if Result then 
   FileName := ReturnFile 
 else 
   FileName := ''; 
end; 

// 取两个目录的相对路径,注意串尾不能是'\'字符! 
function GetRelativePath(Source, Dest: string): string; 
 // 比较两路径字符串头部相同串的函数 
 function GetPathComp(s1, s2: string): Integer; 
 begin 
   if Length(s1) > Length(s2) then swapStr(s1, s2); 
   Result := Pos(s1, s2); 
   while (Result = 0) and (Length(s1) > 3) do 
   begin 
     if s1 = '' then Exit; 
     s1 := ExtractFileDir(s1); 
     Result := Pos(s1, s2); 
   end; 
   if Result <> 0 then Result := Length(s1); 
   if Result = 3 then Result := 2; 
   // 修正因ExtractFileDir()处理'c:\'时产生的错误. 
 end; 
 // 取Dest的相对根路径的函数 
 function GetRoot(s: ShortString): string; 
 var 
   i: Integer; 
 begin 
   Result := ''; 
   for i := 1 to Length(s) do 
     if s[i] = '\' then Result := Result + '..\'; 
   if Result = '' then Result := '.\'; 
   // 如果不想处理成".\"的路径格式，可去掉本行 
 end; 

var 
 RelativRoot, RelativSub: string; 
 HeadNum: Integer; 
begin 
 Source := UpperCase(Source); 
 Dest := UpperCase(Dest);              // 比较两路径字符串头部相同串 
 HeadNum := GetPathComp(Source, Dest); // 取Dest的相对根路径 
 RelativRoot := GetRoot(StrRight(Dest, Length(Dest) - HeadNum)); 
 // 取Source的相对子路径 
 RelativSub := StrRight(Source, Length(Source) - HeadNum - 1); 
 // 返回 
 Result := RelativRoot + RelativSub; 
end; 

// 运行一个文件 
procedure RunFile(const FName: string; Handle: THandle; 
 const Param: string); 
begin 
 ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL); 
end; 

// 运行一个文件并等待其结束 
function WinExecAndWait32(FileName: string; Visibility: Integer): Integer; 
var 
 zAppName: array[0..512] of Char; 
 zCurDir: array[0..255] of Char; 
 WorkDir: string; 
 StartupInfo: TStartupInfo; 
 ProcessInfo: TProcessInformation; 
begin 
 StrPCopy(zAppName, FileName); 
 GetDir(0, WorkDir); 
 StrPCopy(zCurDir, WorkDir); 
 FillChar(StartupInfo, SizeOf(StartupInfo), #0); 
 StartupInfo.cb := SizeOf(StartupInfo); 

 StartupInfo.dwFlags := STARTF_USESHOWWINDOW; 
 StartupInfo.wShowWindow := Visibility; 
 if not CreateProcess(nil, 
   zAppName,                           { pointer to command line string } 
   nil,                                { pointer to process security attributes } 
   nil,                                { pointer to thread security attributes } 
   False,                              { handle inheritance flag } 
   CREATE_NEW_CONSOLE or               { creation flags } 
   NORMAL_PRIORITY_CLASS, 
   nil,                                { pointer to new environment block } 
   nil,                                { pointer to current directory name } 
   StartupInfo,                        { pointer to STARTUPINFO } 
   ProcessInfo) then 
   Result := -1                        { pointer to PROCESS_INF } 

 else 
 begin 
   WaitforSingleObject(ProcessInfo.hProcess, INFINITE); 
   GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result)); 
 end; 
end; 

// 应用程序路径 
function AppPath: string; 
begin 
 Result := ExtractFilePath(Application.ExeName); 
end; 

// 取Windows系统目录 
function GetWindowsDir: string; 
var 
 Buf: array[0..MAX_PATH] of Char; 
begin 
 GetWindowsDirectory(Buf, MAX_PATH); 
 Result := AddDirSuffix(Buf); 
end; 

// 取临时文件目录 
function GetWinTempDir: string; 
var 
 Buf: array[0..MAX_PATH] of Char; 
begin 
 GetTempPath(MAX_PATH, Buf); 
 Result := AddDirSuffix(Buf); 
end; 

// 目录尾加'\'修正 
function AddDirSuffix(Dir: string): string; 
begin 
 Result := Trim(Dir); 
 if Result = '' then Exit; 
 if Result[Length(Result)] <> '\' then Result := Result + '\'; 
end; 

function MakePath(Dir: string): string; 
begin 
 Result := AddDirSuffix(Dir); 
end; 

// 判断文件是否正在使用 
function IsFileInUse(FName: string): Boolean; 
var 
 HFileRes: HFILE; 
begin 
 Result := False; 
 if not FileExists(FName) then 
   Exit; 
 HFileRes := CreateFile(PChar(FName), GENERIC_READ or GENERIC_WRITE, 0, 
   nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); 
 Result := (HFileRes = INVALID_HANDLE_VALUE); 
 if not Result then 
   CloseHandle(HFileRes); 
end; 

// 取文件长度 
function GetFileSize(FileName: string): Integer; 
var 
 FileVar: file of Byte; 
begin 
 {$I-} 
 try 
   AssignFile(FileVar, FileName); 
   Reset(FileVar); 
   Result := FileSize(FileVar); 
   CloseFile(FileVar); 
 except 
   Result := 0; 
 end; 
 {$I+} 
end; 

// 设置文件时间 
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime: 
 TFileTime): Boolean; 
var 
 FileHandle: Integer; 
begin 
 FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone); 
 if FileHandle > 0 then 
 begin 
   SetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime); 
   FileClose(FileHandle); 
   Result := True; 
 end 
 else 
   Result := False; 
end; 

// 取文件时间 
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime: 
 TFileTime): Boolean; 
var 
 FileHandle: Integer; 
begin 
 FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone); 
 if FileHandle > 0 then 
 begin 
   GetFileTime(FileHandle, @CreationTime, @LastAccessTime, @LastWriteTime); 
   FileClose(FileHandle); 
   Result := True; 
 end 
 else 
   Result := False; 
end; 

// 取得与文件相关的图标 
// FileName: e.g. "e:\hao\a.txt" 
// 成功则返回True 
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean; 
var 
 SHFileInfo: TSHFileInfo; 
 h: HWND; 
begin 
 if not Assigned(Icon) then 
   Icon := TIcon.Create; 
 h := SHGetFileInfo(PChar(FileName), 
   0, 
   SHFileInfo, 
   SizeOf(SHFileInfo), 
   SHGFI_ICON or SHGFI_SYSICONINDEX); 
 Icon.Handle := SHFileInfo.hIcon; 
 Result := (h <> 0); 
end; 

// 文件时间转本地时间 
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime; 
var 
 STime: TSystemTime; 
begin 
 FileTimeToLocalFileTime(FTime, FTime); 
 FileTimeToSystemTime(FTime, STime); 
 Result := STime; 
end; 

// 本地时间转文件时间 
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime; 
var 
 FTime: TFileTime; 
begin 
 SystemTimeToFileTime(STime, FTime); 
 LocalFileTimeToFileTime(FTime, FTime); 
 Result := FTime; 
end; 

// 创建备份文件 
function CreateBakFile(FileName, Ext: string): Boolean; 
var 
 BakFileName: string; 
begin 
 BakFileName := FileName + '.' + Ext; 
 Result := CopyFile(PChar(FileName), PChar(BakFileName), False); 
end; 

// 删除整个目录 
function Deltree(Dir: string): Boolean; 
var 
 sr: TSearchRec; 
 fr: Integer; 
begin 
 if not DirectoryExists(Dir) then 
 begin 
   Result := True; 
   Exit; 
 end; 
 fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr); 
 try 
   while fr = 0 do 
   begin 
     if (sr.Name <> '.') and (sr.Name <> '..') then 
     begin 
       if sr.Attr and faDirectory = faDirectory then 
         Result := Deltree(AddDirSuffix(Dir) + sr.Name) 
       else 
         Result := DeleteFile(AddDirSuffix(Dir) + sr.Name); 
       if not Result then 
         Exit; 
     end; 
     fr := FindNext(sr); 
   end; 
 finally 
   FindClose(sr); 
 end; 
 Result := RemoveDir(Dir); 
end; 

// 取文件夹文件数 
function GetDirFiles(Dir: string): Integer; 
var 
 sr: TSearchRec; 
 fr: Integer; 
begin 
 Result := 0; 
 fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr); 
 while fr = 0 do 
 begin 
   if (sr.Name <> '.') and (sr.Name <> '..') then 
     Inc(Result); 
   fr := FindNext(sr); 
 end; 
 FindClose(sr); 
end; 

var 
 FindAbort: Boolean; 

// 查找指定目录下文件 
procedure FindFile(const Path: string; const FileName: string = '*.*'; 
 Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True); 
var 
 APath: string; 
 Info: TSearchRec; 
 Succ: Integer; 
begin 
 FindAbort := False; 
 APath := MakePath(Path); 
 try 
   Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info); 
   while Succ = 0 do 
   begin 
     if (Info.Name <> '.') and (Info.Name <> '..') then 
     begin 
       if (Info.Attr and faDirectory) <> faDirectory then 
       begin 
         if Assigned(Proc) then 
           Proc(APath + Info.FindData.cFileName, Info, FindAbort); 
       end 
       else if bSub then 
         FindFile(APath + Info.Name, FileName, Proc, bSub, bMsg); 
     end; 
     if bMsg then Application.ProcessMessages; 
     if FindAbort then Exit; 
     Succ := FindNext(Info); 
   end; 
 finally 
   FindClose(Info); 
 end; 
end; 

{ 功能说明：查找一个路径下的所有文件。 
 参数：path:路径, filter:文件扩展名过滤, FileList:文件列表, ContainSubDir:是否包含子目录} 
procedure FindFileList(Path,Filter:string;FileList:TStrings;ContainSubDir:Boolean); 
var 
 FSearchRec,DSearchRec:TSearchRec; 
 FindResult:shortint; 
begin 
 FindResult:=FindFirst(path+Filter,sysutils.faAnyFile,FSearchRec); 

 try 
 while FindResult=0 do 
 begin 
   FileList.Add(FSearchRec.Name); 
   FindResult:=FindNext(FSearchRec); 
 end; 
  
 if ContainSubDir then 
 begin 
   FindResult:=FindFirst(path+Filter,faDirectory,DSearchRec); 
   while FindResult=0 do 
   begin 
     if ((DSearchRec.Attr and faDirectory)=faDirectory) 
       and (DSearchRec.Name<>'.') and (DSearchRec.Name<>'..') then 
       FindFileList(Path,Filter,FileList,ContainSubDir); 
       FindResult:=FindNext(DSearchRec); 
   end; 
 end; 
 finally 
   FindClose(FSearchRec); 
 end; 
end; 
  
//返回一文本文件的行数 
function Txtline(const txt: string): integer; 
var 
 F : TextFile; {设定为文本文件} 
 StrLine : string; {每行字符串} 
 line : Integer; {行数} 
begin 
 AssignFile(F, txt); {建立文件} 
 Reset(F); 
 Line := 0; 
 while not SeekEof(f) do {文件没到尾} 
 begin 
   if SeekEoln(f) then {判断是否到行尾} 
     Readln; 
   Readln(F, StrLine); 
   if SeekEof(f) then 
     break 
   else 
     inc(Line); 
 end; 
 CloseFile(F); {关闭文件} 
 Result := Line; 
end; 

//Html文件转化成文本文件 
function Html2Txt(htmlfilename: string): string; 
var Mystring:TStrings; 
   s,lineS:string; 
   line,Llen,i,j:integer; 
   rloop:boolean; 
begin 
  rloop:=False; 
  Mystring:=TStringlist.Create; 
  s:=''; 
  Mystring.LoadFromFile(htmlfilename); 
  line:=Mystring.Count; 
  try 
     for i:=0 to line-1 do 
        Begin 
           lineS:=Mystring[i]; 
           Llen:=length(lineS); 
           j:=1; 
           while (j<=Llen)and(lineS[j]=' ')do 
           begin 
              j:=j+1; 
              s:=s+' '; 
           End; 
           while j<=Llen do 
           Begin 
              if lineS[j]='<'then 
                 rloop:=True; 
                 if lineS[j]='>'then 
                    Begin 
                       rloop:=False; 
                       j:=j+1; 
                       continue; 
                    End; 
                 if rloop then 
                    begin 
                       j:=j+1; 
                       continue; 
                    end 
                 else 
                   s:=s+lineS[j]; 
                    j:=j+1; 
           End; 
           s:=s+#13#10; 
        End; 
  finally 
     Mystring.Free; 
  end;{try} 
  result:=s; 
end; 

// 文件打开方式 
function OpenWith(const FileName: string): Integer; 
begin 
 Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe', 
   PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW); 
end; 

//▎============================================================▎// 
//▎===================⑤扩展的对话框函数=======================▎// 
//▎============================================================▎// 

// 显示提示窗口 
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer); 
begin 
 Application.MessageBox(PChar(Mess), PChar(Caption), Flags); 
end; 

// 显示提示确认窗口 
function InfoOk(Mess: string; Caption: string): Boolean; 
begin 
 Result := Application.MessageBox(PChar(Mess), PChar(Caption), 
   MB_OK + MB_ICONINFORMATION) = IDOK; 
end; 

// 显示错误窗口 
procedure ErrorDlg(Mess: string; Caption: string); 
begin 
 Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP); 
end; 

// 显示警告窗口 
procedure WarningDlg(Mess: string; Caption: string); 
begin 
 Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING); 
end; 

// 显示查询是否窗口 
function QueryDlg(Mess: string; Caption: string): Boolean; 
begin 
 Result := Application.MessageBox(PChar(Mess), PChar(Caption), 
   MB_YESNO + MB_ICONQUESTION) = IDYES; 
end; 

//窗体渐变 
procedure SetWindowAnimate(Sender : TForm; IsSetAni : bool); 
var 
 pOSVersionInfo : OSVersionInfo; 
begin 
 pOSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo); 
 GetVersionEx(pOSVersionInfo); 
 if pOSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then 
 begin 
   if IsSetAni then 
     AnimateWindow(Sender.Handle,444,AW_HIDE or AW_BLEND); 
 end 
 else 
   if IsSetAni then 
   begin 
     AnimateWindow(Sender.Handle,444,AW_HIDE or AW_CENTER); 
   end; 
end; 

//▎============================================================▎// 
//▎====================⑥ 系统功能函数  =======================▎// 
//▎============================================================▎// 

// 移动鼠标到控件 
procedure MoveMouseIntoControl(AWinControl: TControl); 
var 
 rtControl: TRect; 
begin 
 rtControl := AWinControl.BoundsRect; 
 MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2); 
 SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2, 
   rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2); 
end; 

// 动态设置分辨率 
function DynamicResolution(x, y: WORD): Boolean; 
var 
 lpDevMode: TDeviceMode; 
begin 
 Result := EnumDisplaySettings(nil, 0, lpDevMode); 
 if Result then 
 begin 
   lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT; 
   lpDevMode.dmPelsWidth := x; 
   lpDevMode.dmPelsHeight := y; 
   Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL; 
 end; 
end; 

// 窗口最上方显示 
procedure StayOnTop(Handle: HWND; OnTop: Boolean); 
const 
 csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST); 
begin 
 SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE); 
end; 

var 
 WndLong: Integer; 

// 设置程序是否出现在任务栏 
procedure SetHidden(Hide: Boolean); 
begin 
 ShowWindow(Application.Handle, SW_HIDE); 
 if Hide then 
   SetWindowLong(Application.Handle, GWL_EXSTYLE, 
     WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST) 
 else 
   SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong); 
 ShowWindow(Application.Handle, SW_SHOW); 
end; 

const 
 csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE); 

// 设置任务栏是否可见 
procedure SetTaskBarVisible(Visible: Boolean); 
var 
 wndHandle: THandle; 
begin 
 wndHandle := FindWindow('Shell_TrayWnd', nil); 
 ShowWindow(wndHandle, csWndShowFlag[Visible]); 
end; 

// 设置桌面是否可见 
procedure SetDesktopVisible(Visible: Boolean); 
var 
 hDesktop: THandle; 
begin 
 hDesktop := FindWindow('Progman', nil); 
 ShowWindow(hDesktop, csWndShowFlag[Visible]); 
end; 

// 显示等待光标 
procedure BeginWait; 
begin 
 Screen.Cursor := crHourGlass; 
end;   

// 结束等待光标 
procedure EndWait; 
begin 
 Screen.Cursor := crDefault; 
end; 

// 检测是否Win95/98平台 
function CheckWindows9598NT: String; 
var 
  V: TOSVersionInfo; 
begin 
  V.dwOSVersionInfoSize := SizeOf(V); 
  Result := '未知操作系统'; 
  if not GetVersionEx(V) then Exit; 
  if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then 
     Result := 'Windows 95/98' 
  else 
     begin 
        if V.dwPlatformId = VER_PLATFORM_WIN32_NT then 
           Result := 'Windows NT' 
        else 
           Result :='Windows' 
     end; 
end; 

{* 取得当前操作平台是 Windows 95/98 还是NT} 
function GetOSInfo : String; 
begin 
  Result := ''; 
  case Win32Platform of 
     VER_PLATFORM_WIN32_WINDOWS: Result := 'Windows 95/98'; 
     VER_PLATFORM_WIN32_NT: Result := 'Windows NT'; 
  else 
     Result := 'Windows32'; 
  end; 
end; 

//*获取当前Windows登录名的用户 
function GetCurrentUserName : string; 
const 
  cnMaxUserNameLen = 254; 
var 
  sUserName : string; 
  dwUserNameLen : Dword; 
begin 
  dwUserNameLen := cnMaxUserNameLen-1; 
  SetLength( sUserName, cnMaxUserNameLen ); 
  GetUserName(Pchar( sUserName ), dwUserNameLen ); 
  SetLength( sUserName, dwUserNameLen ); 
  Result := sUserName; 
end; 

function GetRegistryOrg_User(UserKeyType:string):string; 
var 
  Myreg:Tregistry; 
  RegString:string; 
begin 
  MyReg:=Tregistry.Create; 
  MyReg.RootKey:=HKEY_LOCAL_MACHINE; 
  if (Win32Platform = VER_PLATFORM_WIN32_NT) then 
     RegString:='Software\Microsoft\Windows NT\CurrentVersion' 
  else 
     RegString:='Software\Microsoft\Windows\CurrentVersion'; 

  if MyReg.openkey(RegString,False) then 
  begin 
     if UpperCase(UserKeyType)='REGISTEREDORGANIZATION' then 
        Result:= MyReg.readstring('RegisteredOrganization') 
     else 
        begin 
           if UpperCase(UserKeyType)='REGISTEREDOWNER' then 
              Result:= MyReg.readstring('RegisteredOwner') 
           else 
              Result:=''; 
        end; 
  end; 
  MyReg.CloseKey; 
  MyReg.Free; 
end; 

//获取操作系统版本号 
function GetSysVersion:string; 
Var 
  OSVI:OSVERSIONINFO; 
  ObjSysVersion:string; 
begin 
  OSVI.dwOSversioninfoSize:=Sizeof(OSVERSIONINFO); 
  GetVersionEx(OSVI); 
  ObjSysVersion:=IntToStr(OSVI.dwMinorVersion)+','+IntToStr(OSVI.dwMinorVersion)+',' 
           +IntToStr(OSVI.dwBuildNumber)+','+IntToStr(OSVI.dwPlatformId)+',' 
           +OSVI.szCSDVersion; 
  if rightstr(ObjSysVersion,1)=',' then 
     ObjSysVersion:=Substr(ObjSysVersion,1,length(ObjSysVersion)-1); 
  Result:=ObjSysVersion; 
end; 

//Windows启动模式 
function WinBootMode:string; 
begin 
  case(GetSystemMetrics(SM_CLEANBOOT)) of 
     0:Result:='正常模式启动'; 
     1:Result:='安全模式启动'; 
     2:Result:='安全模式启动，但附带网络功能'; 
  else 
     Result:='错误：系统启动有问题。'; 
  end; 
end; 

////Windows ShutDown等 
procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean); 
var 
 hToken, hProcess: THandle; 
 tp, prev_tp: TTokenPrivileges; 
 Len, Flags: DWORD; 
 CanShutdown: Boolean; 
begin 
 if Win32Platform = VER_PLATFORM_WIN32_NT then 
 begin 
   hProcess := OpenProcess(PROCESS_ALL_ACCESS, True, GetCurrentProcessID); 
   try 
     if not OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then 
        Exit; 
   finally 
     CloseHandle(hProcess); 
   end; 
   try 
     if not LookupPrivilegeValue('', 'SeShutdownPrivilege', 
       tp.Privileges[0].Luid) then Exit; 
     tp.PrivilegeCount := 1; 
     tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED; 
     if not AdjustTokenPrivileges(hToken, False, tp, SizeOf(prev_tp), 
       prev_tp, Len) then Exit; 
   finally 
     CloseHandle(hToken); 
   end; 
 end; 
 CanShutdown := True; 
//  DoQueryShutdown(CanShutdown); 
 if not CanShutdown then Exit; 
 if PForce then Flags := EWX_FORCE else Flags := 0; 
 case ShutWinType of 
   UPowerOff:  ExitWindowsEx(Flags or EWX_POWEROFF, 0); 
   UShutdown:  ExitWindowsEx(Flags or EWX_SHUTDOWN, 0); 
   UReboot:    ExitWindowsEx(Flags or EWX_REBOOT, 0); 
   ULogoff:    ExitWindowsEx(Flags or EWX_LOGOFF, 0); 
   USuspend:   SetSystemPowerState(True, PForce); 
   UHibernate: SetSystemPowerState(False, PForce); 
 end; 
end; 


//▎============================================================▎// 
//▎=====================⑦硬件功能函数=========================▎// 
//▎============================================================▎// 

function GetClientGUID:string; 
var 
 myGuid:TGUID; 
 ResultStr:string; 
begin 
 CreateGuid(myGuid); 
 ResultStr:=GUIDToString(myGuid); 
 ResultStr:=Communal.Replace(ResultStr,'-','',False); 
 ResultStr:=Communal.Replace(ResultStr,'{','',False); 
 ResultStr:=Communal.Replace(ResultStr,'}','',False); 
 Result:=Substr(ResultStr,1,30); 
end; 

// 声卡是否存在 
function SoundCardExist: Boolean; 
begin 
 Result := WaveOutGetNumDevs > 0; 
end; 

//* 获取磁盘序列号 
function GetDiskSerial(DiskChar: Char): string; 
var 
  SerialNum : pdword; 
  a, b : dword; 
  Buffer : array [0..255] of char; 
begin 
  result := ''; 
  if GetVolumeInformation(PChar(diskchar+':\'), Buffer, SizeOf(Buffer), SerialNum,a, b, nil, 0) then 
     Result := IntToStr(SerialNum^); 
end; 

//*检查磁盘准备是否就绪 
function DiskReady(Root: string) : Boolean; 
var 
  Oem : CARDINAL ; 
  Dw1,Dw2 : DWORD ; 
begin 
  Oem := SetErrorMode( SEM_FAILCRITICALERRORS ) ; 
  if LENGTH(Root) = 1 then Root := Root + ':\\'; 
     Result := GetVolumeInformation( PCHAR( Root ), NIL,0,NIL, Dw1,Dw2, NIL,0 ) ; 
  SetErrorMode( Oem ) ; 
end; 

//*检查驱动器A中磁盘的是否有文件及文件状态 
function DriveState (driveletter: Char) : TDriveState; 
var 
  mask: String[6]; 
  sRec: TSearchRec; 
  oldMode: Cardinal; 
  retcode: Integer; 
begin 
  oldMode := SetErrorMode(SEM_FAILCRITICALERRORS); 
  mask:= '?:\*.*'; 
  mask[1] := driveletter; 
  {$I-} 
  retcode := FindFirst (mask, faAnyfile, Srec); 
  FindClose(Srec); 
  {$I+} 
  case retcode of 
  0 : Result := DSDISK_WITHFILES; //磁盘有文件 
  -18 : Result := DSEMPTYDISK; //好的空磁盘 
  -21, -3: Result := DSNODISK; //NT,Win31的错误代号 
  else 
     Result := DSUNFORMATTEDDISK; 
  end; 
  SetErrorMode(oldMode); 
end; 

//写串口 
procedure WritePortB( wPort : Word; bValue : Byte ); 
begin 
  asm 
  mov dx, wPort 
  mov al, bValue 
  out dx, al 
  end; 
end; 

//读串口 
function ReadPortB( wPort : Word ):Byte; 
begin 
  asm 
  mov dx, wPort 
  in al, dx 
  mov result, al 
  end; 
end; 

//获知当前机器CPU的速率（MHz） 
function CPUSpeed: Double; 
const 
  DelayTime = 500; 
  var 
  TimerHi, TimerLo: DWORD; 
  PriorityClass, Priority: Integer; 
begin 
  PriorityClass := GetPriorityClass(GetCurrentProcess); 
  Priority := GetThreadPriority(GetCurrentThread); 
  SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS); 
  SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL); 
  Sleep(10); 
  asm 
  dw 310Fh 
  mov TimerLo, eax 
  mov TimerHi, edx 
  end; 
  Sleep(DelayTime); 
  asm 
  dw 310Fh 
  sub eax, TimerLo 
  sbb edx, TimerHi 
  mov TimerLo, eax 
  mov TimerHi, edx 
  end; 
  SetThreadPriority(GetCurrentThread, Priority); 
  SetPriorityClass(GetCurrentProcess, PriorityClass); 
  Result := TimerLo / (1000.0 * DelayTime); 
end; 

//获取CPU的标识ID号 
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; 

//获取计算机的物理内存 
function GetMemoryTotalPhys : Dword; 
var 
  memStatus: TMemoryStatus; 
begin 
  memStatus.dwLength := sizeOf ( memStatus ); 
  GlobalMemoryStatus ( memStatus ); 
  Result := memStatus.dwTotalPhys div 1024; 
end; 

//▎============================================================▎// 
//▎=====================⑧网络功能函数=========================▎// 
//▎============================================================▎// 

{* 获取网络计算机名称} 
function GetComputerName:string; 
var 
  wVersionRequested : WORD; 
  wsaData : TWSAData; 
  p : PHostEnt; s : array[0..128] of char; 
begin 
  try 
     wVersionRequested := MAKEWORD(1, 1); //创建 WinSock 
     WSAStartup(wVersionRequested, wsaData); //创建 WinSock 
     GetHostName(@s,128); 
     p:=GetHostByName(@s); 
     Result:=p^.h_Name; 
  finally 
     WSACleanup; //释放 WinSock 
  end; 
end; 

{* 获取计算机的IP地址} 
function GetHostIP:string; 
var 
  wVersionRequested : WORD; 
  wsaData : TWSAData; 
  p : PHostEnt; s : array[0..128] of char; p2 : pchar; 
begin 
  try 
     wVersionRequested := MAKEWORD(1, 1); //创建 WinSock 
     WSAStartup(wVersionRequested, wsaData); //创建 WinSock 
     GetHostName(@s,128); 
     p:=GetHostByName(@s); 
     p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^); 
     Result:= P2; 
  finally 
     WSACleanup; //释放 WinSock 
  end; 
end; 

//▎============================================================▎// 
//▎=====================⑨汉字拼音功能函数=====================▎// 
//▎============================================================▎// 
// 取汉字的拼音 
function GetHzPy(const AHzStr: string): string; 
const 
 ChinaCode: array[0..25, 0..1] of Integer = ((1601, 1636), (1637, 1832), (1833, 2077), 
   (2078, 2273), (2274, 2301), (2302, 2432), (2433, 2593), (2594, 2786), (9999, 0000), 
   (2787, 3105), (3106, 3211), (3212, 3471), (3472, 3634), (3635, 3722), (3723, 3729), 
   (3730, 3857), (3858, 4026), (4027, 4085), (4086, 4389), (4390, 4557), (9999, 0000), 
   (9999, 0000), (4558, 4683), (4684, 4924), (4925, 5248), (5249, 5589)); 
var 
 i, j, HzOrd: Integer; 
begin 
 Result:=''; 
 i := 1; 
 while i <= Length(AHzStr) do 
 begin 
   if (AHzStr[i] >= #160) and (AHzStr[i + 1] >= #160) then 
   begin 
     HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160; 
     for j := 0 to 25 do 
     begin 
       if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then 
       begin 
         Result := Result + Char(Byte('A') + j); 
         Break; 
       end; 
     end; 
     Inc(i); 
   end else Result := Result + AHzStr[i]; 
   Inc(i); 
 end; 
end; 

{* 判断一个字符串中有多少各汉字} 
function HowManyChineseChar(Const s:String):Integer; 
var 
  SW:WideString; 
  C:String; 
  i, WCount:Integer; 
begin 
  SW:=s; 
  WCount:=0; 
  For i:=1 to Length(SW) do 
  begin 
     c:=SW[i]; 
     if Length(c)>1 then 
        Inc(WCount); 
  end; 
  Result:=WCount; 
end; 

//▎============================================================▎// 
//▎==================⑩数据库功能函数及过程====================▎// 
//▎============================================================▎// 

//* 物理删除数据库(Db，Dbf)中的数据[着了删除标记的记录]} 
{function PackDbDbf(Var StatusMsg: String): Boolean; 
var 
  rslt:DBIResult; 
  szErrMsg:DBIMSG; 
  pTblDesc:pCRTblDesc; 
  bExclusive:Boolean; 
  bActive:Boolean; 
  isParadox,isDbase:Boolean; 
  tempTableName:string; 
  Props:CurProps;//保护口令 
begin 
  Result:=False; 
  StatusMsg:=''; 
  if TableType=ttDefault then 
     begin 
        tempTableName:=TableName; 
        tempTableName:=Lowercase(tempTableName); 
        isParadox:=(pos('.db',tempTableName)>0) and (tempTableName[length(tempTableName)]='b'); 
        isDbase:=pos('.dbf',tempTableName)>0; 
     end 
  else 
     begin 
        isParadox:=TableType=ttParadox; 
        isDbase:=TableType=ttDbase; 
     end; 
  if isparadox or isDbase then 
     begin 
        bExclusive:=Exclusive; 
        bActive:=Active; 
        DisableControls; 
//         Close; 
        Exculsive:=true; 
     end 
  else 
     begin 
        StatusMsg:='无效的数据表类型。'; 
        Exit; 
     end; 
  if isParadox then 
     begin 
        if wwMemAvail(Sizeof(CRTblDesc)) then 
           begin 
              StatusMsg:='内存不足，压缩表失败。'; 
           end 
        else 
           begin 
              GetMem(pTblDesc,Sizeof(CRTblDesc)); 
              fillchar(pTblDesc^,Sizeof(CRTblDesc),0); 
              with pTblDesc^ do 
              begin 
                 strCopy(szTblName,Tablename); 
                 strCopy(szTblType,szParadox); 
                 Active:=True; 
                 Check(DbiGetCursorProps(handle,Props));//检测是否右口令保护 
                 bProtected:=props.bProtected; 
                 Active:=False; 
                 bPack:=True; 
              end; 
              Screen.Cursor:=crHourGlass; 
              SetDBFlag(dbfOpened,True); 
              rslt:=DBIdoRestructure(DBHandle,1,pTblDesc,nil,nil,nil,False); 
              if rslt<>DBIERR_NONE then 
                 begin 
                    DBiGetErrorString(rslt,SzErrMsg); 
                    StatusMsg:=SzErrMsg; 
                 end 
              else 
                 Result:=True; 
              SetDBFlag(dbfOpened,False); 
              FreeMem(pTblDesc,Sizeof(CRTlDesc)); 
              Screen.Cursor:=crDefault; 
           end; 
     end 
  else 
     if isDbase then 
        begin 
           Screen.Cursor:=crHourGlass; 
           OPen; 
           rslt:=dbiPacktable(DBHandle,Handle,nil,nil,True); 
           Screen.Cursor:=crDefault; 
           if rslt<>DBIERR_NONE then 
              begin 
                 DBiGetERRorString(rslt,szErrMsg); 
                 StatusMSg:=SzErrMsg; 
              end 
           else 
              Result:=True; 
        end; 
     Close; 
     Exculsive:=bExclusive; 
     Active:=bActive; 
     EnableControls; 
end;} 


{procedure CompactDb(DbName, NewDbName: string); 
var 
  dao: OLEVariant; 
begin 
  dao := CreateOleObject('DAO.DBEngine.35'); 
  dao.CompactDatabase(DbName, NewDbName); 
end;} 

//修复Access表 
procedure RepairDb(DbName: string); 
var 
  Dao: OLEVariant; 
begin 
  Dao := CreateOleObject('DAO.DBEngine.35'); 
  Dao.RepairDatabase(DbName); 
end; 

//通过注册表创建ODBC配置[创建在系统DSN页下] 
function CreateODBCCfgInRegistry(ODBCSourceName:WideString; ServerName, DataBaseDescription:String):boolean; 
var 
 Reg: TRegistry; 
 LPT_systemDir:array [1..255] of char; 
 P:Pchar; 
 DriverString:String; 
begin 
  Reg := TRegistry.Create; 
  Reg.RootKey := HKEY_LOCAL_MACHINE; 
  try 
     try 
        if not Reg.KeyExists('\Software\ODBC\ODBC.INI\'+trim(ODBCSourceName)) then 
        begin 
           //创建并打开主键。 
           if Reg.OpenKey('\Software\ODBC\ODBC.INI\'+trim(ODBCSourceName),True) then 
           begin 
              //写入键值 
              Reg.WriteString('DataBase', ODBCSourceName); 
              Reg.WriteString('Description',Trim(DataBaseDescription)); 

              GetSystemDirectory(@LPT_systemDir,255) ; 
              P:=@LPT_systemDir; 
              DriverString:=StrCat(P,Pchar('\SQLSRV32.DLL')) ; 
              Reg.WriteString('Driver', DriverString); 

              Reg.WriteString('LastUser', 'Administrator'); 
              Reg.WriteString('Server', trim(ServerName)); 
              Reg.WriteString('Trusted_Connection', 'Yes'); 
              reg.CloseKey; 
           end; 

           //加入ODBCDataSource 
           if Reg.OpenKey('\Software\ODBC\ODBC.INI\ODBC Data Sources\',True) then 
           begin 
              Reg.DeleteValue(ODBCSourceName); 
              Reg.WriteString(ODBCSourceName, 'SQL Server'); 
              Reg.CloseKey; 
           end; 
        end; 
        Result:=True; 
     except 
        Result:=False; 
     end; 
  finally 
     Reg.Free; 
  end; 
end; 

function ADOConnectSysBase(Const Adocon:TadoConnection):boolean; 
{* 用Ado连接SysBase数据库函数} 
begin 
  with Adocon do 
    begin 
         Close; 
         LoginPrompt:=False;    //若数据库不存在时，进行判断。。。。。。 
         ConnectionString:='Provider=MSDASQL.1;'+ 
                           'Password="";'+ 
                           'Persist Security Info=True;'+ 
                           'Data Source=Sy_Finalact'; 
         try 
             KeepConnection:=True; 
             Screen.Cursor:=crHourGlass; 
             Connected:=True; 
             Open; 
             Screen.Cursor:=crDefault; 
             ADOConnectSysBase:=True; 
         except 
             ADOConnectSysBase:=False; 
         end; 
    end; 
end; 

//Ado连接数据库函数 
function ADOConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname,DBServerName:String;ValidateMode:Integer):boolean; 
begin 
  with Adocon do 
    begin 
         Close; 
         LoginPrompt:=False;    //若数据库不存在时，进行判断。。。。。。 
         if ValidateMode=0 then//使用Windows NT验证模式 
            ConnectionString:='Provider=SQLOLEDB.1;'+ 
                              'Password="";'+ 
                              'Integrated Security=SSPI;'+  //集成安全 
                              'Persist Security Info=False;'+ 
                              'User ID=sa;Initial Catalog='+''''+dbname+''''+';'+ 
                              'Data Source='+''''+DBServerName+''''; 

         if ValidateMode=1 then//使用SQL SERVER验证模式 
            ConnectionString:='Provider=SQLOLEDB.1;'+ 
                              'Password="";'+ 
                              'Persist Security Info=True;'+ 
                              'User ID=sa;Initial Catalog='+''''+Dbname+''''+';'+ 
                              'Data Source='+''''+DBServerName+''''; 
         try 
             KeepConnection:=True; 
             Screen.Cursor:=crHourGlass; 
             Connected:=True; 
             Open; 
             Screen.Cursor:=crDefault; 
             ADOConnectLocalDB:=True; 
         except 
             ADOConnectLocalDB:=False; 
         end; 
    end; 
end; 

//Ado与ODBC共同连接数据库函数 
function ADOODBCConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname:String;ValidateMode:Integer):boolean; 
begin 
  with Adocon do 
    begin 
         Close; 
         LoginPrompt:=False;    //若数据库不存在时，进行判断。。。。。。 
         if ValidateMode=0 then//使用Windows NT验证模式 
            ConnectionString:='Provider=MSDASQL.1;'+ 
                              'Password="";'+ 
                              'Persist Security Info=False;'+ 
                              'User ID=sa;Data Source='+''''+DBName+''''+';'+ 
                              'Initial Catalog='+''''+DBname+''''; 

         if ValidateMode=1 then//使用SQL SERVER验证模式 
            ConnectionString:='Provider=MSDASQL.1;'+ 
                              'Password="";'+ 
                              'Persist Security Info=True;'+ 
                              'User ID=sa;Data Source='+''''+DBName+''''+';'+ 
                              'Initial Catalog='+''''+DBname+''''; 
         try 
             KeepConnection:=True; 
             Screen.Cursor:=crHourGlass; 
             Connected:=True; 
             Open; 
             Screen.Cursor:=crDefault; 
             ADOODBCConnectLocalDB:=True; 
         except 
             ADOODBCConnectLocalDB:=False; 
         end; 
    end; 
end; 

///在指定的数据库中建立表 
function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean;//建立新表 
Var 
  CreatTableQuery:TQuery; 
  SQLsentence:string; 
  Successed:Boolean;//成功否 
begin 
  Successed:=False; 
  SQLsentence:='CREATE TABLE "'+ LpTableName +'" ' + LpSentence; 
  CreatTableQuery:=TQuery.Create(nil); 
  try 
     try 
        with CreatTableQuery do 
        begin 
           UniDirectional:=True; 
           Active:=False; 
           Sql.Clear; 
           DataBaseName := LpDataBaseName; //数据库名 
           Sql.Add(SQLsentence); 
           ExecSQL; 
           Successed:=True; 
        end; 
     except 
        MessageBox(Application.Handle,Pchar(' 在建立数据库 '+Trim(LpDataBaseName)+' 中的 '+Trim(LpTableName)+' 表出错，建立未能成功 ！'),'建立失败',0+16); 
        Successed:=False; 
     end; 
  finally 
     CreatTableQuery.Free;//释放建立的Query 
     if Successed then 
        Result:=True//建立成功 
     else 
        Result:=False;//建立失败 
  end; 
end; 

//在指定的表中新填字段 
function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;//建立新表 
var 
  Sentence,SQLsentence : string; 
begin 
  Sentence:= ''; 
  SQLsentence:=''; 
  if LpFieldName = '' then 
     raise EDBUpdateErr.Create('字段名不能为空'); 
  if Pos(' ', LpFieldName) <> 0 then 
     raise EDBUpdateErr.Create('字段名中不能含有空格字符'); 
  if LpDataType = ftString then 
     sentence := 'ADD '+LpFieldName+' Char('+ IntToStr( LpSize ) + ')'; 
  if LpDataType = ftInteger then 
     sentence := 'ADD '+LpFieldName+' Integer'; 
  if LpDataType = ftSmallInt then 
     sentence := 'ADD '+LpFieldName+' SmallInt'; 
  if LpDataType = ftFloat then 
     sentence := 'ADD '+LpFieldName+' Float('+ IntToStr( LpSize ) +',0)'; 
  if LpDataType = ftDate then 
     sentence := 'ADD '+LpFieldName+' Date'; 
  if LpDataType = ftTime then 
     sentence := 'ADD '+LpFieldName+' Time'; 
  if LpDataType = ftDateTime then 
     sentence := 'ADD '+LpFieldName+' TimeStamp'; 
  if sentence = '' then 
     raise EDBUpdateErr.Create('无效的字段类型'); 
  if SQLSentence = '' then 
     SQLSentence := sentence 
  else 
     SQLSentence := SQLSentence + ', ' + sentence; 
  Result:=SQLSentence;//返回SQL句体 
end; 

//在指定的表中删除字段 
function KillField(LpFieldName:string):String;//删除表中的字段 
var 
  SQLsentence : string; 
begin 
  if LpFieldName = '' then 
     raise EDBUpdateErr.Create('字段名不能为空'); 
  if Pos(' ', LpFieldName) <> 0 then 
     raise EDBUpdateErr.Create('字段名中不能含有空格字符'); 
  if SQLSentence = '' then 
     SQLSentence := 'DROP COLUMN ' + LpFieldName 
  else 
     SQLSentence := SQLSentence + ', DROP ' + LpFieldName; 
  Result:=SQLSentence; 
end; 

//修改表结构的SQL语句执行体 
function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean;//修改表结构 
var 
  AlterQueryTable:TQuery; 
  Successed:Boolean;//成功否 
begin 
  Successed:=False; 
  AlterQueryTable:= TQuery.Create(nil); 
  try 
     try 
        with AlterQueryTable do 
        begin 
           DataBaseName:=LpDataBaseName;//数据库名 
           UniDirectional:=True; 
           Active:=False; 
           Sql.Clear; 
           Sql.Add(LpSentence); 
           ExecSQL; 
           Successed:=True; 
        end; 
     except 
        Successed:=False; 
     end; 
  finally 
     AlterQueryTable.Free; 
     if successed then 
        Result:=True 
     else 
        Result:=False; 
  end; 
end; 

//修改、添加、删除表结构时的SQL句体 
function GetSQLSentence(LpTableName,LpSQLsentence:string): string; 
begin 
 Result := 'ALTER TABLE "'+ LpTableName +'" ' + LpSQLSentence + ';'; 
end; 


//▎============================================================▎// 
//▎======================⑾进制函数及过程======================▎// 
//▎============================================================▎// 

//字符转化成十六进制 
function StrToHex(AStr: string): string; 
var 
  I : Integer; 
//   Tmp: string; 
  begin 
     Result := ''; 
     For I := 1 to Length(AStr) do 
     begin 
        Result := Result + Format('%2x', [Byte(AStr[I])]); 
     end; 
     I := Pos(' ', Result); 
     While I <> 0 do 
     begin 
        Result[I] := '0'; 
        I := Pos(' ', Result); 
     end; 
end; 

//十六进制转化成字符 
function HexToStr(AStr: string): string; 
var 
  I : Integer; 
  CharValue: Word; 
  begin 
  Result := ''; 
  for I := 1 to Trunc(Length(Astr)/2) do 
  begin 
     Result := Result + ' '; 
     CharValue := TransChar(AStr[2*I-1])*16 + TransChar(AStr[2*I]); 
     Result[I] := Char(CharValue); 
  end; 
end; 

function TransChar(AChar: Char): Integer; 
begin 
  if AChar in ['0'..'9'] then 
     Result := Ord(AChar) - Ord('0') 
  else 
     Result := 10 + Ord(AChar) - Ord('A'); 
  end; 

//▎============================================================▎// 
//▎=====================⑿其它函数及过程=======================▎// 
//▎============================================================▎// 

// 输出限制在Min..Max之间 
function TrimInt(Value, Min, Max: Integer): Integer; overload; 
begin 
 if Value > Max then 
   Result := Max 
 else if Value < Min then 
   Result := Min 
 else 
   Result := Value; 
end; 

// 输出限制在0..255之间 
function IntToByte(Value: Integer): Byte; overload; 
asm 
       OR     EAX, EAX 
       JNS    @@Positive 
       XOR    EAX, EAX 
       RET 

@@Positive: 
       CMP    EAX, 255 
       JBE    @@OK 
       MOV    EAX, 255 
@@OK: 
end; 

// 由TRect分离出坐标、宽高 
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer); 
begin 
 x := Rect.Left; 
 y := Rect.Top; 
 Width := Rect.Right - Rect.Left; 
 Height := Rect.Bottom - Rect.Top; 
end; 

// 比较两个Rect 
function RectEqu(Rect1, Rect2: TRect): Boolean; 
begin 
 Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and 
   (Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom); 
end; 

// 产生TSize类型 
function EnSize(cx, cy: Integer): TSize; 
begin 
 Result.cx := cx; 
 Result.cy := cy; 
end; 

// 计算Rect的宽度 
function RectWidth(Rect: TRect): Integer; 
begin 
 Result := Rect.Right - Rect.Left; 
end; 

// 计算Rect的高度 
function RectHeight(Rect: TRect): Integer; 
begin 
 Result := Rect.Bottom - Rect.Top; 
end; 

// 判断范围 
function InBound(Value: Integer; Min, Max: Integer): Boolean; 
begin 
 Result := (Value >= Min) and (Value <= Max); 
end; 

// 交换两个数 
procedure CnSwap(var A, B: Byte); overload; 
var 
 Tmp: Byte; 
begin 
 Tmp := A; 
 A := B; 
 B := Tmp; 
end; 

procedure CnSwap(var A, B: Integer); overload; 
var 
 Tmp: Integer; 
begin 
 Tmp := A; 
 A := B; 
 B := Tmp; 
end; 

procedure CnSwap(var A, B: Single); overload; 
var 
 Tmp: Single; 
begin 
 Tmp := A; 
 A := B; 
 B := Tmp; 
end; 

procedure CnSwap(var A, B: Double); overload; 
var 
 Tmp: Double; 
begin 
 Tmp := A; 
 A := B; 
 B := Tmp; 
end; 

// 延时 
procedure Delay(const uDelay: DWORD); 
var 
 n: DWORD; 
begin 
 n := GetTickCount; 
 while ((GetTickCount - n) <= uDelay) do 
   Application.ProcessMessages; 
end; 

// 在Win9X下让喇叭发声 
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1); 
const 
 FREQ_SCALE = $1193180; 
var 
 Temp: WORD; 
begin 
 Temp := FREQ_SCALE div Freq; 
 asm 
   in al,61h; 
   or al,3; 
   out 61h,al; 
   mov al,$b6; 
   out 43h,al; 
   mov ax,temp; 
   out 42h,al; 
   mov al,ah; 
   out 42h,al; 
 end; 
 Sleep(Delay); 
 asm 
   in al,$61; 
   and al,$fc; 
   out $61,al; 
 end; 
end; 

// 显示Win32 Api运行结果信息 
procedure ShowLastError; 
var 
 ErrNo: Integer; 
 Buf: array[0..255] of Char; 
begin 
 ErrNo := GetLastError; 
 FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, $400, Buf, 255, nil); 
 if Buf = '' then StrCopy(@Buf, PChar(SUnknowError)); 
 MessageBox(Application.Handle, PChar(string(Buf) + #10#13 + 
   SErrorCode + IntToStr(ErrNo)), 
   SCnInformation, MB_OK + MB_ICONINFORMATION); 
end; 

//将字体Font.Style写入INI文件 
function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string; 
var 
 Mystyle : string; 
 Myini : Tinifile; 
begin 
 Mystyle := '['; 
 if fsBold in FS then MyStyle := MyStyle + 'fsBold'; 
 if fsItalic in FS then 
 if MyStyle = '[' then 
   MyStyle := MyStyle + 'fsItalic' 
 else 
   MyStyle := MyStyle + ',fsItalic'; 
 if fsUnderline in FS then 
   if MyStyle = '[' then 
      MyStyle := MyStyle + 'fsUnderline' 
   else 
      MyStyle := MyStyle + ',fsUnderline'; 
 if fsStrikeOut in FS then 
   if MyStyle = '[' then 
     MyStyle := MyStyle + 'fsStrikeOut' 
   else 
     MyStyle := MyStyle + ',fsStrikeOut'; 
 MyStyle := MyStyle + ']'; 
 if write then 
 begin 
   Myini := TInifile.Create(inifile); 
   Myini.WriteString('FontStyle', 'style', MyStyle); 
   Myini.free; 
 end; 
 Result := MyStyle; 
end; 

//从INI文件中读取字体Font.Style文件 
function readFontStyle(inifile: string): TFontStyles; 
var 
 MyFontStyle : TFontStyles; 
 MyStyle : string; 
 Myini : Tinifile; 
begin 
 MyFontStyle := []; 
 Myini := TInifile.Create(inifile); 
 Mystyle := Myini.ReadString('Fontstyle', 'style', '[]'); 
 if pos('fsBold', Mystyle) > 0 then MyFontStyle := MyFontStyle +   [fsBold]; 
 if Pos('fsItalic', MyStyle) > 0 then MyFontStyle := MyFontStyle + [fsItalic]; 
 if Pos('fsUnderline', MyStyle) > 0 then 
   MyFontStyle := MyFontStyle + [fsUnderline]; 
 if Pos('fsStrikeOut', MyStyle) > 0 then 
   MyFontStyle := MyFontStyle + [fsStrikeOut]; 
 MyIni.free; 
 Result := MyFontStyle; 
end; 

//*取得TMemo 控件当前光标的行和列信息到Tpoint中 
//function ReadCursorPos(SourceMemo: TMemo): TPoint; 
function ReadCursorPos(SourceMemo: TMemo): string; 
var 
  //   Point: TPoint; 
  X,Y:integer; 
begin 
//   point.y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0); 
//   point.x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,point.y,0); 
  y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0); 
  x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,y,0); 
  Result := '行:'+inttostr(y+1)+' '+'列:'+inttostr(x+1); 
end; 

//*检查Tmemo控件能否Undo功能 
function CanUndo(AMemo: TMemo): Boolean; 
begin 
  Result :=AMemo.Perform(EM_CANUNDO, 0, 0)<>0; 
end; 

//* 实现Undo功能 
procedure Undo(Amemo: Tmemo); 
begin 
  Amemo.Perform(EM_UNDO, 0, 0); 
end; 

//* 实现ComBoBox自动下拉 
procedure AutoListDisplay(ACombox:TComboBox); 
begin 
  SendMessage(ACombox.handle, CB_SHOWDROPDOWN, Integer(True), 0); 
end; 

//* 小写金额转换为大写 
function UpperMoney(small:real):string; 
var 
  SmallMonth,BigMonth:string; 
  wei1,qianwei1:string[2]; 
  qianwei,dianweizhi,qian:integer; 
  ObjSmall:real; 
begin 
  {------- 修改参数令值更精确 -------} 
  ObjSmall:=Abs(small); 
  qianwei:=-2;{小数点后的位置，需要的话也可以改动-2值} 
  Smallmonth:=formatfloat('0.00',ObjSmall);{转换成货币形式，需要的话小数点后加多几个零} 
  {---------------------------------} 
  dianweizhi :=pos('.',Smallmonth);{小数点的位置} 
  for qian:=length(Smallmonth) downto 1 do{循环小写货币的每一位，从小写的右边位置到左边} 
  begin 
     if qian<>dianweizhi then{如果读到的不是小数点就继续} 
        begin 
           case strtoint(copy(Smallmonth,qian,1)) of{位置上的数转换成大写} 
           1:wei1:='壹'; 
           2:wei1:='贰'; 
           3:wei1:='叁'; 
           4:wei1:='肆'; 
           5:wei1:='伍'; 
           6:wei1:='陆'; 
           7:wei1:='柒'; 
           8:wei1:='捌'; 
           9:wei1:='玖'; 
           0:wei1:='零'; 
           end; 
           case qianwei of{判断大写位置，可以继续增大到real类型的最大值} 
           -3:qianwei1:='厘'; 
           -2:qianwei1:='分'; 
           -1:qianwei1:='角'; 
           0 :qianwei1:='元'; 
           1 :qianwei1:='拾'; 
           2 :qianwei1:='佰'; 
           3 :qianwei1:='千'; 
           4 :qianwei1:='万'; 
           5 :qianwei1:='拾'; 
           6 :qianwei1:='佰'; 
           7 :qianwei1:='千'; 
           8 :qianwei1:='亿'; 
           9 :qianwei1:='十'; 
           10:qianwei1:='佰'; 
           11:qianwei1:='千'; 
           end; 
           inc(qianwei); 
           if Small<0 then 
              BigMonth :='负'+wei1+qianwei1+BigMonth {组合成大写金额} 
           else 
              BigMonth :=wei1+qianwei1+BigMonth {组合成大写金额} 
        end; 
  end; 
  Result:=BigMonth; 
end; 

//利用系统时间产生随机数 
function Myrandom(Num: Integer): integer; 
var 
  T: _SystemTime; 
  X: integer; 
  I: integer; 
begin 
  Result := 0; 
  If Num = 0 then Exit;; 
     GetSystemTime(T); 
     X := Trunc(T.wMilliseconds/10) * T.wSecond * 1231; 
     X := X + random(1); 
     if X<>0 then 
        X := -X; 
     X := Random(X); 
     X := X mod num; 
     for I := 0 to X do 
        X := Random(Num); 
     Result := X; 
end; 

//打开输入法 
procedure OpenIME(ImeName: string); 
var 
 i: integer; 
 MyHKL: hkl; 
begin 
 if ImeName <> '' then begin 
   if Screen.Imes.Count <> 0 then begin 
     i := Screen.Imes.IndexOf(ImeName); 
     if i >= 0 then MyHKL := hkl(Screen.Imes.Objects[i]); 
     ActivateKeyboardLayout(MyHKL, KLF_ACTIVATE); 
   end; 
 end; 
end; 

//关闭输入法 
procedure CloseIME; 
var 
 MyHKL: hkl; 
begin 
 MyHKL := GetKeyboardLayout(0); 
 if ImmIsIme(MyHKL) then 
   ImmSimulateHotKey(Application.Handle, IME_CHOTKEY_IME_NONIME_TOGGLE); 
end; 

//打开中文输入法 
procedure ToChinese(hWindows: THandle; bChinese: boolean); 
begin 
 if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then 
   ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle); 
end; 

//数据备份 
procedure BackUpData(LpBackDispMessTitle:String); 
var 
  i,j:integer; 
  Source,Dest:array[0..200]of char; 
  s1:string; 
  Lp:_SHFILEOPSTRUCTA; 
  Success:Integer; 
begin 
  if MessageBox(Application.Handle,' 您确认要备份数据吗？','询问窗口',4+32+256)=6 then 
  begin 
     with LP do 
     begin 
    Lp.wnd:=Application.Handle; 
        wFunc:=FO_COPY; 
        s1:='DATA\*.*'; 
        i:=Length(s1); 
        StrCopy(Source,PChar(s1)); 
        Source[i]:=#0; 
        Source[i+1]:=#0; 
        Source[i+2]:=#0; 
        pFrom:=Source; 
        s1:='BACKUP'; 
        j:=Length(s1); 
        StrCopy(Dest,PChar(s1)); 
        Dest[j]:='\'; 
        Dest[j+1]:=#0; 
        Dest[j+2]:=#0; 
        Dest[j+3]:=#0; 
        pTo:=Dest; 
        fFlags:=FOF_ALLOWUNDO; 
        fAnyOperationsAborted:=False; 
        lpszProgressTitle:=PChar(LpBackDispMessTitle); 
     end; 
    Success:=SHFileOperation(LP); 
     case Success of 
        0: 
           MessageBox(Application.Handle,' 所有数据已备份完成 ！','提示窗口',0+48); 
        117: 
           MessageBox(Application.Handle,Pchar(' 您未创建“'+ExtractFilePath(Application.ExeName)+'BACKUP”目录所以不能完成数据备份 ！'),'提示窗口',0+16) 
        else 
           MessageBox(Application.Handle,' 在备份数据的过程中被用户中途中断 ！','提示窗口',0+16); 
     end; 
  end; 
end; 

 


//////////////////////////////////////////////////////////////////////////////// 
//                                                                            // 
//                          从文件中读取Ado连接字串                           // 
//                                                                            // 
//////////////////////////////////////////////////////////////////////////////// 
function GetConnectionString(DataBaseName:string):string; 
var FileStringList:Tstringlist; 
   TempString: ansistring; 
   TheReg:TRegistry;KeyName,fAppPath:string; 
   i:Integer; 
begin 

 TheReg:=TRegistry.Create; 

 try 
   TheReg.RootKey:=HKEY_LOCAL_MACHINE; 
   KeyName:='Software\政府采购管理系统'; 
   if TheReg.OpenKey(KeyName,False) then 
     fAppPath:=TheReg.ReadString('ApplicationPath'); 
 finally 
   TheReg.Free; 
 end; 

 FileStringList:=Tstringlist.Create; 
 //先判断connection.txt是否存在,存在就调入 
 if FileExists(fAppPath+'\connection.txt') then 
    FileStringList.LoadFromFile(fAppPath+'\connection.txt') 
 else 
 begin 

     application.MessageBox('在系统所在目录中没有检测到连接文件(connection.txt)，无法启动系统。','提示',MB_IconError+mb_ok); 

     Result:=''; 
     FileStringList.Free; 
     Exit; 
 end; 
 //组成一个符串，好进行处理。 
 TempString:=''; 
 for i:=0 to FileStringList.Count-1 do 
 begin 
   TempString:=TempString+FileStringList.strings[i]; 
 end; 

 {连接指定名称的数据库} 
 TempString:=Replace(TempString,'DataBaseName',DataBaseName,False); 

 Result:=TempString; 

end; 


{------------------------------------------------------------------------------} 
{function GetRemoteServerName：返回远程服务器的机器名称} 
function GetRemoteServerName:string; 
var iniServer:TIniFile; 
   TheReg:TRegistry;KeyName,fAppPath,RServerName:string; 
begin 

 TheReg:=TRegistry.Create; 

 try 
   TheReg.RootKey:=HKEY_LOCAL_MACHINE; 
   KeyName:='Software\政府采购管理系统'; 

   if TheReg.OpenKey(KeyName,False) then 
     fAppPath:=TheReg.ReadString('ApplicationPath'); 
 finally 
   TheReg.Free; 
 end; 

 {创建远程服务器名称} 
 try 
   iniServer:=TIniFile.Create(fAppPath+'\RemoteServerName.ini'); 
   with iniServer do 
     RServerName:=ReadString('Option','RServerName',''); 
   iniServer.Free; 
 except 
   raise exception.Create('致命错误：未找到包含Com服务器配置的信息文件，初始化失败。'); 
 end; 
 Result:=RServerName; 

end; 

 

initialization 
 WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE); 
end.