delphi 实用函数

{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}

{▎ QQ:35013354 ▎}

{▎ 系统公用函数及过程 ▎}

{▎ ▎}

{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}

{▎ 软件名称：开发包基础库 ▎}

{▎ 单元名称：公共运行时间库单元 ▎}

{▎ 单元版本： V1.0 ▎}

{▎ 备注：该单元定义了组件包的基础类库 ▎}

{▎ 开发平台： PWin98SE + Delphi 6.0 ▎}

{▎ 兼容测试： PWin9X/2000/XP + Delphi 6.0 ▎}

{▎ 本地化：该单元中的字符串均符合本地化处理方式 ▎}

{▎ 更新记录： 2002.07.03 V2.0 ▎}

{▎ 整理单元，重设版本号 ▎}

{▎ 2002.03.17 V0.02 ▎}

{▎ 新增部分函数，并部分修改 ▎}

{▎ 2002.01.30 V0.01 ▎}

{▎ 创建单元（整理而来） ▎}

{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}

{▎ ①: 扩展的字符串操作函数 ▎}

{▎ ②: 扩展的日期时间操作函数 ▎}

{▎ ③: 扩展的位操作函数 ▎}

{▎ ④: 扩展的文件及目录操作函数 ▎}

{▎ ⑤: 扩展的对话框函数 ▎}

{▎ ⑥: 系统功能函数 ▎}

{▎ ⑦: 硬件功能函数 ▎}

{▎ ⑧: 网络功能函数 ▎}

{▎ ⑨: 汉字拼音函数及过程 ▎}

{▎ ⑩: 数据库功能函数 ▎}

{▎ ⑾: 进制功能函数 ▎}

{▎ ⑿: 其它功能函数 ▎}

{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}

unit Communal;

