{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎ ▎}
{▎ 系统公用函数及过程 ▎}
{▎ ▎}
{▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎▎}
{▎ 软件名称: 开发包基础库 ▎}
{▎ 单元名称: 公共运行时间库单元 ▎}
{▎ 单元版本: 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.