SilverLong专栏

程序员的命运

系统公用函数及过程-Communal.pas

{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎                                                                          ▎}
{▎                       系统公用函数及过程                                 ▎}
{▎                                                                          ▎}
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎ 软件名称:  开发包基础库                                                 ▎}
{▎ 单元名称:  公共运行时间库单元                                           ▎}
{▎ 单元版本:  V1.0                                                         ▎}
{▎ 备    注:  该单元定义了组件包的基础类库                                 ▎}
{▎ 开发平台:  Windows2000 + Delphi 6.0                                     ▎}
{▎ 兼容测试:  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;

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

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

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

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

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

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

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

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

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

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

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

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

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

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

{* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串}
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;        {测试通过}

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

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

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

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

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

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

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

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

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

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

{随机字符串函数}
function RandomStr(aLength : Longint) : String;
// Unicode String --> ANSI string 中文格式编码
function UnicodeToAnsi(sStr:String):String;
// ANSI String --> Unicode string 中文格式编码
function AnsiToUnicode(sStr:String):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
  {* Byte类型位数范围}
  TByteBit = 0..7;

  {* Word类型位数范围}
  TWordBit = 0..15;
 
  {* DWord类型位数范围}
  TDWordBit = 0..31;
 
{* 设置二进制位}
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; {测试通过}

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

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

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

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

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

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

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

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

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

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

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

{* 创建备份文件}
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);

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

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

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

{* 文件打开方式}
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;    {测试通过}

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

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

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

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

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

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


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

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

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

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

{* 获取磁盘序列号}
function GetDiskSerial(DiskChar: Char): string;
{* 获取磁盘序列号}
function GetHDSerialNumber(Drv : String): String;{测试通过}
{* 获取磁盘序列号}
function GetHardDiskSerial(const DriveLetter: Char): string; {测试通过}

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

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

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

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


type
 TCPUID = array[1..4] of Longint;

{*获取CPU的标识ID号*}
function GetCPUID : TCPUID; assembler; register;

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


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


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

{* 获取网络计算机名称}
function GetComputerName:string;

{* 获取计算机的IP地址}
function GetHostIP:string;