{* |

interface

{$I CnPack.inc}

uses

Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,

FileCtrl, ShellAPI, CommDlg, MMSystem, WinSock, IniFiles, DBTables, BDE,

StdCtrls, ComObj, ADODB, Imm, DbCtrls, Db, Registry;

const

// 公共信息

{$IFDEF GB2312}

SCnInformation = '提示';

SCnWarning = '警告';

SCnError = '错误';

{$ELSE}

SCnInformation = 'Information';

SCnWarning = 'Warning';

SCnError = 'Error';

{$ENDIF}

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

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

resourcestring

{$IFDEF GB2312}

SUnknowError = '未知错误';

SErrorCode = '错误代码：';

{$ELSE}

SUnknowError = 'Unknow error';

SErrorCode = 'Error code:';

{$ENDIF}

type

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

//▎============================================================▎//

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

//▎============================================================▎//

//从文件中返回Ado连接字串。

function GetConnectionString(DataBaseName:string):string;

//返回服务器的机器名称.

function GetRemoteServerName:string;

function InStr(const sShort: string; const sLong: string): Boolean; {测试通过}

{* 判断s1是否包含在s2中}

function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string; {测试通过}

{* 扩展整数转字符串函数 Example: IntToStrEx(1,5,'0'); 返回："00001"}

function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string; {测试通过}

{* 带分隔符的整数－字符转换}

function ByteToBin(Value: Byte): string; {测试通过}

{* 字节转二进制串}

function StrRight(Str: string; Len: Integer): string; {测试通过}

{* 返回字符串右边的字符 Examples: StrRight('ABCEDFG',3); 返回:'DFG' }

function StrLeft(Str: string; Len: Integer): string; {测试通过}

{* 返回字符串左边的字符}

function Spc(Len: Integer): string; {测试通过}

{* 返回空格串}

function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string; {测试通过}

{* 返回将指定字符s1用字符串s2替换后的字符串，可支持大小写敏感由CaseSensitive操作}

{example: replace('We know what we want','we','I',false) = 'I Know what I want'}

function Replicate(pcChar:Char; piCount:integer):string;

{在一个字符串中查找某个字符串的位置}

function StrNum(ShortStr:string;LongString:string):Integer; {测试通过}

{* 返回某个字符串中某个字符串中出现的次数}

function FindStr(ShortStr:String;LongStrIng:String):Integer; {测试通过}

{* 返回某个字符串中查找某个字符串的位置}

function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String; {测试通过}

{* 返回从位置BeginPlace开始切取长度为CatLeng字符串}

function LeftStr(psInput:String; CutLeng:Integer):String; {测试通过}

{* 返回从左边第一为开始切取 CutLeng长度的字符串}

function RightStr(psInput:String; CutLeng:Integer):String; {测试通过}

{* 返回从右边第一为开始切取 CutLeng长度的字符串}

function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; {测试通过}

{* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串}

function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; {测试通过}

{* 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串}

function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String; {测试通过}

{* 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串}

function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String; {测试通过}

{* 返回替换后字符串[替换单个字符] Examples: ChrTran('abCdEgdlkh','d','#')；返回'abC#Eg#lkh'}

function StrTran(psInput:String; psSearch:String; psTranWith:String):String; {测试通过}

{* 返回替换后字符串[替换字符串] Examples: StrTran('aruyfbn','ruy','=====');；返回'a=====fbn'}

function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String;

{ *返回替换后字符串[替换字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345')；返回'AB12345GHI'}

procedure SwapStr(var s1, s2: string); {测试通过}

{* 交换字串}

function LinesToStr(const Lines: string): string; {测试通过}

{* 多行文本转单行（换行符转'/n'）}

function StrToLines(const Str: string): string; {测试通过}

{* 单行文本转多行（'/n'转换行符）}

function Encrypt(const S: String; Key: Word): String;

{* 字符串加密函数}

function Decrypt(const S: String; Key: Word): String;

{* 字符串解密函数}

function varIIF(aTest: Boolean; TrueValue, FalseValue: Variant): Variant;

function varToStr(const V: Variant): string;

{* VarIIF及VartoStr为变体函数}

function IsDigital(Value: string): boolean;

{功能说明：判断string是否全是数字}

function RandomStr(aLength : Longint) : String;

{随机字符串函数}

//▎============================================================▎//

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

//▎============================================================▎//

function GetYear(Date: TDate): Integer; {测试通过}

{* 取日期年份分量}

function GetMonth(Date: TDate): Integer; {测试通过}

{* 取日期月份分量}

function GetDay(Date: TDate): Integer; {测试通过}

{* 取日期天数分量}

function GetHour(Time: TTime): Integer; {测试通过}

{* 取时间小时分量}

function GetMinute(Time: TTime): Integer; {测试通过}

{* 取时间分钟分量}

function GetSecond(Time: TTime): Integer; {测试通过}

{* 取时间秒分量}

function GetMSecond(Time: TTime): Integer; {测试通过}

{* 取时间毫秒分量}

function GetMonthLastDay(Cs_Year,Cs_Month:string):string;

{ *传入年、月，得到该月份最后一天}

function IsLeapYear( nYear: Integer ): Boolean;

{*/判断某年是否为闰年}

function MaxDateTime(const Values: array of TDateTime): TDateTime;

{//两个日期取较大的日期}

function MinDateTime(const Values: array of TDateTime): TDateTime;

{//两个日期取较小的日期}

function dateBeginOfMonth(D: TDateTime): TDateTime;

{//得到本月的第一天}

function DateEndOfMonth(D: TDateTime): TDateTime;

{//得到本月的最后一天}

function DateEndOfYear(D: TDateTime): TDateTime;

{//得到本年的最后一天}

function DaysBetween(Date1, Date2: TDateTime): integer;

{//得到两个日期相隔的天数}

//▎============================================================▎//

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

//▎============================================================▎//

type

TByteBit = 0..7;

{* Byte类型位数范围}

TWordBit = 0..15;

{* Word类型位数范围}

TDWordBit = 0..31;

{* DWord类型位数范围}

procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;

{* 设置二进制位}

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

{* 设置二进制位}

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

{* 设置二进制位}

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

{* 取二进制位}

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

{* 取二进制位}

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

{* 取二进制位}

//▎============================================================▎//

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

//▎============================================================▎//

function MoveFile(const sName, dName: string): Boolean; {测试通过}

{* 移动文件、目录，参数为源、目标名}

procedure FileProperties(const FName: string); {测试通过}

{* 打开文件属性窗口}

function OpenDialog(var FileName: string; Title: string; Filter: string;

Ext: string): Boolean;

{* 打开文件框}

function FormatPath(APath: string; Width: Integer): string; {测试通过}

{* 缩短显示不下的长路径名}

function GetRelativePath(Source, Dest: string): string; {测试通过}

{* 取两个目录的相对路径,注意串尾不能是'/'字符！}

procedure RunFile(const FName: string; Handle: THandle = 0;

const Param: string = ''); {测试通过}

{* 运行一个文件}

function WinExecAndWait32(FileName: string; Visibility: Integer = SW_NORMAL):

Integer; {测试通过}

{* 运行一个文件并等待其结束}

function AppPath: string; {测试通过}

{* 应用程序路径}

function GetWindowsDir: string; {测试通过}

{* 取Windows系统目录}

function GetWinTempDir: string; {测试通过}

{* 取临时文件目录}

function AddDirSuffix(Dir: string): string; {测试通过}

{* 目录尾加'/'修正}

function MakePath(Dir: string): string; {测试通过}

{* 目录尾加'/'修正}

function IsFileInUse(FName: string): Boolean; {测试通过}

{* 判断文件是否正在使用}

function GetFileSize(FileName: string): Integer; {测试通过}

{* 取文件长度}

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

TFileTime): Boolean; {测试通过}

{* 设置文件时间 Example: FileSetDate('c:/Test/Test1.exe',753160662); }

function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:

TFileTime): Boolean; {测试通过}

{* 取文件时间}

function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime; {测试通过}

{* 文件时间转本地时间}

function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime; {测试通过}

{* 本地时间转文件时间}

function GetFileIcon(FileName: string; var Icon: TIcon): Boolean; {测试通过}

{* 取得与文件相关的图标，成功则返回True}

function CreateBakFile(FileName, Ext: string): Boolean; {测试通过}

{* 创建备份文件}

function Deltree(Dir: string): Boolean; {测试通过}

{* 删除整个目录}

function GetDirFiles(Dir: string): Integer; {测试通过}

{* 取文件夹文件数}

type

TFindCallBack = procedure(const FileName: string; const Info: TSearchRec;

var Abort: Boolean);

{* 查找指定目录下文件的回调函数}

procedure FindFile(const Path: string; const FileName: string = '*.*';

Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);

{* 查找指定目录下文件}

procedure FindFileList(Path,Filter:string;FileList:TStrings;ContainSubDir:Boolean);

{ 功能说明：查找一个路径下的所有文件。

参数： path:路径,filter:文件扩展名过滤,FileList:文件列表, ContainSubDir:是否包含子目录}

function Txtline(const txt: string): integer;

{* 返回一文本文件的行数}

function Html2Txt(htmlfilename: string): string;

{* Html文件转化成文本文件}

function OpenWith(const FileName: string): Integer; {测试通过}

{* 文件打开方式}

//▎============================================================▎//

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

//▎============================================================▎//

procedure InfoDlg(Mess: string; Caption: string = SCnInformation; Flags: Integer

= MB_OK + MB_ICONINFORMATION); {测试通过}

{* 显示提示窗口}

function InfoOk(Mess: string; Caption: string = SCnInformation): Boolean; {测试通过}

{* 显示提示确认窗口}

procedure ErrorDlg(Mess: string; Caption: string = SCnError); {测试通过}

{* 显示错误窗口}

procedure WarningDlg(Mess: string; Caption: string = SCnWarning); {测试通过}

{* 显示警告窗口}

function QueryDlg(Mess: string; Caption: string = SCnInformation): Boolean; {测试通过}

{* 显示查询是否窗口}

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

//▎============================================================▎//

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

//▎============================================================▎//

procedure MoveMouseIntoControl(AWinControl: TControl); {测试通过}

{* 移动鼠标到控件}

function DynamicResolution(x, y: WORD): Boolean; {测试通过}

{* 动态设置分辨率}

procedure StayOnTop(Handle: HWND; OnTop: Boolean); {测试通过}

{* 窗口最上方显示}

procedure SetHidden(Hide: Boolean); {测试通过}

{* 设置程序是否出现在任务栏}

procedure SetTaskBarVisible(Visible: Boolean); {测试通过}

{* 设置任务栏是否可见}

procedure SetDesktopVisible(Visible: Boolean); {测试通过}

{* 设置桌面是否可见}

procedure BeginWait; {测试通过}

{* 显示等待光标}

procedure EndWait; {测试通过}

{* 结束等待光标}

function CheckWindows9598NT: string; {测试通过}

{* 检测是否Win95/98/NT平台}

function GetOSInfo : String; {测试通过}

{* 取得当前操作平台是 Windows 95/98 还是NT}

function GetCurrentUserName : string;

{*获取当前Windows登录名的用户}

function GetRegistryOrg_User(UserKeyType:string):string;

{*获取当前注册的单位及用户名称}

function GetSysVersion:string;

{*//获取操作系统版本号}

function WinBootMode:string;

{//Windows启动模式}

type

PShutType = (UPowerOff, UShutdown, UReboot, ULogOff, USuspend, UHibernate);

procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean);

{//Windows ShutDown等}

//▎============================================================▎//

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

//▎============================================================▎//

function GetClientGUID:string;

{ 功能描述：在本机上得到一个GUID.去掉两端的大括号和中间的横线

返回值：去掉两端的大括号和中间的横线的一个GUID

适用范围：windows

}

function SoundCardExist: Boolean; {测试通过}

{* 声卡是否存在}

function GetDiskSerial(DiskChar: Char): string;

{* 获取磁盘序列号}

function DiskReady(Root: string) : Boolean;

{*检查磁盘准备是否就绪}

procedure WritePortB( wPort : Word; bValue : Byte );

{* 写串口}

function ReadPortB( wPort : Word ) : Byte;

{*读串口}

function CPUSpeed: Double;

{* 获知当前机器CPU的速率（MHz）}

type

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

function GetCPUID : TCPUID; assembler; register;

{*获取CPU的标识ID号*}

function GetMemoryTotalPhys : Dword;

{*获取计算机的物理内存}

type

TDriveState = (DSNODISK, DSUNFORMATTEDDISK, DSEMPTYDISK, DSDISK_WITHFILES);

function DriveState (driveletter: Char) : TDriveState;

{* 检查驱动器A中磁盘是否有效}

//▎============================================================▎//

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

//▎============================================================▎//

function GetComputerName:string;

{* 获取网络计算机名称}

function GetHostIP:string;

{* 获取计算机的IP地址}

function NetUserChangePassword(Domain:PWideChar; UserName:PWideChar; OldPassword:PWideChar; NewPassword:PWideChar): LongInt; stdcall; external 'netapi32.dll' name 'NetUserChangePassword';

{* // 运行平台：Windows NT/2000/XP

{* // Windows 95/98/Me平台：可以用该函数修改用户的Windows登录密码}

//▎============================================================▎//

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

//▎============================================================▎//

function GetHzPy(const AHzStr: string): string; {测试通过}

{* 取汉字的拼音}

function HowManyChineseChar(Const s:String):Integer;

{* 判断一个字符串中有多少各汉字}

//▎============================================================▎//

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

//▎============================================================▎//

{function PackDbDbf(Var StatusMsg: String): Boolean;}

{* 物理删除数据库(Db，Dbf)中的数据[着了删除标记的记录]}

procedure RepairDb(DbName: string);

{* 修复Access表}

function CreateODBCCfgInRegistry(ODBCSourceName:WideString;ServerName, DataBaseDescription:String):boolean;

{* 通过注册表创建ODBC配置[创建在系统DSN页下]}

function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;

{* 用Ado连接SysBase数据库函数}

function ADOConnectLocalDB(Const Adocon:TadoConnection;Const Dbname,DbServerName:string;ValidateMode:Integer):boolean;

{* 用Ado连接数据库函数}

function ADOODBCConnectLocalDB(Const Adocon:TadoConnection;Const Dbname:string;ValidateMode:Integer):boolean;

{* 用Ado与ODBC共同连接数据库函数}

function CreatTable(LpDataBaseName,LpTableName,LpSentence:string):Boolean;

{* //建立新表}

function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;

{*//在表中添加字段}

function KillField(LpFieldName:string):String;

{* //在表中删除字段}

function AlterTableExec(LpDataBaseName,LpSentence:string):Boolean;

{* //修改表结构}

function GetSQLSentence(LpTableName,LpSQLsentence:string): string;

{* /修改、添加、删除表结构时的SQL句体}

//▎============================================================▎//

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

//▎============================================================▎//

function StrToHex(AStr: string): string;

{* 字符转化成十六进制}

function HexToStr(AStr: string): string;

{* 十六进制转化成字符}

function TransChar(AChar: Char): Integer;

//▎============================================================▎//

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

//▎============================================================▎//

function TrimInt(Value, Min, Max: Integer): Integer; overload; {测试通过}

{* 输出限制在Min..Max之间}

function IntToByte(Value: Integer): Byte; overload; {测试通过}

{* 输出限制在0..255之间}

function InBound(Value: Integer; Min, Max: Integer): Boolean; {测试通过}

{* 判断整数Value是否在Min和Max之间}

procedure CnSwap(var A, B: Byte); overload;

{* 交换两个数}

procedure CnSwap(var A, B: Integer); overload;

{* 交换两个数}

procedure CnSwap(var A, B: Single); overload;

{* 交换两个数}

procedure CnSwap(var A, B: Double); overload;

{* 交换两个数}

function RectEqu(Rect1, Rect2: TRect): Boolean;

{* 比较两个Rect是否相等}

procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);

{* 分解一个TRect为左上角坐标x, y和宽度Width、高度Height}

function EnSize(cx, cy: Integer): TSize;

{* 返回一个TSize类型}

function RectWidth(Rect: TRect): Integer;

{* 计算TRect的宽度}

function RectHeight(Rect: TRect): Integer;

{* 计算TRect的高度}

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

{* 延时}

procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1); {Win9X下测试通过}

{* 只能在Win9X下让喇叭发声}

procedure ShowLastError; {测试通过}

{* 显示Win32 Api运行结果信息}

function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string;

{* 将字体Font.Style写入INI文件}

function readFontStyle(inifile: string): TFontStyles;

{* 从INI文件中读取字体Font.Style文件}

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

function ReadCursorPos(SourceMemo: TMemo): string;

{* 取得TMemo 控件当前光标的行和列信息到Tpoint中}

function CanUndo(AMemo: TMemo): Boolean;

{* 检查Tmemo控件能否Undo}

procedure Undo(Amemo: Tmemo);

{*实现Undo功能}

procedure AutoListDisplay(ACombox:TComboBox);

{* 实现ComBoBox自动下拉}

function UpperMoney(small:real):string;

{* 小写金额转换为大写 }

function Myrandom(Num: Integer): integer;

{*利用系统时间产生随机数)}

procedure OpenIME(ImeName: string);

{*打开输入法}

procedure CloseIME;

{*关闭输入法}

procedure ToChinese(hWindows: THandle; bChinese: boolean);

{*打开中文输入法}

//数据备份

procedure BackUpData(LpBackDispMessTitle:String);

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

//▎============================================================▎//

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

//▎============================================================▎//

// 判断s1是否包含在s2中

function InStr(const sShort: string; const sLong: string): Boolean;

var

s1, s2: string;

begin

s1 := LowerCase(sShort);

s2 := LowerCase(sLong);

Result := Pos(s1, s2) > 0;

end;

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

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

begin

Result := IntToStr(Value);

while Length(Result) < Len do

Result := FillChar + Result;

end;

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

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

var

s: string;

i, j: Integer;

begin

s := IntToStr(Value);

Result := '';

j := 0;

for i := Length(s) downto 1 do

begin

Result := s[i] + Result;

Inc(j);

try

if ((j mod SpLen) = 0) and (i <> 1) then

Result := Sp + Result;

except

MessageBox(Application.Handle,' IntToStrSp函数的第二个参数值不能为数字0 ！',SCnError,16);

exit;

end

end;

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

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

begin

if Len >= Length(Str) then

Result := Str

else

Result := Copy(Str, Length(Str) - Len + 1, Len);

end;

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

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

begin

if Len >= Length(Str) then

Result := Str

else

Result := Copy(Str, 1, Len);

end;

// 字节转二进制串

function ByteToBin(Value: Byte): string;

const

V: Byte = 1;

var

i: Integer;

begin

for i := 7 downto 0 do

if (V shl i) and Value <> 0 then

Result := Result + '1'

else

Result := Result + '0';

end;

// 返回空格串

function Spc(Len: Integer): string;

var

i: Integer;

begin

Result := '';

for i := 0 to Len - 1 do

Result := Result + ' ';

end;

// 返回将指定字符s1用字符串s2替换后的字符串，可支持大小写敏感由CaseSensitive操作}

function Replace(Str,s1,s2:string;CaseSensitive:Boolean):string;

var

i:integer;

s,t:string;

begin

s:='';

t:=str;

repeat

if casesensitive then

i:=pos(s1,t)

else

i:=pos(lowercase(s1),lowercase(t));

if i>0 then

begin

s:=s+Copy(t,1,i-1)+s2;

t:=Copy(t,i+Length(s1),MaxInt);

end

else

s:=s+t;

until i<=0;

result:=s;

end;

function Replicate(pcChar:Char; piCount:integer):string;

begin

Result:='';

SetLength(Result,piCount);

fillChar(Pointer(Result)^,piCount,pcChar)

end;

// 返回某个字符串中某个字符串中出现的次数}

function StrNum(ShortStr:string;LongString:string):Integer; {测试通过}

var

i:Integer;

begin

i:=0;

while pos(ShortStr,LongString)>0 do

begin

i:=i+1;

LongString:=Substr(LongString,(FindStr(ShortStr,LongString))+1,Length(LongString)-FindStr(ShortStr,LongString))

end;

Result:=i;

end;

// 返回某个字符串中查找某个字符串的位置}

function FindStr(ShortStr:String;LongStrIng:String):Integer;//在一个字符串中找某个字符的位置

var

locality:integer;

begin

locality:=Pos(ShortStr,LongStrIng);

if locality=0 then

Result:=0

else

Result:=locality;

end;

// 返回从位置BeginPlace开始切取长度为CatLeng字符串}

function SubStr(psInput:String; BeginPlace,CutLeng:Integer):String;

begin

Result:=Copy(psInput,BeginPlace,CutLeng)

end;

// 返回从左边第一为开始切取 CutLeng长度的字符串

function LeftStr(psInput:String; CutLeng:Integer):String;

begin

Result:=Copy(psInput,1,CutLeng)

end;

// 返回从左边第一为开始切取 CutLeng长度的字符串

function RightStr(psInput:String; CutLeng:Integer):String;

begin

Result:=Copy(psInput,Length(psInput)-CutLeng+1,CutLeng)

end;

{* 返回从psInput字符串左边开始用pcPadWith填充后总长度为PiWidth的字符串}

function PadLStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;

begin

Result:=Replicate(pcPadWith,piWidth-Length(psInput))+psInput

end;

{* 返回从psInput字符串右边开始用pcPadWith填充后总长度为PiWidth的字符串}

function PadRStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;

begin

Result:=psInput+Replicate(pcPadWith,piWidth-Length(psInput))

end;

{* 返回从psInput字符串两边开始用pcPadWith填充后总长度为PiWidth的字符串}

function PadCStr(psInput:String; piWidth:Integer; pcPadWith:Char):String;

var

liHalf :integer;

begin

liHalf:=(piWidth-Length(psInput))div 2;

Result:=Replicate(pcPadWith,liHalf)+psInput+Replicate(pcPadWith,piWidth-Length(psInput)-liHalf)

end;

{* 返回替换后字符串 Examples: ChrTran('abCdEgdlkh','d','#')；返回'bC#Eg#lkh'}

function ChrTran(psInput:String; pcSearch:Char; pcTranWith:Char):String;

var

i,j:integer;

begin

j:=Length(psInput);

for i:=1 to j do

begin

if psInput[i]=pcSearch then

psInput[i]:=pcTranWith

end;

Result:=psInput

end;

{* 返回替换后字符串 Examples: StrTran('aruyfbn','ruy','====='); 返回'a=====fbn'}

function StrTran(psInput:String; psSearch:String; psTranWith:String):String;

var

liPosition,liLenOfSrch,liLenOfIn:integer;

begin

liPosition:=Pos(psSearch,psInput);

liLenOfSrch:=Length(psSearch);

liLenOfIn:=Length(psInput);

while liPosition>0 do

begin

psInput:=Copy(psInput,1,liPosition-1)

+psTranWith

+Copy(psInput,liPosition+liLenOfSrch,liLenOfIn);

liPosition:=Pos(psSearch,psInput)

end;

Result:=psInput

end;

{ *返回替换后字符串[替换字符串] Examples: Stuff('ABCDEFGHI',3,4,'12345')；返回'AB12345GHI'}

function Stuff(psInput:String; piBeginPlace,piCount:Integer; psStuffWith:String):String;

begin

Result:=Copy(psInput,1,piBeginPlace-1)+

psStuffWith+

Copy(psInput,piBeginPlace+piCount,Length(psInput))

end;

// 交换字串

procedure SwapStr(var s1, s2: string);

var

tempstr: string;

begin

tempstr := s1;

s1 := s2;

s2 := tempstr;

end;

const

csLinesCR = #13#10;

csStrCR = '/n';

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

function LinesToStr(const Lines: string): string;

var

i: Integer;

begin

Result := Lines;

i := Pos(csLinesCR, Result);

while i > 0 do

begin

system.Delete(Result, i, Length(csLinesCR));

system.insert(csStrCR, Result, i);

i := Pos(csLinesCR, Result);

end;

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

function StrToLines(const Str: string): string;

var

i: Integer;

begin

Result := Str;

i := Pos(csStrCR, Result);

while i > 0 do

begin

system.Delete(Result, i, Length(csStrCR));

system.insert(csLinesCR, Result, i);

i := Pos(csStrCR, Result);

end;

//字符串加密函数

function Encrypt(const S: String; Key: Word): String;

var

I : Integer;

begin

Result := S;

for I := 1 to Length(S) do

begin

Result[I] := char(byte(S[I]) xor (Key shr 8));

Key := (byte(Result[I]) + Key) * C1 + C2;

if Result[I] = Chr(0) then

Result[I] := S[I];

end;

Result := StrToHex(Result);

end;

//字符串解密函数

function Decrypt(const S: String; Key: Word): String;

var

I: Integer;

S1: string;

begin

S1 := HexToStr(S);

Result := S1;

for I := 1 to Length(S1) do

begin

if char(byte(S1[I]) xor (Key shr 8)) = Chr(0) then

begin

Result[I] := S1[I];

Key := (byte(Chr(0)) + Key) * C1 + C2; //保证Key的正确性　　

end

else

begin

Result[I] := char(byte(S1[I]) xor (Key shr 8));

Key := (byte(S1[I]) + Key) * C1 + C2;

end;

///VarIIF,VarTostr为变体函数

function varIIF(aTest: Boolean; TrueValue, FalseValue: Variant): Variant;

begin

if aTest then Result := TrueValue else Result := FalseValue;

end;

function varToStr(const V: Variant): string;

begin

case TVarData(v).vType of

varSmallInt: Result := IntToStr(TVarData(v).VSmallInt);

varInteger: Result := IntToStr(TVarData(v).VInteger);

varSingle: Result := FloatToStr(TVarData(v).VSingle);

varDouble: Result := FloatToStr(TVarData(v).VDouble);

varCurrency: Result := FloatToStr(TVarData(v).VCurrency);

varDate: Result := DateToStr(TVarData(v).VDate);

varBoolean: Result := varIIf(TVarData(v).VBoolean, 'True', 'False');

varByte: Result := IntToStr(TVarData(v).VByte);

varString: Result := StrPas(TVarData(v).VString);

varEmpty,

varNull,

varVariant,

varUnknown,

varTypeMask,

varArray,

varByRef,

varDispatch,

varError: Result := '';

end;

{功能说明：判断string是否全是数字}

function IsDigital(Value: string): boolean;

var

i, j: integer;

str: char;

begin

result := true;

Value := trim(Value);

j := Length(Value);

if j = 0 then

begin

result := false;

exit;

end;

for i := 1 to j do

begin

str := Value[i];

if not (str in ['0'..'9']) then

begin

result := false;

exit;

end;

{随机字符串函数}

function RandomStr(aLength : Longint) : String;

var

X : Longint;

begin

if aLength <= 0 then exit;

SetLength(Result, aLength);

for X:=1 to aLength do

Result[X] := Chr(Random(26) + 65);

end;

//▎============================================================▎//

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

//▎============================================================▎//

function GetYear(Date: TDate): Integer;

var

y, m, d: WORD;

begin

DecodeDate(Date, y, m, d);

Result := y;

end;

function GetMonth(Date: TDate): Integer;

var

y, m, d: WORD;

begin

DecodeDate(Date, y, m, d);

Result := m;

end;

function GetDay(Date: TDate): Integer;

var

y, m, d: WORD;

begin

DecodeDate(Date, y, m, d);

Result := d;

end;

function GetHour(Time: TTime): Integer;

var

h, m, s, ms: WORD;

begin

DecodeTime(Time, h, m, s, ms);

Result := h;

end;

function GetMinute(Time: TTime): Integer;

var

h, m, s, ms: WORD;

begin

DecodeTime(Time, h, m, s, ms);

Result := m;

end;

function GetSecond(Time: TTime): Integer;

var

h, m, s, ms: WORD;

begin

DecodeTime(Time, h, m, s, ms);

Result := s;

end;

function GetMSecond(Time: TTime): Integer;

var

h, m, s, ms: WORD;

begin

DecodeTime(Time, h, m, s, ms);

Result := ms;

end;

//传入年、月，得到该月份最后一天

function GetMonthLastDay(Cs_Year,Cs_Month:string):string;

Var

V_date:Tdate;

V_year,V_month,V_day:word;

begin

V_year:=strtoint(Cs_year);

V_month:=strtoint(Cs_month);

if V_month=12 then

begin

V_month:=1;

inc(V_year);

end

else

inc(V_month);

V_date:=EncodeDate(V_year,V_month,1);

V_date:=V_date-1;

DecodeDate(V_date,V_year,V_month,V_day);

Result:=DateToStr(EncodeDate(V_year,V_month,V_day));

end;

//判断某年是否为闰年

function IsLeapYear( nYear: Integer ): Boolean;

begin

Result := (nYear mod 4 = 0) and ((nYear mod 100 <> 0) or (nYear mod 400 = 0));

end;

//两个日期取较大的日期

function MaxDateTime(const Values: array of TDateTime): TDateTime;

var

I: Cardinal;

begin

Result := Values[0];

for I := 0 to Low(Values) do

if Values[I] < Result then Result := Values[I];

end;

//两个日期取较小的日期

function MinDateTime(const Values: array of TDateTime): TDateTime;

var

I: Cardinal;

begin

Result := Values[0];

for I := 0 to High(Values) do

if Values[I] < Result then Result := Values[I];

end;

//得到本月的第一一天

function dateBeginOfMonth(D: TDateTime): TDateTime;

var

Year, Month, Day: Word;

begin

DecodeDate(D, Year, Month, Day);

Result := EncodeDate(Year, Month, 1);

end;

//得到本月的最后一天

function dateEndOfMonth(D: TDateTime): TDateTime;

var

Year, Month, Day: Word;

begin

DecodeDate(D, Year, Month, Day);

if Month = 12 then

begin

Inc(Year);

Month := 1;

end else

Inc(Month);

Result := EncodeDate(Year, Month, 1) - 1;

end;

//得到本年的最后一天

function dateEndOfYear(D: TDateTime): TDateTime;

var

Year, Month, Day: Word;

begin

DecodeDate(D, Year, Month, Day);

Result := EncodeDate(Year, 12, 31);

end;

//得到两个日期相隔的天数

function DaysBetween(Date1, Date2: TDateTime): integer;

begin

Result := Trunc(Date2) - Trunc(Date1) + 1;

if Result < 0 then Result := 0;

end;

//▎============================================================▎//

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

//▎============================================================▎//

// 设置位

procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean);

begin

if IsSet then

Value := Value or (1 shl Bit)

else

Value := Value and not (1 shl Bit);

end;

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

begin

if IsSet then

Value := Value or (1 shl Bit)

else

Value := Value and not (1 shl Bit);

end;

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

begin

if IsSet then

Value := Value or (1 shl Bit)

else

Value := Value and not (1 shl Bit);

end;

// 取位

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

begin

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

end;

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

begin

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

end;

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

begin

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

end;

//▎============================================================▎//

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

//▎============================================================▎//

// 移动文件、目录

function MoveFile(const sName, dName: string): Boolean;

var

s1, s2: AnsiString;

lpFileOp: TSHFileOpStruct;

begin

s1 := PChar(sName) + #0#0;

s2 := PChar(dName) + #0#0;

with lpFileOp do

begin

Wnd := Application.Handle;

wFunc := FO_MOVE;

pFrom := PChar(s1);

pTo := PChar(s2);

fFlags := FOF_ALLOWUNDO;

hNameMappings := nil;

lpszProgressTitle := nil;

fAnyOperationsAborted := True;

end;

Result := SHFileOperation(lpFileOp) = 0;

end;

// 打开文件属性窗口

procedure FileProperties(const FName: string);

var

SEI: SHELLEXECUTEINFO;

begin

with SEI do

begin

cbSize := SizeOf(SEI);

fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or

SEE_MASK_FLAG_NO_UI;

Wnd := Application.Handle;

lpVerb := 'properties';

lpFile := PChar(FName);

lpParameters := nil;

lpDirectory := nil;

nShow := 0;

hInstApp := 0;

lpIDList := nil;

end;

ShellExecuteEx(@SEI);

end;

// 缩短显示不下的长路径名

function FormatPath(APath: string; Width: Integer): string;

var

SLen: Integer;

i, j: Integer;

TString: string;

begin

SLen := Length(APath);

if (SLen <= Width) or (Width <= 6) then

begin

Result := APath;

Exit

end

else

begin

i := SLen;

TString := APath;

for j := 1 to 2 do

begin

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

i := i - 1;

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;

// 打开文件框

function OpenDialog(var FileName: string; Title: string; Filter: string;

Ext: string): Boolean;

var

OpenName: TOPENFILENAME;

TempFilename, ReturnFile: string;

begin

with OpenName do

begin

lStructSize := SizeOf(OpenName);

hWndOwner := GetModuleHandle('');

Hinstance := SysInit.Hinstance;

lpstrFilter := PChar(Filter + #0 + Ext + #0#0);

lpstrCustomFilter := '';

nMaxCustFilter := 0;

nFilterIndex := 1;

nMaxFile := MAX_PATH;

SetLength(TempFilename, nMaxFile + 2);

lpstrFile := PChar(TempFilename);

FillChar(lpstrFile^, MAX_PATH, 0);

SetLength(TempFilename, nMaxFile + 2);

nMaxFileTitle := MAX_PATH;

SetLength(ReturnFile, MAX_PATH + 2);

lpstrFileTitle := PChar(ReturnFile);

FillChar(lpstrFile^, MAX_PATH, 0);

lpstrInitialDir := '.';

lpstrTitle := PChar(Title);

Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;

nFileOffset := 0;

nFileExtension := 0;

lpstrDefExt := PChar(Ext);

lCustData := 0;

lpfnHook := nil;

lpTemplateName := '';

end;

Result := GetOpenFileName(OpenName);

if Result then

FileName := ReturnFile

else

FileName := '';

end;

// 取两个目录的相对路径,注意串尾不能是'/'字符!

function GetRelativePath(Source, Dest: string): string;

// 比较两路径字符串头部相同串的函数

function GetPathComp(s1, s2: string): Integer;

begin

if Length(s1) > Length(s2) then swapStr(s1, s2);

Result := Pos(s1, s2);

while (Result = 0) and (Length(s1) > 3) do

begin

if s1 = '' then Exit;

s1 := ExtractFileDir(s1);

Result := Pos(s1, s2);

end;

if Result <> 0 then Result := Length(s1);

if Result = 3 then Result := 2;

// 修正因ExtractFileDir()处理'c:/'时产生的错误.

end;

// 取Dest的相对根路径的函数

function GetRoot(s: ShortString): string;

var

i: Integer;

begin

Result := '';

for i := 1 to Length(s) do

if s[i] = '/' then Result := Result + '../';

if Result = '' then Result := './';

// 如果不想处理成"./"的路径格式，可去掉本行

end;

var

RelativRoot, RelativSub: string;

HeadNum: Integer;

begin

Source := UpperCase(Source);

Dest := UpperCase(Dest); // 比较两路径字符串头部相同串

HeadNum := GetPathComp(Source, Dest); // 取Dest的相对根路径

RelativRoot := GetRoot(StrRight(Dest, Length(Dest) - HeadNum));

// 取Source的相对子路径

RelativSub := StrRight(Source, Length(Source) - HeadNum - 1);

// 返回

Result := RelativRoot + RelativSub;

end;

// 运行一个文件

procedure RunFile(const FName: string; Handle: THandle;

const Param: string);

begin

ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);

end;

// 运行一个文件并等待其结束

function WinExecAndWait32(FileName: string; Visibility: Integer): Integer;

var

zAppName: array[0..512] of Char;

zCurDir: array[0..255] of Char;

WorkDir: string;

StartupInfo: TStartupInfo;

ProcessInfo: TProcessInformation;

begin

StrPCopy(zAppName, FileName);

GetDir(0, WorkDir);

StrPCopy(zCurDir, WorkDir);

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

StartupInfo.cb := SizeOf(StartupInfo);

StartupInfo.dwFlags := STARTF_USESHOWWINDOW;

StartupInfo.wShowWindow := Visibility;

if not CreateProcess(nil,

zAppName, { pointer to command line string }

nil, { pointer to process security attributes }

nil, { pointer to thread security attributes }

False, { handle inheritance flag }

CREATE_NEW_CONSOLE or { creation flags }

NORMAL_PRIORITY_CLASS,

nil, { pointer to new environment block }

nil, { pointer to current directory name }

StartupInfo, { pointer to STARTUPINFO }

ProcessInfo) then

Result := -1 { pointer to PROCESS_INF }

else

begin

WaitforSingleObject(ProcessInfo.hProcess, INFINITE);

GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));

end;

// 应用程序路径

function AppPath: string;

begin

Result := ExtractFilePath(Application.ExeName);

end;

// 取Windows系统目录

function GetWindowsDir: string;

var

Buf: array[0..MAX_PATH] of Char;

begin

GetWindowsDirectory(Buf, MAX_PATH);

Result := AddDirSuffix(Buf);

end;

// 取临时文件目录

function GetWinTempDir: string;

var

Buf: array[0..MAX_PATH] of Char;

begin

GetTempPath(MAX_PATH, Buf);

Result := AddDirSuffix(Buf);

end;

// 目录尾加'/'修正

function AddDirSuffix(Dir: string): string;

begin

Result := Trim(Dir);

if Result = '' then Exit;

if Result[Length(Result)] <> '/' then Result := Result + '/';

end;

function MakePath(Dir: string): string;

begin

Result := AddDirSuffix(Dir);

end;

// 判断文件是否正在使用

function IsFileInUse(FName: string): Boolean;

var

HFileRes: HFILE;

begin

Result := False;

if not FileExists(FName) then

Exit;

HFileRes := CreateFile(PChar(FName), GENERIC_READ or GENERIC_WRITE, 0,

nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);

Result := (HFileRes = INVALID_HANDLE_VALUE);

if not Result then

CloseHandle(HFileRes);

end;

// 取文件长度

function GetFileSize(FileName: string): Integer;

var

FileVar: file of Byte;

begin

{$I-}

try

AssignFile(FileVar, FileName);

Reset(FileVar);

Result := FileSize(FileVar);

CloseFile(FileVar);

except

Result := 0;

end;

{$I+}

end;

// 设置文件时间

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

TFileTime): Boolean;

var

FileHandle: Integer;

begin

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

if FileHandle > 0 then

begin

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

FileClose(FileHandle);

Result := True;

end

else

Result := False;

end;

// 取文件时间

function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:

TFileTime): Boolean;

var

FileHandle: Integer;

begin

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

if FileHandle > 0 then

begin

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

FileClose(FileHandle);

Result := True;

end

else

Result := False;

end;

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

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

// 成功则返回True

function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;

var

SHFileInfo: TSHFileInfo;

h: HWND;

begin

if not Assigned(Icon) then

Icon := TIcon.Create;

h := SHGetFileInfo(PChar(FileName),

SHFileInfo,

SizeOf(SHFileInfo),

SHGFI_ICON or SHGFI_SYSICONINDEX);

Icon.Handle := SHFileInfo.hIcon;

Result := (h <> 0);

end;

// 文件时间转本地时间

function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;

var

STime: TSystemTime;

begin

FileTimeToLocalFileTime(FTime, FTime);

FileTimeToSystemTime(FTime, STime);

Result := STime;

end;

// 本地时间转文件时间

function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;

var

FTime: TFileTime;

begin

SystemTimeToFileTime(STime, FTime);

LocalFileTimeToFileTime(FTime, FTime);

Result := FTime;

end;

// 创建备份文件

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

var

BakFileName: string;

begin

BakFileName := FileName + '.' + Ext;

Result := CopyFile(PChar(FileName), PChar(BakFileName), False);

end;

// 删除整个目录

function Deltree(Dir: string): Boolean;

var

sr: TSearchRec;

fr: Integer;

begin

if not DirectoryExists(Dir) then

begin

Result := True;

Exit;

end;

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

try

while fr = 0 do

begin

if (sr.Name <> '.') and (sr.Name <> '..') then

begin

if sr.Attr and faDirectory = faDirectory then

Result := Deltree(AddDirSuffix(Dir) + sr.Name)

else

Result := DeleteFile(AddDirSuffix(Dir) + sr.Name);

if not Result then

Exit;

end;

fr := FindNext(sr);

end;

finally

FindClose(sr);

end;

Result := RemoveDir(Dir);

end;

// 取文件夹文件数

function GetDirFiles(Dir: string): Integer;

var

sr: TSearchRec;

fr: Integer;

begin

Result := 0;

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

while fr = 0 do

begin

if (sr.Name <> '.') and (sr.Name <> '..') then

Inc(Result);

fr := FindNext(sr);

end;

FindClose(sr);

end;

var

FindAbort: Boolean;

// 查找指定目录下文件

procedure FindFile(const Path: string; const FileName: string = '*.*';

Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);

var

APath: string;

Info: TSearchRec;

Succ: Integer;

begin

FindAbort := False;

APath := MakePath(Path);

try

Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info);

while Succ = 0 do

begin

if (Info.Name <> '.') and (Info.Name <> '..') then

begin

if (Info.Attr and faDirectory) <> faDirectory then

begin

if Assigned(Proc) then

Proc(APath + Info.FindData.cFileName, Info, FindAbort);

end

else if bSub then

FindFile(APath + Info.Name, FileName, Proc, bSub, bMsg);

end;

if bMsg then Application.ProcessMessages;

if FindAbort then Exit;

Succ := FindNext(Info);

end;

finally

FindClose(Info);

end;

{ 功能说明：查找一个路径下的所有文件。

参数：path:路径, filter:文件扩展名过滤, FileList:文件列表, ContainSubDir:是否包含子目录}

procedure FindFileList(Path,Filter:string;FileList:TStrings;ContainSubDir:Boolean);

var

FSearchRec,DSearchRec:TSearchRec;

FindResult:shortint;

begin

FindResult:=FindFirst(path+Filter,sysutils.faAnyFile,FSearchRec);

try

while FindResult=0 do

begin

FileList.Add(FSearchRec.Name);

FindResult:=FindNext(FSearchRec);

end;

if ContainSubDir then

begin

FindResult:=FindFirst(path+Filter,faDirectory,DSearchRec);

while FindResult=0 do

begin

if ((DSearchRec.Attr and faDirectory)=faDirectory)

and (DSearchRec.Name<>'.') and (DSearchRec.Name<>'..') then

FindFileList(Path,Filter,FileList,ContainSubDir);

FindResult:=FindNext(DSearchRec);

end;

finally

FindClose(FSearchRec);

end;

//返回一文本文件的行数

function Txtline(const txt: string): integer;

var

F : TextFile; {设定为文本文件}

StrLine : string; {每行字符串}

line : Integer; {行数}

begin

AssignFile(F, txt); {建立文件}

Reset(F);

Line := 0;

while not SeekEof(f) do {文件没到尾}

begin

if SeekEoln(f) then {判断是否到行尾}

Readln;

Readln(F, StrLine);

if SeekEof(f) then

break

else

inc(Line);

end;

CloseFile(F); {关闭文件}

Result := Line;

end;

//Html文件转化成文本文件

function Html2Txt(htmlfilename: string): string;

var Mystring:TStrings;

s,lineS:string;

line,Llen,i,j:integer;

rloop:boolean;

begin

rloop:=False;

Mystring:=TStringlist.Create;

s:='';

Mystring.LoadFromFile(htmlfilename);

line:=Mystring.Count;

try

for i:=0 to line-1 do

Begin

lineS:=Mystring[i];

Llen:=length(lineS);

j:=1;

while (j<=Llen)and(lineS[j]=' ')do

begin

j:=j+1;

s:=s+' ';

End;

while j<=Llen do

Begin

if lineS[j]='<'then

rloop:=True;

if lineS[j]='>'then

Begin

rloop:=False;

j:=j+1;

continue;

End;

if rloop then

begin

j:=j+1;

continue;

end

else

s:=s+lineS[j];

j:=j+1;

End;

s:=s+#13#10;

End;

finally

Mystring.Free;

end;{try}

result:=s;

end;

// 文件打开方式

function OpenWith(const FileName: string): Integer;

begin

Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe',

PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);

end;

//▎============================================================▎//

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

//▎============================================================▎//

// 显示提示窗口

procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);

begin

Application.MessageBox(PChar(Mess), PChar(Caption), Flags);

end;

// 显示提示确认窗口

function InfoOk(Mess: string; Caption: string): Boolean;

begin

Result := Application.MessageBox(PChar(Mess), PChar(Caption),

MB_OK + MB_ICONINFORMATION) = IDOK;

end;

// 显示错误窗口

procedure ErrorDlg(Mess: string; Caption: string);

begin

Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);

end;

// 显示警告窗口

procedure WarningDlg(Mess: string; Caption: string);

begin

Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);

end;

// 显示查询是否窗口

function QueryDlg(Mess: string; Caption: string): Boolean;

begin

Result := Application.MessageBox(PChar(Mess), PChar(Caption),

MB_YESNO + MB_ICONQUESTION) = IDYES;

end;

//窗体渐变

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

var

pOSVersionInfo : OSVersionInfo;

begin

pOSVersionInfo.dwOSVersionInfoSize := sizeof(OSVersionInfo);

GetVersionEx(pOSVersionInfo);

if pOSVersionInfo.dwPlatformId = VER_PLATFORM_WIN32_NT then

begin

if IsSetAni then

AnimateWindow(Sender.Handle,444,AW_HIDE or AW_BLEND);

end

else

if IsSetAni then

begin

AnimateWindow(Sender.Handle,444,AW_HIDE or AW_CENTER);

end;

//▎============================================================▎//

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

//▎============================================================▎//

// 移动鼠标到控件

procedure MoveMouseIntoControl(AWinControl: TControl);

var

rtControl: TRect;

begin

rtControl := AWinControl.BoundsRect;

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

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

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

end;

// 动态设置分辨率

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

var

lpDevMode: TDeviceMode;

begin

Result := EnumDisplaySettings(nil, 0, lpDevMode);

if Result then

begin

lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;

lpDevMode.dmPelsWidth := x;

lpDevMode.dmPelsHeight := y;

Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;

end;

// 窗口最上方显示

procedure StayOnTop(Handle: HWND; OnTop: Boolean);

const

csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);

begin

SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);

end;

var

WndLong: Integer;

// 设置程序是否出现在任务栏

procedure SetHidden(Hide: Boolean);

begin

ShowWindow(Application.Handle, SW_HIDE);

if Hide then

SetWindowLong(Application.Handle, GWL_EXSTYLE,

WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)

else

SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);

ShowWindow(Application.Handle, SW_SHOW);

end;

const

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

// 设置任务栏是否可见

procedure SetTaskBarVisible(Visible: Boolean);

var

wndHandle: THandle;

begin

wndHandle := FindWindow('Shell_TrayWnd', nil);

ShowWindow(wndHandle, csWndShowFlag[Visible]);

end;

// 设置桌面是否可见

procedure SetDesktopVisible(Visible: Boolean);

var

hDesktop: THandle;

begin

hDesktop := FindWindow('Progman', nil);

ShowWindow(hDesktop, csWndShowFlag[Visible]);

end;

// 显示等待光标

procedure BeginWait;

begin

Screen.Cursor := crHourGlass;

end;

// 结束等待光标

procedure EndWait;

begin

Screen.Cursor := crDefault;

end;

// 检测是否Win95/98平台

function CheckWindows9598NT: String;

var

V: TOSVersionInfo;

begin

V.dwOSVersionInfoSize := SizeOf(V);