{* // 运行平台:Windows NT/2000/XP
{* // Windows 95/98/Me平台:可以用该函数修改用户的Windows登录密码}
function NetUserChangePassword(Domain:PWideChar; UserName:PWideChar; OldPassword:PWideChar; NewPassword:PWideChar): LongInt; stdcall; external 'netapi32.dll' name 'NetUserChangePassword';

 

//▎============================================================▎//
//▎=====================⑨汉字拼音功能函数=====================▎//
//▎============================================================▎//

{* 取汉字的拼音}
function GetHzPy(const AHzStr: string): string;       {测试通过}

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


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

{* 物理删除数据库(Db,Dbf)中的数据[着了删除标记的记录]}
{function PackDbDbf(Var StatusMsg: String): Boolean;}


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

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

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

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

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

{* //建立新表}
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;

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

 

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

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

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


function TransChar(AChar: Char): Integer;

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

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

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

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

{* 交换两个数}
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;

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

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

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

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

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

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

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

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

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

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


//function ReadCursorPos(SourceMemo: TMemo): TPoint;

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

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

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

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

{* 小写金额转换为大写 }
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中
  参  数: sShort 短参数  sLong 长参数
  返回值: 成功:  True  失败:  False
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 扩展整数转字符串函数
  参  数: Value 目标数  Len 长度 FillChar  填充字(默认为0)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
begin
  Result := IntToStr(Value);
  while Length(Result) < Len do
    Result := FillChar + Result;
end;

{=================================================================
  功  能: 带分隔符的整数-字符转换
  参  数: Value 目标数  SpLen 长度(默认为3) Sp  填充字(默认为',')
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 返回字符串右边的字符
  参  数: Str 目标数  Len 长度
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 返回字符串左边的字符
  参  数: Str 目标数  Len 长度
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function StrLeft(Str: string; Len: Integer): string;
begin
  if Len >= Length(Str) then
    Result := Str
  else
    Result := Copy(Str, 1, Len);
end;


{=================================================================
  功  能: 字节转二进制串
  参  数: Value 字节数
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能: 返回空格串
  参  数: Len 长度
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function Spc(Len: Integer): string;
var
  i: Integer;
begin
  Result := '';
  for i := 0 to Len - 1 do
    Result := Result + ' ';
end;


{=================================================================
  功  能: 返回将指定字符s1用字符串s2替换后的字符串,可支持大小写敏感由CaseSensitive操作
  参  数: Str  s1指定字符 s2替换字符串 CaseSensitive支持大小写敏感
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能:
  参  数: pcChar  piCount
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function Replicate(pcChar:Char; piCount:integer):string;
begin
 Result:='';
 SetLength(Result,piCount);
 fillChar(Pointer(Result)^,piCount,pcChar)
end;

{=================================================================
  功  能: 返回某个字符串中某个字符串中出现的次数
  参  数: ShortStr  LongString
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 返回某个字符串中查找某个字符串的位置(在一个字符串中找某个字符的位置)
  参  数: ShortStr  LongString
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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字符串
  参  数: psInput原子串  BeginPlace开始位置 CutLeng结束位置
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String;
begin
 Result:=Copy(psInput,BeginPlace,CutLeng)
end;


{=================================================================
  功  能: 返回从左边第一为开始切取 CutLeng长度的字符串
  参  数: psInput原字串  CutLeng结束位置
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function LeftStr(psInput:String; CutLeng:Integer):String;
begin
 Result:=Copy(psInput,1,CutLeng)
end;


{=================================================================
  功  能: 返回从右边第一为开始切取 CutLeng长度的字符串
  参  数: psInput原字串  CutLeng结束位置
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function RightStr(psInput:String; CutLeng:Integer):String;
begin
 Result:=Copy(psInput,Length(psInput)-CutLeng+1,CutLeng)
end;


{=================================================================
  功  能: 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串
  参  数: psInput原字串  piWidth填充字符串 pcPadWith总长度
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
begin
 Result:=Replicate(pcPadWith,piWidth-Length(psInput))+psInput
end;


{=================================================================
  功  能: 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串
  参  数: psInput原字串  piWidth填充字符串 pcPadWith总长度
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;
begin
 Result:=psInput+Replicate(pcPadWith,piWidth-Length(psInput))
end;

{=================================================================
  功  能: 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串
  参  数: psInput原字串  piWidth填充字符串 pcPadWith总长度
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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'
  参  数: psInput原字串  pcSearch填充字符串 pcTranWith总长度
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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'
  参  数: psInput原字串  pcSearch字符串 pcTranWith字符串
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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'
  参  数: psInput原字串  pcSearch字符串 pcTranWith字符串
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 交换字串
  参  数: s1原字串  s2字符串
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure SwapStr(var s1, s2: string);
var
  tempstr: string;
begin
  tempstr := s1;
  s1 := s2;
  s2 := tempstr;
end;

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


{=================================================================
  功  能: 多行文本转单行(换行符转'/n')
  参  数: Lines多行文本
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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'转换行符)
  参  数: Str单行文本
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 字符串加密函数
  参  数: S字符串 Key密匙(关键字)
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 字符串解密函数
  参  数: S字符串 Key密匙(关键字)
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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为变体函数
  参  数: aTest TrueValue FalseValue
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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是否全是数字
  参  数: Value字符串
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 随机字符串函数
  参  数: Value字符串
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能: Unicode String --> ANSI string 中文格式编码
  参  数: sStr(Unicode字符串)
  返回值: ANSI String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function UnicodeToAnsi(sStr:String):String;
var
        sStr1: string;
        wStr: WideString;
        psStr1,psStr: PChar;
        iUnicode,i,len: Integer;
begin
        sStr1:='';
        // 为sStr1申请200字节的空间
        for i:=1 to 200 do sStr1:=sStr1+'-';
        psStr1:=PChar(sStr1);
        len:=Length(sStr);
        i:=1;
        while i<=len do
        begin
                // '554a' --> chr(0x55)+chr(0x4a)
                psStr:=PChar(sStr)+i-1;
                HexToBin(psStr, psStr1, 2);
                // chr(0x55)+chr(0x4a) --> 21834
                iUnicode:=ord(sStr1[1])*256+ord(sStr1[2]);
                // 21834 --> '啊'
                wStr:=wStr+WideChar(iUnicode);
                i:=i+4;
        end;
        Result:=String(wStr);
end;


{=================================================================
  功  能: ANSI String --> Unicode string 中文格式编码
  参  数: sStr(ANSI字符串)
  返回值: Unicode  String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function AnsiToUnicode(sStr:String):String;
var
        i,len: Integer;
        cur: Integer;
        t: String;
        s: WideString;
begin
        s:= WideString(sStr);
        Result:='';
        len:=Length(s);
        i:=1;
        while i<=len do
        begin
                cur:=ord(s[i]);
                FmtStr(t,'%4.4X',[cur]); // ???? <-- 钱勤
                Result:=Result+t;
                inc(i);
        end;
end;

 

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

{=================================================================
  功  能: 根据日期得到年份
  参  数: Date 日期
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetYear(Date: TDate): Integer;
var
  y, m, d: WORD;
begin
  DecodeDate(Date, y, m, d);
  Result := y;
end;

{=================================================================
  功  能: 根据日期得到月份
  参  数: Date 日期
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetMonth(Date: TDate): Integer;
var
  y, m, d: WORD;
begin
  DecodeDate(Date, y, m, d);
  Result := m;
end;

{=================================================================
  功  能: 根据日期得到日(即当前几号)
  参  数: Date 日期
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetDay(Date: TDate): Integer;
var
  y, m, d: WORD;
begin
  DecodeDate(Date, y, m, d);
  Result := d;
end;

{=================================================================
  功  能: 根据时间得到小时数
  参  数: Time 时间
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetHour(Time: TTime): Integer;
var
  h, m, s, ms: WORD;
begin
  DecodeTime(Time, h, m, s, ms);
  Result := h;
end;

{=================================================================
  功  能: 根据时间得到f分钟数
  参  数: Time 时间
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetMinute(Time: TTime): Integer;
var
  h, m, s, ms: WORD;
begin
  DecodeTime(Time, h, m, s, ms);
  Result := m;
end;

{=================================================================
  功  能: 根据时间得到秒数
  参  数: Time 时间
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetSecond(Time: TTime): Integer;
var
  h, m, s, ms: WORD;
begin
  DecodeTime(Time, h, m, s, ms);
  Result := s;
end;

{=================================================================
  功  能: 根据时间得到微秒数
  参  数: Time 时间
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetMSecond(Time: TTime): Integer;
var
  h, m, s, ms: WORD;
begin
  DecodeTime(Time, h, m, s, ms);
  Result := ms;
end;


{=================================================================
  功  能: 传入年、月,得到该月份最后一天
  参  数: Cs_Year年 Cs_Month月
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 判断某年是否为闰年
  参  数: nYear年份(整数)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function IsLeapYear( nYear: Integer ): Boolean;
begin
  Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod 400 = 0));
end;


{=================================================================
  功  能: 两个日期取较大的日期
  参  数: Values 时间磋(日期+时间)
  返回值: TDateTime
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 两个日期取较小的日期
  参  数: Values 时间磋(日期+时间)
  返回值: TDateTime
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 得到本月的第一一天
  参  数: D 时间磋(日期+时间)
  返回值: TDateTime
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function dateBeginOfMonth(D: TDateTime): TDateTime;
var
  Year, Month, Day: Word;
begin
  DecodeDate(D, Year, Month, Day);
  Result := EncodeDate(Year, Month, 1);
end;


{=================================================================
  功  能: 得到本月的最后一天
  参  数: D 时间磋(日期+时间)
  返回值: TDateTime
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 得到本年的最后一天
  参  数: D 时间磋(日期+时间)
  返回值: TDateTime
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function dateEndOfYear(D: TDateTime): TDateTime;
var
  Year, Month, Day: Word;
begin
  DecodeDate(D, Year, Month, Day);
  Result := EncodeDate(Year, 12, 31);
end;


{=================================================================
  功  能: 得到两个日期相隔的天数
  参  数: D 时间磋(日期+时间)
  返回值: TDateTime
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function DaysBetween(Date1, Date2: TDateTime): integer;
begin
  Result := Trunc(Date2) - Trunc(Date1) + 1;
  if Result < 0 then Result := 0;
end;


//▎============================================================▎//
//▎=====================③位操作函数===========================▎//
//▎============================================================▎//


{=================================================================
  功  能: 设置位
  参  数: Value字节 BitByte类型位数范围 IsSet(Boolean)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 设置位
  参  数: ValueWord类型 BitWord类型位数范围 IsSet(Boolean)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能: 设置位
  参  数: Value DWORD类型 BitDWord类型位数范围 IsSet(Boolean)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 取位
  参  数: Value 字节 BitByte类型位数范围
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetBit(Value: Byte; Bit: TByteBit): Boolean;
begin
  Result := Value and (1 shl Bit) <> 0;
end;

{=================================================================
  功  能: 取位
  参  数: Value(Word 0..65535 unsigned 16-bi) BitWord类型位数范围
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetBit(Value: WORD; Bit: TWordBit): Boolean;
begin
  Result := Value and (1 shl Bit) <> 0;
end;

{=================================================================
  功  能: 取位
  参  数: Value(Longword ) BitDWord类型位数范围
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;
begin
  Result := Value and (1 shl Bit) <> 0;
end;

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


{=================================================================
  功  能: 移动文件、目录
  参  数: sName(原) dName(目标)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 打开文件属性窗口
  参  数: FName(文件)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 缩短显示不下的长路径名
  参  数: APath(长路径) Width(长度)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 打开文件框
  参  数: FileName(文件名) Title(题头) Filter(分隔符) Ext(标签)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 取两个目录的相对路径,注意串尾不能是'/'字符!
  参  数: Source(原路径) Dest(目标路径)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 运行一个文件
  参  数: FName(文件名) Handle(句柄) Param(参数)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure RunFile(const FName: string; Handle: THandle;
  const Param: string);
begin
  ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;


{=================================================================
  功  能: 运行一个文件并等待其结束
  参  数: FileName(文件名) Visibility(明显度)
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 应用程序路径
  参  数: 无
  返回值: string(应用程序路径)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function AppPath: string;
begin
  Result := ExtractFilePath(Application.ExeName);
end;


{=================================================================
  功  能: 取Windows系统目录
  参  数: 无
  返回值: string(Windows系统目录)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetWindowsDir: string;
var
  Buf: array[0..MAX_PATH] of Char;
begin
  GetWindowsDirectory(Buf, MAX_PATH);
  Result := AddDirSuffix(Buf);
end;


{=================================================================
  功  能: 取临时文件目录
  参  数: 无
  返回值: string(临时文件目录)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetWinTempDir: string;
var
  Buf: array[0..MAX_PATH] of Char;
begin
  GetTempPath(MAX_PATH, Buf);
  Result := AddDirSuffix(Buf);
end;


{=================================================================
  功  能: 目录尾加'/'修正
  参  数: Dir(目录)
  返回值: string(目录尾加'/'修正)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function AddDirSuffix(Dir: string): string;
begin
  Result := Trim(Dir);
  if Result = '' then Exit;
  if Result[Length(Result)] <> '/' then Result := Result + '/';
end;

{=================================================================
  功  能: 新建目录
  参  数: Dir(目录)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function MakePath(Dir: string): string;
begin
  Result := AddDirSuffix(Dir);
end;


{=================================================================
  功  能: 判断文件是否正在使用
  参  数: FName(文件)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 取文件长度
  参  数: FName(文件)
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 设置文件时间
  参  数: FileName(文件)
          CreationTime(创建时间)
          LastWriteTime(最后写入时间)
          LastAccessTime(最后访问时间)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 取文件时间
  参  数: FileName(文件)
          CreationTime(创建时间)
          LastWriteTime(最后写入时间)
          LastAccessTime(最后访问时间)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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"
  参  数: FileName(文件)
          Icon(图标)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 文件时间转本地时间
  参  数: FTime(文件时间)
  返回值: TSystemTime(系统时间)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
var
  STime: TSystemTime;
begin
  FileTimeToLocalFileTime(FTime, FTime);
  FileTimeToSystemTime(FTime, STime);
  Result := STime;
end;


{=================================================================
  功  能: 本地时间转文件时间
  参  数: STime(系统时间)
  返回值: TSystemTime(文件时间)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
var
  FTime: TFileTime;
begin
  SystemTimeToFileTime(STime, FTime);
  LocalFileTimeToFileTime(FTime, FTime);
  Result := FTime;
end;


{=================================================================
  功  能: 创建备份文件
  参  数: FileName(文件名) Ext(文件后缀)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function CreateBakFile(FileName, Ext: string): Boolean;
var
  BakFileName: string;
begin
  BakFileName := FileName + '.' + Ext;
  Result := CopyFile(PChar(FileName), PChar(BakFileName), False);
end;


{=================================================================
  功  能: 删除整个目录
  参  数: Dir(目录)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 取文件夹文件数
  参  数: Dir(目录)
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 查找指定目录下文件
  参  数: Path(目录)
          FileName(目标文件)
          Proc
          bSub
          bMsg
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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(是否包含子目录)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;
 

{=================================================================
  功  能: 返回一文本文件的行数
  参  数: txt(文本文件)
  返回值: integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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文件转化成文本文件
  参  数: htmlfilename(Html文件)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 文件打开方式
  参  数: FileName(文件)
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function OpenWith(const FileName: string): Integer;
begin
  Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe',
    PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);
end;


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


{=================================================================
  功  能: 显示提示窗口
  参  数: Mess(消息)  Caption(标题) Flags(标志)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;

 
{=================================================================
  功  能: 显示提示确认窗口
  参  数: Mess(消息)  Caption(标题)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function InfoOk(Mess: string; Caption: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_OK + MB_ICONINFORMATION) = IDOK;
end;


{=================================================================
  功  能: 显示错误窗口
  参  数: Mess(消息)  Caption(标题)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure ErrorDlg(Mess: string; Caption: string);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;


{=================================================================
  功  能: 显示警告窗口
  参  数: Mess(消息)  Caption(标题)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure WarningDlg(Mess: string; Caption: string);
begin
  Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;


{=================================================================
  功  能: 显示查询是否窗口
  参  数: Mess(消息)  Caption(标题)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function QueryDlg(Mess: string; Caption: string): Boolean;
begin
  Result := Application.MessageBox(PChar(Mess), PChar(Caption),
    MB_YESNO + MB_ICONQUESTION) = IDYES;
end;


{=================================================================
  功  能: 窗体渐变
  参  数: Sender(窗体)  IsSetAni(是否渐变)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

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

 

{=================================================================
  功  能: 移动鼠标到控件
  参  数: AWinControl(控件)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 动态设置分辨率
  参  数: x(X轴) y(Y轴)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 窗口最上方显示
  参  数: x(X轴) y(Y轴)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 设置程序是否出现在任务栏
  参  数: Hide(是否显示 True 显示 False不显示)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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);


{=================================================================
  功  能: 设置任务栏是否可见
  参  数: Visible(是否显示 True 显示 False不显示)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure SetTaskBarVisible(Visible: Boolean);
var
  wndHandle: THandle;
begin
  wndHandle := FindWindow('Shell_TrayWnd', nil);
  ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;


{=================================================================
  功  能: 设置桌面是否可见
  参  数: Visible(是否显示 True 显示 False不显示)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure SetDesktopVisible(Visible: Boolean);
var
  hDesktop: THandle;
begin
  hDesktop := FindWindow('Progman', nil);
  ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;


{=================================================================
  功  能: 显示等待光标
  参  数: 无
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure BeginWait;
begin
  Screen.Cursor := crHourGlass;
end; 


{=================================================================
  功  能: 结束等待光标
  参  数: 无
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure EndWait;
begin
  Screen.Cursor := crDefault;
end;


{=================================================================
  功  能:  检测是否Win95/98平台
  参  数: 无
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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
  参  数: 无
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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登录名的用户
  参  数: 无
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能: 根据参数从注册表中获取当前Windows登录名的用户
  参  数: UserKeyType
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 获取操作系统版本号
  参  数: 无
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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启动模式
  参  数: 无
  返回值: String
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function WinBootMode:string;
begin
   case(GetSystemMetrics(SM_CLEANBOOT)) of
      0:Result:='正常模式启动';
      1:Result:='安全模式启动';
      2:Result:='安全模式启动,但附带网络功能';
   else
      Result:='错误:系统启动有问题。';
   end;
end;


{=================================================================
  功  能: Windows ShutDown等
  参  数: ShutWinType PForce
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


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

{=================================================================
  功  能:
  参  数: 无
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 声卡是否存在
  参  数: 无
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function SoundCardExist: Boolean;
begin
  Result := WaveOutGetNumDevs > 0;
end;


{=================================================================
  功  能: 获取磁盘序列号
  参  数: DiskChar(磁盘盘符)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 获取磁盘序列号
  参  数: DiskChar(磁盘盘符)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetHDSerialNumber(Drv : String): String;
var
  VolumeSerialNumber : DWORD;
  MaximumComponentLength : DWORD;
  FileSystemFlags : DWORD;
begin
  if Drv[Length(Drv)] =':' then Drv := Drv + '/';
  GetVolumeInformation(pChar(Drv),nil,0,@VolumeSerialNumber,
    MaximumComponentLength,FileSystemFlags, nil,0);

  Result := IntToHex(HiWord(VolumeSerialNumber), 4) +'-' +
          IntToHex(LoWord(VolumeSerialNumber), 4);
end;

{=================================================================
  功  能: 获取磁盘序列号
  参  数: DiskChar(磁盘盘符)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetHardDiskSerial(const DriveLetter: Char): string;
var
  NotUsed: DWORD;
  VolumeFlags: DWORD;
  VolumeInfo: array[0..MAX_PATH] of Char;
  VolumeSerialNumber: DWORD;
begin
  GetVolumeInformation(PChar(DriveLetter + ':/'),
  nil, SizeOf(VolumeInfo), @VolumeSerialNumber, NotUsed,
  VolumeFlags, nil, 0);
  Result := Format('Label = %s VolSer = %8.8X',
  [VolumeInfo, VolumeSerialNumber])
end;


{=================================================================
  功  能: 检查磁盘准备是否就绪
  参  数: Root(磁盘盘符)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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中磁盘的是否有文件及文件状态
  参  数: driveletter(驱动 证书)
  返回值: TDriveState(驱动状态)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 写串口
  参  数: wPort(端口--Word类型) bValue(值--字节类型)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure WritePortB( wPort : Word; bValue : Byte );
begin
   asm
   mov dx, wPort
   mov al, bValue
   out dx, al
   end;
end;


{=================================================================
  功  能: 读串口
  参  数: wPort(端口--Word类型)
  返回值: Byte(值--字节类型)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function ReadPortB( wPort : Word ):Byte;
begin
   asm
   mov dx, wPort
   in al, dx
   mov result, al
   end;
end;


{=================================================================
  功  能: 获知当前机器CPU的速率(MHz)
  参  数: 无
  返回值: Double
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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号
  参  数: 无
  返回值: TCPUID
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 获取计算机的物理内存
  参  数: 无
  返回值: Dword
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetMemoryTotalPhys : Dword;
var
   memStatus: TMemoryStatus;
begin
   memStatus.dwLength := sizeOf ( memStatus );
   GlobalMemoryStatus ( memStatus );
   Result := memStatus.dwTotalPhys div 1024;
end;


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

 

{=================================================================
  功  能: 获取网络计算机名称
  参  数: 无
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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地址
  参  数: 无
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

//▎============================================================▎//
//▎=====================⑨汉字拼音功能函数=====================▎//
//▎============================================================▎//


{=================================================================
  功  能: 取汉字的拼音
  参  数: 无
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 判断一个字符串中有多少各汉字
  参  数: s字符串
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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)中的数据[着了删除标记的记录]
  参  数: StatusMsg字符串
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
{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;}

{=================================================================
  功  能:
  参  数: DbName NewDbName字符串
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
{procedure CompactDb(DbName, NewDbName: string);
var
   dao: OLEVariant;
begin
   dao := CreateOleObject('DAO.DBEngine.35');
   dao.CompactDatabase(DbName, NewDbName);
end;}


{=================================================================
  功  能: 修复Access表
  参  数: DbName字符串
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure RepairDb(DbName: string);
var
   Dao: OLEVariant;
begin
   Dao := CreateOleObject('DAO.DBEngine.35');
   Dao.RepairDatabase(DbName);
end;


{=================================================================
  功  能: 通过注册表创建ODBC配置[创建在系统DSN页下]
  参  数: ODBCSourceName(ODBC连接字符串)
          ServerName(服务器名称)
          DataBaseDescription(数据库描述)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能: 用Ado连接SysBase数据库函数
  参  数: Adocon(连接字符串)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;
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连接数据库函数
  参  数: Adocon(连接字符串)
          Dbname(数据库名)
          DBServerName(数据库服务器名)
          ValidateMode(验证模式)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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共同连接数据库函数
  参  数: Adocon(连接字符串)
          Dbname(数据库名)
          ValidateMode(验证模式)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 在指定的数据库中建立表(建立新表)
  参  数: LpDataBaseName(数据库名)
          LpTableName(表名)
          LpSentence(句子)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 在指定的表中新填字段
  参  数: LpFieldName(字段名)
          LpDataType(字段类型)
          LpSize(大小)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 在指定的表中删除字段
  参  数: LpFieldName(字段名)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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语句执行体
  参  数: LpDataBaseName(数据库名)
          LpSentence(句子)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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句体
  参  数: LpTableName(表名)
          LpSQLsentence(SQL句子)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function GetSQLSentence(LpTableName,LpSQLsentence:string): string;
begin
  Result := 'ALTER TABLE "'+ LpTableName +'" ' + LpSQLSentence + ';';
end;


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


{=================================================================
  功  能: 字符转化成十六进制
  参  数: AStr(字符)
  返回值: string(十六进制)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 十六进制转化成字符
  参  数: AStr(十六进制)
  返回值: string(字符)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能:
  参  数: AChar
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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之间
  参  数: Value(原)
          Min(最小范围)
          Max(最大范围)
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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之间
  参  数: Value(原)
  返回值: Byte
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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分离出坐标、宽高
  参  数: Rect(结构)
          x(X轴)
          y(Y轴)
          Width(宽度)
          Height(高度)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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
  参  数: Rect1(结构1) Rect2(结构2)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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类型
  参  数: cx() cy()
  返回值: TSize
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function EnSize(cx, cy: Integer): TSize;
begin
  Result.cx := cx;
  Result.cy := cy;
end;


{=================================================================
  功  能: 计算Rect的宽度
  参  数: Rect
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function RectWidth(Rect: TRect): Integer;
begin
  Result := Rect.Right - Rect.Left;
end;


{=================================================================
  功  能: 计算Rect的高度
  参  数: Rect
  返回值: Integer
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function RectHeight(Rect: TRect): Integer;
begin
  Result := Rect.Bottom - Rect.Top;
end;


{=================================================================
  功  能: 判断范围
  参  数: Value Min  Max
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
  Result := (Value >= Min) and (Value <= Max);
end;


{=================================================================
  功  能: 交换两个数
  参  数: A B [Byte]
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure CnSwap(var A, B: Byte); overload;
var
  Tmp: Byte;
begin
  Tmp := A;
  A := B;
  B := Tmp;
end;

{=================================================================
  功  能: 交换两个数
  参  数: A B  [Integer]
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure CnSwap(var A, B: Integer); overload;
var
  Tmp: Integer;
begin
  Tmp := A;
  A := B;
  B := Tmp;
end;

{=================================================================
  功  能: 交换两个数
  参  数: A B [Single]
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure CnSwap(var A, B: Single); overload;
var
  Tmp: Single;
begin
  Tmp := A;
  A := B;
  B := Tmp;
end;

{=================================================================
  功  能: 交换两个数
  参  数: A B [Double]
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure CnSwap(var A, B: Double); overload;
var
  Tmp: Double;
begin
  Tmp := A;
  A := B;
  B := Tmp;
end;


{=================================================================
  功  能: 延时
  参  数: uDelay
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure Delay(const uDelay: DWORD);
var
  n: DWORD;
begin
  n := GetTickCount;
  while ((GetTickCount - n) <= uDelay) do
    Application.ProcessMessages;
end;

 
{=================================================================
  功  能: 在Win9X下让喇叭发声
  参  数: Freq(频数--默认值1200)  Delay( 延迟--默认值1)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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运行结果信息
  参  数: 无
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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文件
  参  数: FS(字体) inifile(INI文件) write(是否写入)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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文件
  参  数: inifile(INI文件)
  返回值: TFontStyles(字体)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


//function ReadCursorPos(SourceMemo: TMemo): TPoint;
{=================================================================
  功  能: 取得TMemo 控件当前光标的行和列信息到Tpoint中
  参  数: SourceMemo(TMemo)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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功能
  参  数: AMemo(TMemo)
  返回值: Boolean(成功:  True  失败:  False)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
function CanUndo(AMemo: TMemo): Boolean;
begin
   Result :=AMemo.Perform(EM_CANUNDO, 0, 0)<>0;
end;


{=================================================================
  功  能: 实现Undo功能
  参  数: AMemo(TMemo)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure Undo(Amemo: Tmemo);
begin
   Amemo.Perform(EM_UNDO, 0, 0);
end;


{=================================================================
  功  能: 实现ComBoBox自动下拉
  参  数: ACombox(TComboBox)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure AutoListDisplay(ACombox:TComboBox);
begin
   SendMessage(ACombox.handle, CB_SHOWDROPDOWN, Integer(True), 0);
end;


{=================================================================
  功  能: 小写金额转换为大写
  参  数: small(小写金额)
  返回值: string(大写)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 利用系统时间产生随机数
  参  数: Num(数)
  返回值: integer(随机数)
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;

{=================================================================
  功  能: 打开输入法
  参  数: ImeName(输入法)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 关闭输入法
  参  数: 无
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure CloseIME;
var
  MyHKL: hkl;
begin
  MyHKL := GetKeyboardLayout(0);
  if ImmIsIme(MyHKL) then
    ImmSimulateHotKey(Application.Handle, IME_CHOTKEY_IME_NONIME_TOGGLE);
end;


{=================================================================
  功  能: 打开中文输入法
  参  数: hWindows(句柄)  bChinese(是否中文)
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
procedure ToChinese(hWindows: THandle; bChinese: boolean);
begin
  if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then
    ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle);
end;


{=================================================================
  功  能: 数据备份
  参  数: LpBackDispMessTitle()
  返回值: 无
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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连接字串
  参  数: DataBaseName(数据库名称)
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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;


{=================================================================
  功  能: 返回远程服务器的机器名称
  参  数: 无
  返回值: string
  备 注:
  版 本:
     1.0  2005/10/09 09:55:00
=================================================================}
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.


阅读更多
个人分类: DELPHI
上一篇耐人寻味
下一篇BaseFunction.pas
想对作者说点什么? 我来说一句

Communal.pas

2012年07月27日 89KB 下载

WINCE5.0中断机制

2011年01月23日 662KB 下载

复变函数及应用(英文版第八版)

2011年02月26日 9.61MB 下载

复变函数及应用(第七版)答案

2010年01月04日 3.69MB 下载

MATLAB使用技巧

2009年09月20日 24KB 下载

复变函数及其应用(原书第九版)

2018年04月13日 58.97MB 下载

matlab函数及指令

2008年09月08日 20KB 下载

Uchome函数及注释

2011年11月17日 157KB 下载

没有更多推荐了,返回首页

关闭
关闭