Result := '未知操作系统';

if not GetVersionEx(V) then Exit;

if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then

Result := 'Windows 95/98'

else

begin

if V.dwPlatformId = VER_PLATFORM_WIN32_NT then

Result := 'Windows NT'

else

Result :='Windows'

end;

{* 取得当前操作平台是 Windows 95/98 还是NT}

function GetOSInfo : String;

begin

Result := '';

case Win32Platform of

VER_PLATFORM_WIN32_WINDOWS: Result := 'Windows 95/98';

VER_PLATFORM_WIN32_NT: Result := 'Windows NT';

else

Result := 'Windows32';

end;

//*获取当前Windows登录名的用户

function GetCurrentUserName : string;

const

cnMaxUserNameLen = 254;

var

sUserName : string;

dwUserNameLen : Dword;

begin

dwUserNameLen := cnMaxUserNameLen-1;

SetLength( sUserName, cnMaxUserNameLen );

GetUserName(Pchar( sUserName ), dwUserNameLen );

SetLength( sUserName, dwUserNameLen );

Result := sUserName;

end;

function GetRegistryOrg_User(UserKeyType:string):string;

var

Myreg:Tregistry;

RegString:string;

begin

MyReg:=Tregistry.Create;

MyReg.RootKey:=HKEY_LOCAL_MACHINE;

if (Win32Platform = VER_PLATFORM_WIN32_NT) then

RegString:='Software/Microsoft/Windows NT/CurrentVersion'

else

RegString:='Software/Microsoft/Windows/CurrentVersion';

if MyReg.openkey(RegString,False) then

begin

if UpperCase(UserKeyType)='REGISTEREDORGANIZATION' then

Result:= MyReg.readstring('RegisteredOrganization')

else

begin

if UpperCase(UserKeyType)='REGISTEREDOWNER' then

Result:= MyReg.readstring('RegisteredOwner')

else

Result:='';

end;

MyReg.CloseKey;

MyReg.Free;

end;

//获取操作系统版本号

function GetSysVersion:string;

Var

OSVI:OSVERSIONINFO;

ObjSysVersion:string;

begin

OSVI.dwOSversioninfoSize:=Sizeof(OSVERSIONINFO);

GetVersionEx(OSVI);

ObjSysVersion:=IntToStr(OSVI.dwMinorVersion)+','+IntToStr(OSVI.dwMinorVersion)+','

+IntToStr(OSVI.dwBuildNumber)+','+IntToStr(OSVI.dwPlatformId)+','

+OSVI.szCSDVersion;

if rightstr(ObjSysVersion,1)=',' then

ObjSysVersion:=Substr(ObjSysVersion,1,length(ObjSysVersion)-1);

Result:=ObjSysVersion;

end;

//Windows启动模式

function WinBootMode:string;

begin

case(GetSystemMetrics(SM_CLEANBOOT)) of

0:Result:='正常模式启动';

1:Result:='安全模式启动';

2:Result:='安全模式启动，但附带网络功能';

else

Result:='错误：系统启动有问题。';

end;

Windows ShutDown等

procedure WinShutDown(ShutWinType:PShutType; PForce:Boolean);

var

hToken, hProcess: THandle;

tp, prev_tp: TTokenPrivileges;

Len, Flags: DWORD;

CanShutdown: Boolean;

begin

if Win32Platform = VER_PLATFORM_WIN32_NT then

begin

hProcess := OpenProcess(PROCESS_ALL_ACCESS, True, GetCurrentProcessID);

try

if not OpenProcessToken(hProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, hToken) then

Exit;

finally

CloseHandle(hProcess);

end;

try

if not LookupPrivilegeValue('', 'SeShutdownPrivilege',

tp.Privileges[0].Luid) then Exit;

tp.PrivilegeCount := 1;

tp.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED;

if not AdjustTokenPrivileges(hToken, False, tp, SizeOf(prev_tp),

prev_tp, Len) then Exit;

finally

CloseHandle(hToken);

end;

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;

//▎============================================================▎//

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

//▎============================================================▎//

function GetClientGUID:string;

var

myGuid:TGUID;

ResultStr:string;

begin

CreateGuid(myGuid);

ResultStr:=GUIDToString(myGuid);

ResultStr:=Communal.Replace(ResultStr,'-','',False);

ResultStr:=Communal.Replace(ResultStr,'{','',False);

ResultStr:=Communal.Replace(ResultStr,'}','',False);

Result:=Substr(ResultStr,1,30);

end;

// 声卡是否存在

function SoundCardExist: Boolean;

begin

Result := WaveOutGetNumDevs > 0;

end;

//* 获取磁盘序列号

function GetDiskSerial(DiskChar: Char): string;

var

SerialNum : pdword;

a, b : dword;

Buffer : array [0..255] of char;

begin

result := '';

if GetVolumeInformation(PChar(diskchar+':/'), Buffer, SizeOf(Buffer), SerialNum,a, b, nil, 0) then

Result := IntToStr(SerialNum^);

end;

//*检查磁盘准备是否就绪

function DiskReady(Root: string) : Boolean;

var

Oem : CARDINAL ;

Dw1,Dw2 : DWORD ;

begin

Oem := SetErrorMode( SEM_FAILCRITICALERRORS ) ;

if LENGTH(Root) = 1 then Root := Root + '://';

Result := GetVolumeInformation( PCHAR( Root ), NIL,0,NIL, Dw1,Dw2, NIL,0 ) ;

SetErrorMode( Oem ) ;

end;

//*检查驱动器A中磁盘的是否有文件及文件状态

function DriveState (driveletter: Char) : TDriveState;

var

mask: String[6];

sRec: TSearchRec;

oldMode: Cardinal;

retcode: Integer;

begin

oldMode := SetErrorMode(SEM_FAILCRITICALERRORS);

mask:= '?:/*.*';

mask[1] := driveletter;

{$I-}

retcode := FindFirst (mask, faAnyfile, Srec);

FindClose(Srec);

{$I+}

case retcode of

0 : Result := DSDISK_WITHFILES; //磁盘有文件

-18 : Result := DSEMPTYDISK; //好的空磁盘

-21, -3: Result := DSNODISK; //NT,Win31的错误代号

else

Result := DSUNFORMATTEDDISK;

end;

SetErrorMode(oldMode);

end;

//写串口

procedure WritePortB( wPort : Word; bValue : Byte );

begin

asm

mov dx, wPort

mov al, bValue

out dx, al

end;

//读串口

function ReadPortB( wPort : Word ):Byte;

begin

asm

mov dx, wPort

in al, dx

mov result, al

end;

//获知当前机器CPU的速率（MHz）

function CPUSpeed: Double;

const

DelayTime = 500;

var

TimerHi, TimerLo: DWORD;

PriorityClass, Priority: Integer;

begin

PriorityClass := GetPriorityClass(GetCurrentProcess);

Priority := GetThreadPriority(GetCurrentThread);

SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);

SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);

Sleep(10);

asm

dw 310Fh

mov TimerLo, eax

mov TimerHi, edx

end;

Sleep(DelayTime);

asm

dw 310Fh

sub eax, TimerLo

sbb edx, TimerHi

mov TimerLo, eax

mov TimerHi, edx

end;

SetThreadPriority(GetCurrentThread, Priority);

SetPriorityClass(GetCurrentProcess, PriorityClass);

Result := TimerLo / (1000.0 * DelayTime);

end;

//获取CPU的标识ID号

function GetCPUID : TCPUID; assembler; register;

asm

PUSH EBX {Save affected register}

PUSH EDI

MOV EDI,EAX {@Resukt}

MOV EAX,1

DW $A20F {CPUID Command}

STOSD {CPUID[1]}

MOV EAX,EBX

STOSD {CPUID[2]}

MOV EAX,ECX

STOSD {CPUID[3]}

MOV EAX,EDX

STOSD {CPUID[4]}

POP EDI {Restore registers}

POP EBX

end;

//获取计算机的物理内存

function GetMemoryTotalPhys : Dword;

var

memStatus: TMemoryStatus;

begin

memStatus.dwLength := sizeOf ( memStatus );

GlobalMemoryStatus ( memStatus );

Result := memStatus.dwTotalPhys div 1024;

end;

//▎============================================================▎//

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

//▎============================================================▎//

{* 获取网络计算机名称}

function GetComputerName:string;

var

wVersionRequested : WORD;

wsaData : TWSAData;

p : PHostEnt; s : array[0..128] of char;

begin

try

wVersionRequested := MAKEWORD(1, 1); //创建 WinSock

WSAStartup(wVersionRequested, wsaData); //创建 WinSock

GetHostName(@s,128);

p:=GetHostByName(@s);

Result:=p^.h_Name;

finally

WSACleanup; //释放 WinSock

end;

{* 获取计算机的IP地址}

function GetHostIP:string;

var

wVersionRequested : WORD;

wsaData : TWSAData;

p : PHostEnt; s : array[0..128] of char; p2 : pchar;

begin

try

wVersionRequested := MAKEWORD(1, 1); //创建 WinSock

WSAStartup(wVersionRequested, wsaData); //创建 WinSock

GetHostName(@s,128);

p:=GetHostByName(@s);

p2 := iNet_ntoa(PInAddr(p^.h_addr_list^)^);

Result:= P2;

finally

WSACleanup; //释放 WinSock

end;

//▎============================================================▎//

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

//▎============================================================▎//

// 取汉字的拼音

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;

Inc(i);

end else Result := Result + AHzStr[i];

Inc(i);

end;

{* 判断一个字符串中有多少各汉字}

function HowManyChineseChar(Const s:String):Integer;

var

SW:WideString;

C:String;

i, WCount:Integer;

begin

SW:=s;

WCount:=0;

For i:=1 to Length(SW) do

begin

c:=SW[i];

if Length(c)>1 then

Inc(WCount);

end;

Result:=WCount;

end;

//▎============================================================▎//

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

//▎============================================================▎//

//* 物理删除数据库(Db，Dbf)中的数据[着了删除标记的记录]}

{function PackDbDbf(Var StatusMsg: String): Boolean;

var

rslt:DBIResult;

szErrMsg:DBIMSG;

pTblDesc:pCRTblDesc;

bExclusive:Boolean;

bActive:Boolean;

isParadox,isDbase:Boolean;

tempTableName:string;

Props:CurProps;//保护口令

begin

Result:=False;

StatusMsg:='';

if TableType=ttDefault then

begin

tempTableName:=TableName;

tempTableName:=Lowercase(tempTableName);

isParadox:=(pos('.db',tempTableName)>0) and (tempTableName[length(tempTableName)]='b');

isDbase:=pos('.dbf',tempTableName)>0;

end

else

begin

isParadox:=TableType=ttParadox;

isDbase:=TableType=ttDbase;

end;

if isparadox or isDbase then

begin

bExclusive:=Exclusive;

bActive:=Active;

DisableControls;

// Close;

Exculsive:=true;

end

else

begin

StatusMsg:='无效的数据表类型。';

Exit;

end;

if isParadox then

begin

if wwMemAvail(Sizeof(CRTblDesc)) then

begin

StatusMsg:='内存不足，压缩表失败。';

end

else

begin

GetMem(pTblDesc,Sizeof(CRTblDesc));

fillchar(pTblDesc^,Sizeof(CRTblDesc),0);

with pTblDesc^ do

begin

strCopy(szTblName,Tablename);

strCopy(szTblType,szParadox);

Active:=True;

Check(DbiGetCursorProps(handle,Props));//检测是否右口令保护

bProtected:=props.bProtected;

Active:=False;

bPack:=True;

end;

Screen.Cursor:=crHourGlass;

SetDBFlag(dbfOpened,True);

rslt:=DBIdoRestructure(DBHandle,1,pTblDesc,nil,nil,nil,False);

if rslt<>DBIERR_NONE then

begin

DBiGetErrorString(rslt,SzErrMsg);

StatusMsg:=SzErrMsg;

end

else

Result:=True;

SetDBFlag(dbfOpened,False);

FreeMem(pTblDesc,Sizeof(CRTlDesc));

Screen.Cursor:=crDefault;

end;

end

else

if isDbase then

begin

Screen.Cursor:=crHourGlass;

OPen;

rslt:=dbiPacktable(DBHandle,Handle,nil,nil,True);

Screen.Cursor:=crDefault;

if rslt<>DBIERR_NONE then

begin

DBiGetERRorString(rslt,szErrMsg);

StatusMSg:=SzErrMsg;

end

else

Result:=True;

end;

Close;

Exculsive:=bExclusive;

Active:=bActive;

EnableControls;

end;}

{procedure CompactDb(DbName, NewDbName: string);

var

dao: OLEVariant;

begin

dao := CreateOleObject('DAO.DBEngine.35');

dao.CompactDatabase(DbName, NewDbName);

end;}

//修复Access表

procedure RepairDb(DbName: string);

var

Dao: OLEVariant;

begin

Dao := CreateOleObject('DAO.DBEngine.35');

Dao.RepairDatabase(DbName);

end;

//通过注册表创建ODBC配置[创建在系统DSN页下]

function CreateODBCCfgInRegistry(ODBCSourceName:WideString; ServerName, DataBaseDescription:String):boolean;

var

Reg: TRegistry;

LPT_systemDir:array [1..255] of char;

P:Pchar;

DriverString:String;

begin

Reg := TRegistry.Create;

Reg.RootKey := HKEY_LOCAL_MACHINE;

try

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;

Result:=True;

except

Result:=False;

end;

finally

Reg.Free;

end;

function ADOConnectSysBase(Const Adocon:TadoConnection):boolean;

{* 用Ado连接SysBase数据库函数}

begin

with Adocon do

begin

Close;

LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。

ConnectionString:='Provider=MSDASQL.1;'+

'Password="";'+

'Persist Security Info=True;'+

'Data Source=Sy_Finalact';

try

KeepConnection:=True;

Screen.Cursor:=crHourGlass;

Connected:=True;

Open;

Screen.Cursor:=crDefault;

ADOConnectSysBase:=True;

except

ADOConnectSysBase:=False;

end;

//Ado连接数据库函数

function ADOConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname,DBServerName:String;ValidateMode:Integer):boolean;

begin

with Adocon do

begin

Close;

LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。

if ValidateMode=0 then//使用Windows NT验证模式

ConnectionString:='Provider=SQLOLEDB.1;'+

'Password="";'+

'Integrated Security=SSPI;'+ //集成安全

'Persist Security Info=False;'+

'User ID=sa;Initial Catalog='+''''+dbname+''''+';'+

'Data Source='+''''+DBServerName+'''';

if ValidateMode=1 then//使用SQL SERVER验证模式

ConnectionString:='Provider=SQLOLEDB.1;'+

'Password="";'+

'Persist Security Info=True;'+

'User ID=sa;Initial Catalog='+''''+Dbname+''''+';'+

'Data Source='+''''+DBServerName+'''';

try

KeepConnection:=True;

Screen.Cursor:=crHourGlass;

Connected:=True;

Open;

Screen.Cursor:=crDefault;

ADOConnectLocalDB:=True;

except

ADOConnectLocalDB:=False;

end;

//Ado与ODBC共同连接数据库函数

function ADOODBCConnectLocalDB(Const Adocon:TAdoConnection;Const Dbname:String;ValidateMode:Integer):boolean;

begin

with Adocon do

begin

Close;

LoginPrompt:=False; //若数据库不存在时，进行判断。。。。。。

if ValidateMode=0 then//使用Windows NT验证模式

ConnectionString:='Provider=MSDASQL.1;'+

'Password="";'+

'Persist Security Info=False;'+

'User ID=sa;Data Source='+''''+DBName+''''+';'+

'Initial Catalog='+''''+DBname+'''';

if ValidateMode=1 then//使用SQL SERVER验证模式

ConnectionString:='Provider=MSDASQL.1;'+

'Password="";'+

'Persist Security Info=True;'+

'User ID=sa;Data Source='+''''+DBName+''''+';'+

'Initial Catalog='+''''+DBname+'''';

try

KeepConnection:=True;

Screen.Cursor:=crHourGlass;

Connected:=True;

Open;

Screen.Cursor:=crDefault;

ADOODBCConnectLocalDB:=True;

except

ADOODBCConnectLocalDB:=False;

end;

///在指定的数据库中建立表

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

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;

//在指定的表中新填字段

function AddField(LpFieldName:string; LpDataType: TFieldType; LpSize: Word):string;//建立新表

var

Sentence,SQLsentence : string;

begin

Sentence:= '';

SQLsentence:='';

if LpFieldName = '' then

raise EDBUpdateErr.Create('字段名不能为空');

if Pos(' ', LpFieldName) <> 0 then

raise EDBUpdateErr.Create('字段名中不能含有空格字符');

if LpDataType = ftString then

sentence := 'ADD '+LpFieldName+' Char('+ IntToStr( LpSize ) + ')';

if LpDataType = ftInteger then

sentence := 'ADD '+LpFieldName+' Integer';

if LpDataType = ftSmallInt then

sentence := 'ADD '+LpFieldName+' SmallInt';

if LpDataType = ftFloat then

sentence := 'ADD '+LpFieldName+' Float('+ IntToStr( LpSize ) +',0)';

if LpDataType = ftDate then

sentence := 'ADD '+LpFieldName+' Date';

if LpDataType = ftTime then

sentence := 'ADD '+LpFieldName+' Time';

if LpDataType = ftDateTime then

sentence := 'ADD '+LpFieldName+' TimeStamp';

if sentence = '' then

raise EDBUpdateErr.Create('无效的字段类型');

if SQLSentence = '' then

SQLSentence := sentence

else

SQLSentence := SQLSentence + ', ' + sentence;

Result:=SQLSentence;//返回SQL句体

end;

//在指定的表中删除字段

function KillField(LpFieldName:string):String;//删除表中的字段

var

SQLsentence : string;

begin

if LpFieldName = '' then

raise EDBUpdateErr.Create('字段名不能为空');

if Pos(' ', LpFieldName) <> 0 then

raise EDBUpdateErr.Create('字段名中不能含有空格字符');

if SQLSentence = '' then

SQLSentence := 'DROP COLUMN ' + LpFieldName

else

SQLSentence := SQLSentence + ', DROP ' + LpFieldName;

Result:=SQLSentence;

end;

//修改表结构的SQL语句执行体

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

var

AlterQueryTable:TQuery;

Successed:Boolean;//成功否

begin

Successed:=False;

AlterQueryTable:= TQuery.Create(nil);

try

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;

//修改、添加、删除表结构时的SQL句体

function GetSQLSentence(LpTableName,LpSQLsentence:string): string;

begin

Result := 'ALTER TABLE "'+ LpTableName +'" ' + LpSQLSentence + ';';

end;

//▎============================================================▎//

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

//▎============================================================▎//

//字符转化成十六进制

function StrToHex(AStr: string): string;

var

I : Integer;

// Tmp: string;

begin

Result := '';

For I := 1 to Length(AStr) do

begin

Result := Result + Format('%2x', [Byte(AStr[I])]);

end;

I := Pos(' ', Result);

While I <> 0 do

begin

Result[I] := '0';

I := Pos(' ', Result);

end;

//十六进制转化成字符

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;

function TransChar(AChar: Char): Integer;

begin

if AChar in ['0'..'9'] then

Result := Ord(AChar) - Ord('0')

else

Result := 10 + Ord(AChar) - Ord('A');

end;

//▎============================================================▎//

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

//▎============================================================▎//

// 输出限制在Min..Max之间

function TrimInt(Value, Min, Max: Integer): Integer; overload;

begin

if Value > Max then

Result := Max

else if Value < Min then

Result := Min

else

Result := Value;

end;

// 输出限制在0..255之间

function IntToByte(Value: Integer): Byte; overload;

asm

OR EAX, EAX

JNS @@Positive

XOR EAX, EAX

RET

@@Positive:

CMP EAX, 255

JBE @@OK

MOV EAX, 255

@@OK:

end;

// 由TRect分离出坐标、宽高

procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);

begin

x := Rect.Left;

y := Rect.Top;

Width := Rect.Right - Rect.Left;

Height := Rect.Bottom - Rect.Top;

end;

// 比较两个Rect

function RectEqu(Rect1, Rect2: TRect): Boolean;

begin

Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and

(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);

end;

// 产生TSize类型

function EnSize(cx, cy: Integer): TSize;

begin

Result.cx := cx;

Result.cy := cy;

end;

// 计算Rect的宽度

function RectWidth(Rect: TRect): Integer;

begin

Result := Rect.Right - Rect.Left;

end;

// 计算Rect的高度

function RectHeight(Rect: TRect): Integer;

begin

Result := Rect.Bottom - Rect.Top;

end;

// 判断范围

function InBound(Value: Integer; Min, Max: Integer): Boolean;

begin

Result := (Value >= Min) and (Value <= Max);

end;

// 交换两个数

procedure CnSwap(var A, B: Byte); overload;

var

Tmp: Byte;

begin

Tmp := A;

A := B;

B := Tmp;

end;

procedure CnSwap(var A, B: Integer); overload;

var

Tmp: Integer;

begin

Tmp := A;

A := B;

B := Tmp;

end;

procedure CnSwap(var A, B: Single); overload;

var

Tmp: Single;

begin

Tmp := A;

A := B;

B := Tmp;

end;

procedure CnSwap(var A, B: Double); overload;

var

Tmp: Double;

begin

Tmp := A;

A := B;

B := Tmp;

end;

// 延时

procedure Delay(const uDelay: DWORD);

var

n: DWORD;

begin

n := GetTickCount;

while ((GetTickCount - n) <= uDelay) do

Application.ProcessMessages;

end;

// 在Win9X下让喇叭发声

procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);

const

FREQ_SCALE = $1193180;

var

Temp: WORD;

begin

Temp := FREQ_SCALE div Freq;

asm

in al,61h;

or al,3;

out 61h,al;

mov al,$b6;

out 43h,al;

mov ax,temp;

out 42h,al;

mov al,ah;

out 42h,al;

end;

Sleep(Delay);

asm

in al,$61;

and al,$fc;

out $61,al;

end;

// 显示Win32 Api运行结果信息

procedure ShowLastError;

var

ErrNo: Integer;

Buf: array[0..255] of Char;

begin

ErrNo := GetLastError;

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

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

MessageBox(Application.Handle, PChar(string(Buf) + #10#13 +

SErrorCode + IntToStr(ErrNo)),

SCnInformation, MB_OK + MB_ICONINFORMATION);

end;

//将字体Font.Style写入INI文件

function writeFontStyle(FS: TFontStyles; inifile: string; write: boolean):string;

var

Mystyle : string;

Myini : Tinifile;

begin

Mystyle := '[';

if fsBold in FS then MyStyle := MyStyle + 'fsBold';

if fsItalic in FS then

if MyStyle = '[' then

MyStyle := MyStyle + 'fsItalic'

else

MyStyle := MyStyle + ',fsItalic';

if fsUnderline in FS then

if MyStyle = '[' then

MyStyle := MyStyle + 'fsUnderline'

else

MyStyle := MyStyle + ',fsUnderline';

if fsStrikeOut in FS then

if MyStyle = '[' then

MyStyle := MyStyle + 'fsStrikeOut'

else

MyStyle := MyStyle + ',fsStrikeOut';

MyStyle := MyStyle + ']';

if write then

begin

Myini := TInifile.Create(inifile);

Myini.WriteString('FontStyle', 'style', MyStyle);

Myini.free;

end;

Result := MyStyle;

end;

//从INI文件中读取字体Font.Style文件

function readFontStyle(inifile: string): TFontStyles;

var

MyFontStyle : TFontStyles;

MyStyle : string;

Myini : Tinifile;

begin

MyFontStyle := [];

Myini := TInifile.Create(inifile);

Mystyle := Myini.ReadString('Fontstyle', 'style', '[]');

if pos('fsBold', Mystyle) > 0 then MyFontStyle := MyFontStyle + [fsBold];

if Pos('fsItalic', MyStyle) > 0 then MyFontStyle := MyFontStyle + [fsItalic];

if Pos('fsUnderline', MyStyle) > 0 then

MyFontStyle := MyFontStyle + [fsUnderline];

if Pos('fsStrikeOut', MyStyle) > 0 then

MyFontStyle := MyFontStyle + [fsStrikeOut];

MyIni.free;

Result := MyFontStyle;

end;

//*取得TMemo 控件当前光标的行和列信息到Tpoint中

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

function ReadCursorPos(SourceMemo: TMemo): string;

var

// Point: TPoint;

X,Y:integer;

begin

// point.y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);

// point.x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,point.y,0);

y := SendMessage(SourceMemo.Handle, EM_LINEFROMCHAR,SourceMemo.SelStart,0);

x := SourceMemo.SelStart- SendMessage(SourceMemo.Handle,EM_LINEINDEX,y,0);

Result := '行:'+inttostr(y+1)+' '+'列:'+inttostr(x+1);

end;

//*检查Tmemo控件能否Undo功能

function CanUndo(AMemo: TMemo): Boolean;

begin

Result :=AMemo.Perform(EM_CANUNDO, 0, 0)<>0;

end;

//* 实现Undo功能

procedure Undo(Amemo: Tmemo);

begin

Amemo.Perform(EM_UNDO, 0, 0);

end;

//* 实现ComBoBox自动下拉

procedure AutoListDisplay(ACombox:TComboBox);

begin

SendMessage(ACombox.handle, CB_SHOWDROPDOWN, Integer(True), 0);

end;

//* 小写金额转换为大写

function UpperMoney(small:real):string;

var

SmallMonth,BigMonth:string;

wei1,qianwei1:string[2];

qianwei,dianweizhi,qian:integer;

ObjSmall:real;

begin

{------- 修改参数令值更精确 -------}

ObjSmall:=Abs(small);

qianwei:=-2;{小数点后的位置，需要的话也可以改动-2值}

Smallmonth:=formatfloat('0.00',ObjSmall);{转换成货币形式，需要的话小数点后加多几个零}

{---------------------------------}

dianweizhi :=pos('.',Smallmonth);{小数点的位置}

for qian:=length(Smallmonth) downto 1 do{循环小写货币的每一位，从小写的右边位置到左边}

begin

if qian<>dianweizhi then{如果读到的不是小数点就继续}

begin

case strtoint(copy(Smallmonth,qian,1)) of{位置上的数转换成大写}

1:wei1:='壹';

2:wei1:='贰';

3:wei1:='叁';

4:wei1:='肆';

5:wei1:='伍';

6:wei1:='陆';

7:wei1:='柒';

8:wei1:='捌';

9:wei1:='玖';

0:wei1:='零';

end;

case qianwei of{判断大写位置，可以继续增大到real类型的最大值}

-3:qianwei1:='厘';

-2:qianwei1:='分';

-1:qianwei1:='角';

0 :qianwei1:='元';

1 :qianwei1:='拾';

2 :qianwei1:='佰';

3 :qianwei1:='千';

4 :qianwei1:='万';

5 :qianwei1:='拾';

6 :qianwei1:='佰';

7 :qianwei1:='千';

8 :qianwei1:='亿';

9 :qianwei1:='十';

10:qianwei1:='佰';

11:qianwei1:='千';

end;

inc(qianwei);

if Small<0 then

BigMonth :='负'+wei1+qianwei1+BigMonth {组合成大写金额}

else

BigMonth :=wei1+qianwei1+BigMonth {组合成大写金额}

end;

Result:=BigMonth;

end;

//利用系统时间产生随机数

function Myrandom(Num: Integer): integer;

var

T: _SystemTime;

X: integer;

I: integer;

begin

Result := 0;

If Num = 0 then Exit;;

GetSystemTime(T);

X := Trunc(T.wMilliseconds/10) * T.wSecond * 1231;

X := X + random(1);

if X<>0 then

X := -X;

X := Random(X);

X := X mod num;

for I := 0 to X do

X := Random(Num);

Result := X;

end;

//打开输入法

procedure OpenIME(ImeName: string);

var

i: integer;

MyHKL: hkl;

begin

if ImeName <> '' then begin

if Screen.Imes.Count <> 0 then begin

i := Screen.Imes.IndexOf(ImeName);

if i >= 0 then MyHKL := hkl(Screen.Imes.Objects[i]);

ActivateKeyboardLayout(MyHKL, KLF_ACTIVATE);

end;

//关闭输入法

procedure CloseIME;

var

MyHKL: hkl;

begin

MyHKL := GetKeyboardLayout(0);

if ImmIsIme(MyHKL) then

ImmSimulateHotKey(Application.Handle, IME_CHOTKEY_IME_NONIME_TOGGLE);

end;

//打开中文输入法

procedure ToChinese(hWindows: THandle; bChinese: boolean);

begin

if ImmIsIME(GetKeyboardLayOut(0)) <> bChinese then

ImmSimulateHotKey(hWindows, IME_THotKey_IME_NonIME_Toggle);

end;

//数据备份

procedure BackUpData(LpBackDispMessTitle:String);

var

i,j:integer;

Source,Dest:array[0..200]of char;

s1:string;

Lp:_SHFILEOPSTRUCTA;

Success:Integer;

begin

if MessageBox(Application.Handle,' 您确认要备份数据吗？','询问窗口',4+32+256)=6 then

begin

with LP do

begin

Lp.wnd:=Application.Handle;

wFunc:=FO_COPY;

s1:='DATA/*.*';

i:=Length(s1);

StrCopy(Source,PChar(s1));

Source[i]:=#0;

Source[i+1]:=#0;

Source[i+2]:=#0;

pFrom:=Source;

s1:='BACKUP';

j:=Length(s1);

StrCopy(Dest,PChar(s1));

Dest[j]:='/';

Dest[j+1]:=#0;

Dest[j+2]:=#0;

Dest[j+3]:=#0;

pTo:=Dest;

fFlags:=FOF_ALLOWUNDO;

fAnyOperationsAborted:=False;

lpszProgressTitle:=PChar(LpBackDispMessTitle);

end;

Success:=SHFileOperation(LP);

case Success of

MessageBox(Application.Handle,' 所有数据已备份完成！','提示窗口',0+48);

117:

MessageBox(Application.Handle,Pchar(' 您未创建“'+ExtractFilePath(Application.ExeName)+'BACKUP”目录所以不能完成数据备份！'),'提示窗口',0+16)

else

MessageBox(Application.Handle,' 在备份数据的过程中被用户中途中断！','提示窗口',0+16);

end;

// //

// 从文件中读取Ado连接字串 //

// //

function GetConnectionString(DataBaseName:string):string;

var FileStringList:Tstringlist;

TempString: ansistring;

TheReg:TRegistry;KeyName,fAppPath:string;

i:Integer;

begin

TheReg:=TRegistry.Create;

try

TheReg.RootKey:=HKEY_LOCAL_MACHINE;

KeyName:='Software/政府采购管理系统';

if TheReg.OpenKey(KeyName,False) then

fAppPath:=TheReg.ReadString('ApplicationPath');

finally

TheReg.Free;

end;

FileStringList:=Tstringlist.Create;

//先判断connection.txt是否存在,存在就调入

if FileExists(fAppPath+'/connection.txt') then

FileStringList.LoadFromFile(fAppPath+'/connection.txt')

else

begin

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

Result:='';

FileStringList.Free;

Exit;

end;

//组成一个符串，好进行处理。

TempString:='';

for i:=0 to FileStringList.Count-1 do

begin

TempString:=TempString+FileStringList.strings[i];

end;

{连接指定名称的数据库}

TempString:=Replace(TempString,'DataBaseName',DataBaseName,False);

Result:=TempString;

end;

{------------------------------------------------------------------------------}

{function GetRemoteServerName：返回远程服务器的机器名称}

function GetRemoteServerName:string;

var iniServer:TIniFile;

TheReg:TRegistry;KeyName,fAppPath,RServerName:string;

begin

TheReg:=TRegistry.Create;

try

TheReg.RootKey:=HKEY_LOCAL_MACHINE;

KeyName:='Software/政府采购管理系统';

if TheReg.OpenKey(KeyName,False) then

fAppPath:=TheReg.ReadString('ApplicationPath');

finally

TheReg.Free;

end;

{创建远程服务器名称}

try

iniServer:=TIniFile.Create(fAppPath+'/RemoteServerName.ini');

with iniServer do

RServerName:=ReadString('Option','RServerName','');

iniServer.Free;

except

raise exception.Create('致命错误：未找到包含Com服务器配置的信息文件，初始化失败。');

end;

Result:=RServerName;

end;

initialization

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

end.

推荐分享