{ 原始文件名:CnCommon.pas }
{ 单元作者:CnPack开发组 }
{ 下载地址:http://cnpack.yeah.net }
{ 电子邮件:cnpack@163.com }
{ 备注:该单元为开发包公共运行时间库单元 }
{ 最后更新:2002.04.09 V1.0 }
{ }
{******************************************************************************}
unit CnCommon;
interface
{$I CnPack.inc}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, ShellAPI, CommDlg, MMSystem, CnConsts;
//----------------------------------------------------------------------------//
//扩展的文件目录操作函数 //
//----------------------------------------------------------------------------//
function MoveFile(const sName, dName: string): Boolean;
{* 移动文件、目录,参数为源、目标名}
procedure FileProperties(const FName: string);
{* 打开文件属性窗口}
function OpenDialog(var FileName: string; Title: string; Filter: string;
Ext: string): Boolean;
{* 打开文件框}
function FormatPath(APath: string; Width: Integer): string;
{* 缩短显示不下的长路径名}
function GetRelativePath(Source, Dest: string): string;
{* 取两个目录的相对路径,注意串尾不能是'/'字符!}
procedure RunFile(const FName: string; Handle: THandle = 0;
const Param: string = '');
{* 运行一个文件}
function WinExecAndWait32(FileName: string; Visibility: Integer = SW_NORMAL):
Integer;
{* 运行一个文件并等待其结束}
function AppPath: string;
{* 应用程序路径}
function GetWindowsDir: string;
{* 取Windows系统目录}
function GetWinTempDir: string;
{* 取临时文件目录}
function AddDirSuffix(Dir: string): string;
{* 目录尾加'/'修正}
function MakePath(Dir: string): string;
{* 目录尾加'/'修正}
function IsFileInUse(FName: string): Boolean;
{* 判断文件是否正在使用}
function GetFileSize(FileName: string): Integer;
{* 取文件长度}
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
{* 设置文件时间}
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
{* 取文件时间}
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
{* 文件时间转本地时间}
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
{* 本地时间转文件时间}
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;
{* 取得与文件相关的图标,成功则返回True}
function CreateBakFile(FileName, Ext: string): Boolean;
{* 创建备份文件}
function Deltree(Dir: string): Boolean;
{* 删除整个目录}
function GetDirFiles(Dir: string): Integer;
{* 取文件夹文件数}
type
TFindCallBack = procedure(const FileName: string; const Info: TSearchRec;
var Abort: Boolean);
{* 查找指定目录下文件的回调函数}
procedure FindFile(const Path: string; const FileName: string = '*.*';
Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);
{* 查找指定目录下文件}
function OpenWith(const FileName: string): Integer;
{* 文件打开方式}
//----------------------------------------------------------------------------//
//扩展的字符串操作函数 //
//----------------------------------------------------------------------------//
function InStr(const sShort: string; const sLong: string): Boolean;
{* 判断s1是否包含在s2中}
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;
{* 字节转二进制串}
function StrRight(Str: string; Len: Integer): string;
{* 返回字符串右边的字符}
function StrLeft(Str: string; Len: Integer): string;
{* 返回字符串左边的字符}
function Spc(Len: Integer): string;
{* 返回空格串}
procedure SwapStr(var s1, s2: string);
{* 交换字串}
function LinesToStr(const Lines: string): string;
{* 多行文本转单行(换行符转'/n')}
function StrToLines(const Str: string): string;
{* 单行文本转多行('/n'转换行符)}
//----------------------------------------------------------------------------//
//扩展的对话框函数 //
//----------------------------------------------------------------------------//
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;
{* 显示查询是否窗口}
//----------------------------------------------------------------------------//
//扩展日期时间操作函数 //
//----------------------------------------------------------------------------//
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;
{* 取时间毫秒分量}
//----------------------------------------------------------------------------//
//位操作函数 //
//----------------------------------------------------------------------------//
type
TByteBit = 0..7;
{* Byte类型位数范围}
TWordBit = 0..15;
{* Word类型位数范围}
TDWordBit = 0..31;
{* DWord类型位数范围}
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;
{* 设置二进制位}
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload;
{* 设置二进制位}
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload;
{* 设置二进制位}
function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload;
{* 取二进制位}
function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload;
{* 取二进制位}
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload;
{* 取二进制位}
//----------------------------------------------------------------------------//
//系统功能函数 //
//----------------------------------------------------------------------------//
procedure MoveMouseIntoControl(AWinControl: TControl);
{* 移动鼠标到控件}
function DynamicResolution(x, y: WORD): Boolean;
{* 动态设置分辨率}
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
{* 窗口最上方显示}
procedure SetHidden(Hide: Boolean);
{* 设置程序是否出现在任务栏}
procedure SetTaskBarVisible(Visible: Boolean);
{* 设置任务栏是否可见}
procedure SetDesktopVisible(Visible: Boolean);
{* 设置桌面是否可见}
procedure BeginWait;
{* 显示等待光标}
procedure EndWait;
{* 结束等待光标}
function CheckWindows9598: Boolean;
{* 检测是否Win95/98平台}
//----------------------------------------------------------------------------//
//其它过程 //
//----------------------------------------------------------------------------//
function TrimInt(Value, Min, Max: Integer): Integer; overload;
{* 输出限制在Min..Max之间}
function IntToByte(Value: Integer): Byte; overload;
{* 输出限制在0..255之间}
function InBound(Value: Integer; Min, Max: Integer): Boolean;
{* 判断整数Value是否在Min和Max之间}
procedure CnSwap(var A, B: Byte); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Integer); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Single); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Double); overload;
{* 交换两个数}
function RectEqu(Rect1, Rect2: TRect): Boolean;
{* 比较两个Rect是否相等}
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
{* 分解一个TRect为左上角坐标x, y和宽度Width、高度Height}
function EnSize(cx, cy: Integer): TSize;
{* 返回一个TSize类型}
function RectWidth(Rect: TRect): Integer;
{* 计算TRect的宽度}
function RectHeight(Rect: TRect): Integer;
{* 计算TRect的高度}
procedure Delay(const uDelay: DWORD);
{* 延时}
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
{* 在Win9X下让喇叭发声}
procedure ShowLastError;
{* 显示Win32 Api运行结果信息}
function GetHzPy(const AHzStr: string): string;
{* 取汉字的拼音}
function SoundCardExist: Boolean;
{* 声卡是否存在}
implementation
//----------------------------------------------------------------------------//
//扩展的文件目录操作函数 //
//----------------------------------------------------------------------------//
//移动文件、目录
function MoveFile(const sName, dName: string): Boolean;
var
s1, s2: AnsiString;
lpFileOp: TSHFileOpStruct;
begin
s1 := PChar(sName) + #0#0;
s2 := PChar(dName) + #0#0;
with lpFileOp do
begin
Wnd := Application.Handle;
wFunc := FO_MOVE;
pFrom := PChar(s1);
pTo := PChar(s2);
fFlags := FOF_ALLOWUNDO;
hNameMappings := nil;
lpszProgressTitle := nil;
fAnyOperationsAborted := True;
end;
Result := SHFileOperation(lpFileOp) = 0;
end;
//打开文件属性窗口
procedure FileProperties(const FName: string);
var
SEI: SHELLEXECUTEINFO;
begin
with SEI do
begin
cbSize := SizeOf(SEI);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or
SEE_MASK_FLAG_NO_UI;
Wnd := Application.Handle;
lpVerb := 'properties';
lpFile := PChar(FName);
lpParameters := nil;
lpDirectory := nil;
nShow := 0;
hInstApp := 0;
lpIDList := nil;
end;
ShellExecuteEx(@@SEI);
end;
//缩短显示不下的长路径名
function FormatPath(APath: string; Width: Integer): string;
var
SLen: Integer;
i, j: Integer;
TString: string;
begin
SLen := Length(APath);
if (SLen <= Width) or (Width <= 6) then
begin
Result := APath;
Exit
end
else
begin
i := SLen;
TString := APath;
for j := 1 to 2 do
begin
while (TString <> '/') and (SLen - i < Width - 8) do
i := i - 1;
i := i - 1;
end;
for j := SLen - i - 1 downto 0 do
TString[Width - j] := TString[SLen - j];
for j := SLen - i to SLen - i + 2 do
TString[Width - j] := '.';
Delete(TString, Width + 1, 255);
Result := TString;
end;
end;
//打开文件框
function OpenDialog(var FileName: string; Title: string; Filter: string;
Ext: string): Boolean;
var
OpenName: TOPENFILENAME;
TempFilename, ReturnFile: string;
begin
with OpenName do
begin
lStructSize := SizeOf(OpenName);
hWndOwner := GetModuleHandle('');
Hinstance := SysInit.Hinstance;
lpstrFilter := PChar(Filter + #0 + Ext + #0#0);
lpstrCustomFilter := '';
nMaxCustFilter := 0;
nFilterIndex := 1;
nMaxFile := MAX_PATH;
SetLength(TempFilename, nMaxFile + 2);
lpstrFile := PChar(TempFilename);
FillChar(lpstrFile^, MAX_PATH, 0);
SetLength(TempFilename, nMaxFile + 2);
nMaxFileTitle := MAX_PATH;
SetLength(ReturnFile, MAX_PATH + 2);
lpstrFileTitle := PChar(ReturnFile);
FillChar(lpstrFile^, MAX_PATH, 0);
lpstrInitialDir := '.';
lpstrTitle := PChar(Title);
Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;
nFileOffset := 0;
nFileExtension := 0;
lpstrDefExt := PChar(Ext);
lCustData := 0;
lpfnHook := nil;
lpTemplateName := '';
end;
Result := GetOpenFileName(OpenName);
if Result then
FileName := ReturnFile
else
FileName := '';
end;
// 取两个目录的相对路径,注意串尾不能是'/'字符!
function GetRelativePath(Source, Dest: string): string;
//比较两路径字符串头部相同串的函数
function GetPathComp(s1, s2: string): Integer;
begin
if Length(s1) > Length(s2) then swapStr(s1, s2);
Result := Pos(s1, s2);
while (Result = 0) and (Length(s1) > 3) do
begin
if s1 = '' then Exit;
s1 := ExtractFileDir(s1);
Result := Pos(s1, s2);
end;
if Result <> 0 then Result := Length(s1);
if Result = 3 then Result := 2;
//修正因ExtractFileDir()处理'c:/'时产生的错误.
end;
//取Dest的相对根路径的函数
function GetRoot(s: ShortString): string;
var
i: Integer;
begin
Result := '';
for i := 1 to Length(s) do
if s = '/' then Result := Result + '../';
if Result = '' then Result := './';
//如果不想处理成"./"的路径格式,可去掉本行
end;
var
RelativRoot, RelativSub: string;
HeadNum: Integer;
begin
Source := UpperCase(Source);
Dest := UpperCase(Dest); //比较两路径字符串头部相同串
HeadNum := GetPathComp(Source, Dest); //取Dest的相对根路径
RelativRoot := GetRoot(StrRight(Dest, Length(Dest) - HeadNum));
//取Source的相对子路径
RelativSub := StrRight(Source, Length(Source) - HeadNum - 1);
//返回
Result := RelativRoot + RelativSub;
end;
//运行一个文件
procedure RunFile(const FName: string; Handle: THandle;
const Param: string);
begin
ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;
//运行一个文件并等待其结束
function WinExecAndWait32(FileName: string; Visibility: Integer): Integer;
var
zAppName: array[0..512] of Char;
zCurDir: array[0..255] of Char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
False, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) then
Result := -1 { pointer to PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));
end;
end;
//应用程序路径
function AppPath: string;
begin
Result := ExtractFilePath(Application.ExeName);
end;
//取Windows系统目录
function GetWindowsDir: string;
var
Buf: array[0..MAX_PATH] of Char;
begin
GetWindowsDirectory(Buf, MAX_PATH);
Result := AddDirSuffix(Buf);
end;
//取临时文件目录
function GetWinTempDir: string;
var
Buf: array[0..MAX_PATH] of Char;
begin
GetTempPath(MAX_PATH, Buf);
Result := AddDirSuffix(Buf);
end;
//目录尾加'/'修正
function AddDirSuffix(Dir: string): string;
begin
Result := Trim(Dir);
if Result = '' then Exit;
if Result[Length(Result)] <> '/' then Result := Result + '/';
end;
function MakePath(Dir: string): string;
begin
Result := AddDirSuffix(Dir);
end;
//判断文件是否正在使用
function IsFileInUse(FName: string): Boolean;
var
HFileRes: HFILE;
begin
Result := False;
if not FileExists(FName) then
Exit;
HFileRes := CreateFile(PChar(FName), GENERIC_READ or GENERIC_WRITE, 0,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;
//取文件长度
function GetFileSize(FileName: string): Integer;
var
FileVar: file of Byte;
begin
{$I-}
try
AssignFile(FileVar, FileName);
Reset(FileVar);
Result := FileSize(FileVar);
CloseFile(FileVar);
except
Result := 0;
end;
{$I+}
end;
//设置文件时间
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
var
FileHandle: Integer;
begin
FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
if FileHandle > 0 then
begin
SetFileTime(FileHandle, @@CreationTime, @@LastAccessTime, @@LastWriteTime);
FileClose(FileHandle);
Result := True;
end
else
Result := False;
end;
//取文件时间
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
var
FileHandle: Integer;
begin
FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if FileHandle > 0 then
begin
GetFileTime(FileHandle, @@CreationTime, @@LastAccessTime, @@LastWriteTime);
FileClose(FileHandle);
Result := True;
end
else
Result := False;
end;
//取得与文件相关的图标
//FileName: e.g. "e:/hao/a.txt"
//成功则返回True
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;
var
SHFileInfo: TSHFileInfo;
h: HWND;
begin
if not Assigned(Icon) then
Icon := TIcon.Create;
h := SHGetFileInfo(PChar(FileName),
0,
SHFileInfo,
SizeOf(SHFileInfo),
SHGFI_ICON or SHGFI_SYSICONINDEX);
Icon.Handle := SHFileInfo.hIcon;
Result := (h <> 0);
end;
//文件时间转本地时间
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
var
STime: TSystemTime;
begin
FileTimeToLocalFileTime(FTime, FTime);
FileTimeToSystemTime(FTime, STime);
Result := STime;
end;
//本地时间转文件时间
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
var
FTime: TFileTime;
begin
SystemTimeToFileTime(STime, FTime);
LocalFileTimeToFileTime(FTime, FTime);
Result := FTime;
end;
//创建备份文件
function CreateBakFile(FileName, Ext: string): Boolean;
var
BakFileName: string;
begin
BakFileName := FileName + '.' + Ext;
Result := CopyFile(PChar(FileName), PChar(BakFileName), False);
end;
//删除整个目录
function Deltree(Dir: string): Boolean;
var
sr: TSearchRec;
fr: Integer;
begin
if not DirectoryExists(Dir) then
begin
Result := True;
Exit;
end;
fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);
try
while fr = 0 do
begin
if (sr.Name <> '.') and (sr.Name <> '..') then
begin
if sr.Attr and faDirectory = faDirectory then
Result := Deltree(AddDirSuffix(Dir) + sr.Name)
else
Result := DeleteFile(AddDirSuffix(Dir) + sr.Name);
if not Result then
Exit;
end;
fr := FindNext(sr);
end;
finally
FindClose(sr);
end;
Result := RemoveDir(Dir);
end;
//取文件夹文件数
function GetDirFiles(Dir: string): Integer;
var
sr: TSearchRec;
fr: Integer;
begin
Result := 0;
fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);
while fr = 0 do
begin
if (sr.Name <> '.') and (sr.Name <> '..') then
Inc(Result);
fr := FindNext(sr);
end;
FindClose(sr);
end;
var
FindAbort: Boolean;
//查找指定目录下文件
procedure FindFile(const Path: string; const FileName: string = '*.*';
Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);
var
APath: string;
Info: TSearchRec;
Succ: Integer;
begin
FindAbort := False;
APath := MakePath(Path);
try
Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info);
while Succ = 0 do
begin
if (Info.Name <> '.') and (Info.Name <> '..') then
begin
if (Info.Attr and faDirectory) <> faDirectory then
begin
if Assigned(Proc) then
Proc(APath + Info.FindData.cFileName, Info, FindAbort);
end
else if bSub then
FindFile(APath + Info.Name, FileName, Proc, bSub, bMsg);
end;
if bMsg then Application.ProcessMessages;
if FindAbort then Exit;
Succ := FindNext(Info);
end;
finally
FindClose(Info);
end;
end;
//文件打开方式
function OpenWith(const FileName: string): Integer;
begin
Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe',
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);
end;
//----------------------------------------------------------------------------//
//扩展的字符串操作函数 //
//----------------------------------------------------------------------------//
//判断s1是否包含在s2中
function InStr(const sShort: string; const sLong: string): Boolean;
var
s1, s2: string;
begin
s1 := LowerCase(sShort);
s2 := LowerCase(sLong);
Result := Pos(s1, s2) > 0;
end;
//扩展整数转字符串函数,参数分别为目标数、长度、填充字符(默认为0)
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
begin
Result := IntToStr(Value);
while Length(Result) < Len do
Result := FillChar + Result;
end;
//带分隔符的整数-字符转换
function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
var
s: string;
i, j: Integer;
begin
s := IntToStr(Value);
Result := '';
j := 0;
for i := Length(s) downto 1 do
begin
Result := s + Result;
Inc(j);
if ((j mod SpLen) = 0) and (i <> 1) then Result := Sp + Result;
end;
end;
//返回字符串右边的字符
function StrRight(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, Length(Str) - Len + 1, Len);
end;
//返回字符串左边的字符
function StrLeft(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, 1, Len);
end;
//字节转二进制串
function ByteToBin(Value: Byte): string;
const
V: Byte = 1;
var
i: Integer;
begin
for i := 7 downto 0 do
if (V shl i) and Value <> 0 then
Result := Result + '1'
else
Result := Result + '0';
end;
//返回空格串
function Spc(Len: Integer): string;
var
i: Integer;
begin
Result := '';
for i := 0 to Len - 1 do
Result := Result + ' ';
end;
//交换字串
procedure SwapStr(var s1, s2: string);
var
tempstr: string;
begin
tempstr := s1;
s1 := s2;
s2 := tempstr;
end;
const
csLinesCR = #13#10;
csStrCR = '/n';
//多行文本转单行(换行符转'/n')
function LinesToStr(const Lines: string): string;
var
i: Integer;
begin
Result := Lines;
i := Pos(csLinesCR, Result);
while i > 0 do
begin
system.Delete(Result, i, Length(csLinesCR));
system.insert(csStrCR, Result, i);
i := Pos(csLinesCR, Result);
end;
end;
//单行文本转多行('/n'转换行符)
function StrToLines(const Str: string): string;
var
i: Integer;
begin
Result := Str;
i := Pos(csStrCR, Result);
while i > 0 do
begin
system.Delete(Result, i, Length(csStrCR));
system.insert(csLinesCR, Result, i);
i := Pos(csStrCR, Result);
end;
end;
//----------------------------------------------------------------------------//
//扩展的对话框函数 //
//----------------------------------------------------------------------------//
//显示提示窗口
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;
//显示提示确认窗口
function InfoOk(Mess: string; Caption: string): Boolean;
begin
Result := Application.MessageBox(PChar(Mess), PChar(Caption),
MB_OKCANCEL + MB_ICONINFORMATION) = IDOK;
end;
//显示错误窗口
procedure ErrorDlg(Mess: string; Caption: string);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;
//显示警告窗口
procedure WarningDlg(Mess: string; Caption: string);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;
//显示查询是否窗口
function QueryDlg(Mess: string; Caption: string): Boolean;
begin
Result := Application.MessageBox(PChar(Mess), PChar(Caption),
MB_YESNO + MB_ICONQUESTION) = IDYES;
end;
//----------------------------------------------------------------------------//
//位扩展日期时间操作函数 //
//----------------------------------------------------------------------------//
function GetYear(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := y;
end;
function GetMonth(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := m;
end;
function GetDay(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := d;
end;
function GetHour(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := h;
end;
function GetMinute(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := m;
end;
function GetSecond(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := s;
end;
function GetMSecond(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := ms;
end;
//----------------------------------------------------------------------------//
//位操作函数 //
//----------------------------------------------------------------------------//
//设置位
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
//取位
function GetBit(Value: Byte; Bit: TByteBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
function GetBit(Value: WORD; Bit: TWordBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
//----------------------------------------------------------------------------//
//系统功能函数 //
//----------------------------------------------------------------------------//
//移动鼠标到控件
procedure MoveMouseIntoControl(AWinControl: TControl);
var
rtControl: TRect;
begin
rtControl := AWinControl.BoundsRect;
MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2);
SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2,
rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2);
end;
//动态设置分辨率
function DynamicResolution(x, y: WORD): Boolean;
var
lpDevMode: TDeviceMode;
begin
Result := EnumDisplaySettings(nil, 0, lpDevMode);
if Result then
begin
lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := x;
lpDevMode.dmPelsHeight := y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;
//窗口最上方显示
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
const
csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
end;
var
WndLong: Integer;
//设置程序是否出现在任务栏
procedure SetHidden(Hide: Boolean);
begin
ShowWindow(Application.Handle, SW_HIDE);
if Hide then
SetWindowLong(Application.Handle, GWL_EXSTYLE,
WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)
else
SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);
ShowWindow(Application.Handle, SW_SHOW);
end;
const
csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);
//设置任务栏是否可见
procedure SetTaskBarVisible(Visible: Boolean);
var
wndHandle: THandle;
begin
wndHandle := FindWindow('Shell_TrayWnd', nil);
ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;
//设置桌面是否可见
procedure SetDesktopVisible(Visible: Boolean);
var
hDesktop: THandle;
begin
hDesktop := FindWindow('Progman', nil);
ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;
//显示等待光标
procedure BeginWait;
begin
Screen.Cursor := crHourGlass;
end;
//结束等待光标
procedure EndWait;
begin
Screen.Cursor := crDefault;
end;
//检测是否Win95/98平台
function CheckWindows9598: Boolean;
var
V: TOSVersionInfo;
begin
V.dwOSVersionInfoSize := SizeOf(V);
Result := False;
if not GetVersionEx(V) then Exit;
if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
Result := True;
end;
// 输出限制在Min..Max之间
function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value < Min then
Result := Min
else
Result := Value;
end;
// 输出限制在0..255之间
function IntToByte(Value: Integer): Byte; overload;
asm
OR EAX, EAX
JNS @@@@Positive
XOR EAX, EAX
RET
@@@@Positive:
CMP EAX, 255
JBE @@@@OK
MOV EAX, 255
@@@@OK:
end;
// 由TRect分离出坐标、宽高
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
begin
x := Rect.Left;
y := Rect.Top;
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
end;
// 比较两个Rect
function RectEqu(Rect1, Rect2: TRect): Boolean;
begin
Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and
(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;
// 产生TSize类型
function EnSize(cx, cy: Integer): TSize;
begin
Result.cx := cx;
Result.cy := cy;
end;
// 计算Rect的宽度
function RectWidth(Rect: TRect): Integer;
begin
Result := Rect.Right - Rect.Left;
end;
// 计算Rect的高度
function RectHeight(Rect: TRect): Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
// 判断范围
function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;
// 交换两个数
procedure CnSwap(var A, B: Byte); overload;
var
Tmp: Byte;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Integer); overload;
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Single); overload;
var
Tmp: Single;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Double); overload;
var
Tmp: Double;
begin
Tmp := A;
A := B;
B := Tmp;
end;
//延时
procedure Delay(const uDelay: DWORD);
var
n: DWORD;
begin
n := GetTickCount;
while ((GetTickCount - n) <= uDelay) do
Application.ProcessMessages;
end;
//在Win9X下让喇叭发声
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
const
FREQ_SCALE = $1193180;
var
Temp: WORD;
begin
Temp := FREQ_SCALE div Freq;
asm
in al,61h;
or al,3;
out 61h,al;
mov al,$b6;
out 43h,al;
mov ax,temp;
out 42h,al;
mov al,ah;
out 42h,al;
end;
Sleep(Delay);
asm
in al,$61;
and al,$fc;
out $61,al;
end;
end;
//显示Win32 Api运行结果信息
procedure ShowLastError;
var
ErrNo: Integer;
Buf: array[0..255] of Char;
begin
ErrNo := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, $400, Buf, 255, nil);
if Buf = '' then StrCopy(@@Buf, PChar(SUnknowError));
MessageBox(Application.Handle, PChar(string(Buf) + #10#13 +
SErrorCode + IntToStr(ErrNo)),
SCnInformation, MB_OK + MB_ICONINFORMATION);
end;
//取汉字的拼音
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
i := 1;
while i <= Length(AHzStr) do
begin
if (AHzStr >= #160) and (AHzStr[i + 1] >= #160) then
begin
HzOrd := (Ord(AHzStr) - 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;
Inc(i);
end;
end;
//声卡是否存在
function SoundCardExist: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;
initialization
WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);
end.
{ 单元作者:CnPack开发组 }
{ 下载地址:http://cnpack.yeah.net }
{ 电子邮件:cnpack@163.com }
{ 备注:该单元为开发包公共运行时间库单元 }
{ 最后更新:2002.04.09 V1.0 }
{ }
{******************************************************************************}
unit CnCommon;
interface
{$I CnPack.inc}
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
FileCtrl, ShellAPI, CommDlg, MMSystem, CnConsts;
//----------------------------------------------------------------------------//
//扩展的文件目录操作函数 //
//----------------------------------------------------------------------------//
function MoveFile(const sName, dName: string): Boolean;
{* 移动文件、目录,参数为源、目标名}
procedure FileProperties(const FName: string);
{* 打开文件属性窗口}
function OpenDialog(var FileName: string; Title: string; Filter: string;
Ext: string): Boolean;
{* 打开文件框}
function FormatPath(APath: string; Width: Integer): string;
{* 缩短显示不下的长路径名}
function GetRelativePath(Source, Dest: string): string;
{* 取两个目录的相对路径,注意串尾不能是'/'字符!}
procedure RunFile(const FName: string; Handle: THandle = 0;
const Param: string = '');
{* 运行一个文件}
function WinExecAndWait32(FileName: string; Visibility: Integer = SW_NORMAL):
Integer;
{* 运行一个文件并等待其结束}
function AppPath: string;
{* 应用程序路径}
function GetWindowsDir: string;
{* 取Windows系统目录}
function GetWinTempDir: string;
{* 取临时文件目录}
function AddDirSuffix(Dir: string): string;
{* 目录尾加'/'修正}
function MakePath(Dir: string): string;
{* 目录尾加'/'修正}
function IsFileInUse(FName: string): Boolean;
{* 判断文件是否正在使用}
function GetFileSize(FileName: string): Integer;
{* 取文件长度}
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
{* 设置文件时间}
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
{* 取文件时间}
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
{* 文件时间转本地时间}
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
{* 本地时间转文件时间}
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;
{* 取得与文件相关的图标,成功则返回True}
function CreateBakFile(FileName, Ext: string): Boolean;
{* 创建备份文件}
function Deltree(Dir: string): Boolean;
{* 删除整个目录}
function GetDirFiles(Dir: string): Integer;
{* 取文件夹文件数}
type
TFindCallBack = procedure(const FileName: string; const Info: TSearchRec;
var Abort: Boolean);
{* 查找指定目录下文件的回调函数}
procedure FindFile(const Path: string; const FileName: string = '*.*';
Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);
{* 查找指定目录下文件}
function OpenWith(const FileName: string): Integer;
{* 文件打开方式}
//----------------------------------------------------------------------------//
//扩展的字符串操作函数 //
//----------------------------------------------------------------------------//
function InStr(const sShort: string; const sLong: string): Boolean;
{* 判断s1是否包含在s2中}
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;
{* 字节转二进制串}
function StrRight(Str: string; Len: Integer): string;
{* 返回字符串右边的字符}
function StrLeft(Str: string; Len: Integer): string;
{* 返回字符串左边的字符}
function Spc(Len: Integer): string;
{* 返回空格串}
procedure SwapStr(var s1, s2: string);
{* 交换字串}
function LinesToStr(const Lines: string): string;
{* 多行文本转单行(换行符转'/n')}
function StrToLines(const Str: string): string;
{* 单行文本转多行('/n'转换行符)}
//----------------------------------------------------------------------------//
//扩展的对话框函数 //
//----------------------------------------------------------------------------//
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;
{* 显示查询是否窗口}
//----------------------------------------------------------------------------//
//扩展日期时间操作函数 //
//----------------------------------------------------------------------------//
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;
{* 取时间毫秒分量}
//----------------------------------------------------------------------------//
//位操作函数 //
//----------------------------------------------------------------------------//
type
TByteBit = 0..7;
{* Byte类型位数范围}
TWordBit = 0..15;
{* Word类型位数范围}
TDWordBit = 0..31;
{* DWord类型位数范围}
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean); overload;
{* 设置二进制位}
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean); overload;
{* 设置二进制位}
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean); overload;
{* 设置二进制位}
function GetBit(Value: Byte; Bit: TByteBit): Boolean; overload;
{* 取二进制位}
function GetBit(Value: WORD; Bit: TWordBit): Boolean; overload;
{* 取二进制位}
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean; overload;
{* 取二进制位}
//----------------------------------------------------------------------------//
//系统功能函数 //
//----------------------------------------------------------------------------//
procedure MoveMouseIntoControl(AWinControl: TControl);
{* 移动鼠标到控件}
function DynamicResolution(x, y: WORD): Boolean;
{* 动态设置分辨率}
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
{* 窗口最上方显示}
procedure SetHidden(Hide: Boolean);
{* 设置程序是否出现在任务栏}
procedure SetTaskBarVisible(Visible: Boolean);
{* 设置任务栏是否可见}
procedure SetDesktopVisible(Visible: Boolean);
{* 设置桌面是否可见}
procedure BeginWait;
{* 显示等待光标}
procedure EndWait;
{* 结束等待光标}
function CheckWindows9598: Boolean;
{* 检测是否Win95/98平台}
//----------------------------------------------------------------------------//
//其它过程 //
//----------------------------------------------------------------------------//
function TrimInt(Value, Min, Max: Integer): Integer; overload;
{* 输出限制在Min..Max之间}
function IntToByte(Value: Integer): Byte; overload;
{* 输出限制在0..255之间}
function InBound(Value: Integer; Min, Max: Integer): Boolean;
{* 判断整数Value是否在Min和Max之间}
procedure CnSwap(var A, B: Byte); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Integer); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Single); overload;
{* 交换两个数}
procedure CnSwap(var A, B: Double); overload;
{* 交换两个数}
function RectEqu(Rect1, Rect2: TRect): Boolean;
{* 比较两个Rect是否相等}
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
{* 分解一个TRect为左上角坐标x, y和宽度Width、高度Height}
function EnSize(cx, cy: Integer): TSize;
{* 返回一个TSize类型}
function RectWidth(Rect: TRect): Integer;
{* 计算TRect的宽度}
function RectHeight(Rect: TRect): Integer;
{* 计算TRect的高度}
procedure Delay(const uDelay: DWORD);
{* 延时}
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
{* 在Win9X下让喇叭发声}
procedure ShowLastError;
{* 显示Win32 Api运行结果信息}
function GetHzPy(const AHzStr: string): string;
{* 取汉字的拼音}
function SoundCardExist: Boolean;
{* 声卡是否存在}
implementation
//----------------------------------------------------------------------------//
//扩展的文件目录操作函数 //
//----------------------------------------------------------------------------//
//移动文件、目录
function MoveFile(const sName, dName: string): Boolean;
var
s1, s2: AnsiString;
lpFileOp: TSHFileOpStruct;
begin
s1 := PChar(sName) + #0#0;
s2 := PChar(dName) + #0#0;
with lpFileOp do
begin
Wnd := Application.Handle;
wFunc := FO_MOVE;
pFrom := PChar(s1);
pTo := PChar(s2);
fFlags := FOF_ALLOWUNDO;
hNameMappings := nil;
lpszProgressTitle := nil;
fAnyOperationsAborted := True;
end;
Result := SHFileOperation(lpFileOp) = 0;
end;
//打开文件属性窗口
procedure FileProperties(const FName: string);
var
SEI: SHELLEXECUTEINFO;
begin
with SEI do
begin
cbSize := SizeOf(SEI);
fMask := SEE_MASK_NOCLOSEPROCESS or SEE_MASK_INVOKEIDLIST or
SEE_MASK_FLAG_NO_UI;
Wnd := Application.Handle;
lpVerb := 'properties';
lpFile := PChar(FName);
lpParameters := nil;
lpDirectory := nil;
nShow := 0;
hInstApp := 0;
lpIDList := nil;
end;
ShellExecuteEx(@@SEI);
end;
//缩短显示不下的长路径名
function FormatPath(APath: string; Width: Integer): string;
var
SLen: Integer;
i, j: Integer;
TString: string;
begin
SLen := Length(APath);
if (SLen <= Width) or (Width <= 6) then
begin
Result := APath;
Exit
end
else
begin
i := SLen;
TString := APath;
for j := 1 to 2 do
begin
while (TString <> '/') and (SLen - i < Width - 8) do
i := i - 1;
i := i - 1;
end;
for j := SLen - i - 1 downto 0 do
TString[Width - j] := TString[SLen - j];
for j := SLen - i to SLen - i + 2 do
TString[Width - j] := '.';
Delete(TString, Width + 1, 255);
Result := TString;
end;
end;
//打开文件框
function OpenDialog(var FileName: string; Title: string; Filter: string;
Ext: string): Boolean;
var
OpenName: TOPENFILENAME;
TempFilename, ReturnFile: string;
begin
with OpenName do
begin
lStructSize := SizeOf(OpenName);
hWndOwner := GetModuleHandle('');
Hinstance := SysInit.Hinstance;
lpstrFilter := PChar(Filter + #0 + Ext + #0#0);
lpstrCustomFilter := '';
nMaxCustFilter := 0;
nFilterIndex := 1;
nMaxFile := MAX_PATH;
SetLength(TempFilename, nMaxFile + 2);
lpstrFile := PChar(TempFilename);
FillChar(lpstrFile^, MAX_PATH, 0);
SetLength(TempFilename, nMaxFile + 2);
nMaxFileTitle := MAX_PATH;
SetLength(ReturnFile, MAX_PATH + 2);
lpstrFileTitle := PChar(ReturnFile);
FillChar(lpstrFile^, MAX_PATH, 0);
lpstrInitialDir := '.';
lpstrTitle := PChar(Title);
Flags := OFN_HIDEREADONLY + OFN_ENABLESIZING;
nFileOffset := 0;
nFileExtension := 0;
lpstrDefExt := PChar(Ext);
lCustData := 0;
lpfnHook := nil;
lpTemplateName := '';
end;
Result := GetOpenFileName(OpenName);
if Result then
FileName := ReturnFile
else
FileName := '';
end;
// 取两个目录的相对路径,注意串尾不能是'/'字符!
function GetRelativePath(Source, Dest: string): string;
//比较两路径字符串头部相同串的函数
function GetPathComp(s1, s2: string): Integer;
begin
if Length(s1) > Length(s2) then swapStr(s1, s2);
Result := Pos(s1, s2);
while (Result = 0) and (Length(s1) > 3) do
begin
if s1 = '' then Exit;
s1 := ExtractFileDir(s1);
Result := Pos(s1, s2);
end;
if Result <> 0 then Result := Length(s1);
if Result = 3 then Result := 2;
//修正因ExtractFileDir()处理'c:/'时产生的错误.
end;
//取Dest的相对根路径的函数
function GetRoot(s: ShortString): string;
var
i: Integer;
begin
Result := '';
for i := 1 to Length(s) do
if s = '/' then Result := Result + '../';
if Result = '' then Result := './';
//如果不想处理成"./"的路径格式,可去掉本行
end;
var
RelativRoot, RelativSub: string;
HeadNum: Integer;
begin
Source := UpperCase(Source);
Dest := UpperCase(Dest); //比较两路径字符串头部相同串
HeadNum := GetPathComp(Source, Dest); //取Dest的相对根路径
RelativRoot := GetRoot(StrRight(Dest, Length(Dest) - HeadNum));
//取Source的相对子路径
RelativSub := StrRight(Source, Length(Source) - HeadNum - 1);
//返回
Result := RelativRoot + RelativSub;
end;
//运行一个文件
procedure RunFile(const FName: string; Handle: THandle;
const Param: string);
begin
ShellExecute(Handle, nil, PChar(FName), PChar(Param), nil, SW_SHOWNORMAL);
end;
//运行一个文件并等待其结束
function WinExecAndWait32(FileName: string; Visibility: Integer): Integer;
var
zAppName: array[0..512] of Char;
zCurDir: array[0..255] of Char;
WorkDir: string;
StartupInfo: TStartupInfo;
ProcessInfo: TProcessInformation;
begin
StrPCopy(zAppName, FileName);
GetDir(0, WorkDir);
StrPCopy(zCurDir, WorkDir);
FillChar(StartupInfo, SizeOf(StartupInfo), #0);
StartupInfo.cb := SizeOf(StartupInfo);
StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
StartupInfo.wShowWindow := Visibility;
if not CreateProcess(nil,
zAppName, { pointer to command line string }
nil, { pointer to process security attributes }
nil, { pointer to thread security attributes }
False, { handle inheritance flag }
CREATE_NEW_CONSOLE or { creation flags }
NORMAL_PRIORITY_CLASS,
nil, { pointer to new environment block }
nil, { pointer to current directory name }
StartupInfo, { pointer to STARTUPINFO }
ProcessInfo) then
Result := -1 { pointer to PROCESS_INF }
else
begin
WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
GetExitCodeProcess(ProcessInfo.hProcess, Cardinal(Result));
end;
end;
//应用程序路径
function AppPath: string;
begin
Result := ExtractFilePath(Application.ExeName);
end;
//取Windows系统目录
function GetWindowsDir: string;
var
Buf: array[0..MAX_PATH] of Char;
begin
GetWindowsDirectory(Buf, MAX_PATH);
Result := AddDirSuffix(Buf);
end;
//取临时文件目录
function GetWinTempDir: string;
var
Buf: array[0..MAX_PATH] of Char;
begin
GetTempPath(MAX_PATH, Buf);
Result := AddDirSuffix(Buf);
end;
//目录尾加'/'修正
function AddDirSuffix(Dir: string): string;
begin
Result := Trim(Dir);
if Result = '' then Exit;
if Result[Length(Result)] <> '/' then Result := Result + '/';
end;
function MakePath(Dir: string): string;
begin
Result := AddDirSuffix(Dir);
end;
//判断文件是否正在使用
function IsFileInUse(FName: string): Boolean;
var
HFileRes: HFILE;
begin
Result := False;
if not FileExists(FName) then
Exit;
HFileRes := CreateFile(PChar(FName), GENERIC_READ or GENERIC_WRITE, 0,
nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
Result := (HFileRes = INVALID_HANDLE_VALUE);
if not Result then
CloseHandle(HFileRes);
end;
//取文件长度
function GetFileSize(FileName: string): Integer;
var
FileVar: file of Byte;
begin
{$I-}
try
AssignFile(FileVar, FileName);
Reset(FileVar);
Result := FileSize(FileVar);
CloseFile(FileVar);
except
Result := 0;
end;
{$I+}
end;
//设置文件时间
function SetFileDate(FileName: string; CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
var
FileHandle: Integer;
begin
FileHandle := FileOpen(FileName, fmOpenWrite or fmShareDenyNone);
if FileHandle > 0 then
begin
SetFileTime(FileHandle, @@CreationTime, @@LastAccessTime, @@LastWriteTime);
FileClose(FileHandle);
Result := True;
end
else
Result := False;
end;
//取文件时间
function GetFileDate(FileName: string; var CreationTime, LastWriteTime, LastAccessTime:
TFileTime): Boolean;
var
FileHandle: Integer;
begin
FileHandle := FileOpen(FileName, fmOpenRead or fmShareDenyNone);
if FileHandle > 0 then
begin
GetFileTime(FileHandle, @@CreationTime, @@LastAccessTime, @@LastWriteTime);
FileClose(FileHandle);
Result := True;
end
else
Result := False;
end;
//取得与文件相关的图标
//FileName: e.g. "e:/hao/a.txt"
//成功则返回True
function GetFileIcon(FileName: string; var Icon: TIcon): Boolean;
var
SHFileInfo: TSHFileInfo;
h: HWND;
begin
if not Assigned(Icon) then
Icon := TIcon.Create;
h := SHGetFileInfo(PChar(FileName),
0,
SHFileInfo,
SizeOf(SHFileInfo),
SHGFI_ICON or SHGFI_SYSICONINDEX);
Icon.Handle := SHFileInfo.hIcon;
Result := (h <> 0);
end;
//文件时间转本地时间
function FileTimeToLocalSystemTime(FTime: TFileTime): TSystemTime;
var
STime: TSystemTime;
begin
FileTimeToLocalFileTime(FTime, FTime);
FileTimeToSystemTime(FTime, STime);
Result := STime;
end;
//本地时间转文件时间
function LocalSystemTimeToFileTime(STime: TSystemTime): TFileTime;
var
FTime: TFileTime;
begin
SystemTimeToFileTime(STime, FTime);
LocalFileTimeToFileTime(FTime, FTime);
Result := FTime;
end;
//创建备份文件
function CreateBakFile(FileName, Ext: string): Boolean;
var
BakFileName: string;
begin
BakFileName := FileName + '.' + Ext;
Result := CopyFile(PChar(FileName), PChar(BakFileName), False);
end;
//删除整个目录
function Deltree(Dir: string): Boolean;
var
sr: TSearchRec;
fr: Integer;
begin
if not DirectoryExists(Dir) then
begin
Result := True;
Exit;
end;
fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);
try
while fr = 0 do
begin
if (sr.Name <> '.') and (sr.Name <> '..') then
begin
if sr.Attr and faDirectory = faDirectory then
Result := Deltree(AddDirSuffix(Dir) + sr.Name)
else
Result := DeleteFile(AddDirSuffix(Dir) + sr.Name);
if not Result then
Exit;
end;
fr := FindNext(sr);
end;
finally
FindClose(sr);
end;
Result := RemoveDir(Dir);
end;
//取文件夹文件数
function GetDirFiles(Dir: string): Integer;
var
sr: TSearchRec;
fr: Integer;
begin
Result := 0;
fr := FindFirst(AddDirSuffix(Dir) + '*.*', faAnyFile, sr);
while fr = 0 do
begin
if (sr.Name <> '.') and (sr.Name <> '..') then
Inc(Result);
fr := FindNext(sr);
end;
FindClose(sr);
end;
var
FindAbort: Boolean;
//查找指定目录下文件
procedure FindFile(const Path: string; const FileName: string = '*.*';
Proc: TFindCallBack = nil; bSub: Boolean = True; const bMsg: Boolean = True);
var
APath: string;
Info: TSearchRec;
Succ: Integer;
begin
FindAbort := False;
APath := MakePath(Path);
try
Succ := FindFirst(APath + FileName, faAnyFile - faVolumeID, Info);
while Succ = 0 do
begin
if (Info.Name <> '.') and (Info.Name <> '..') then
begin
if (Info.Attr and faDirectory) <> faDirectory then
begin
if Assigned(Proc) then
Proc(APath + Info.FindData.cFileName, Info, FindAbort);
end
else if bSub then
FindFile(APath + Info.Name, FileName, Proc, bSub, bMsg);
end;
if bMsg then Application.ProcessMessages;
if FindAbort then Exit;
Succ := FindNext(Info);
end;
finally
FindClose(Info);
end;
end;
//文件打开方式
function OpenWith(const FileName: string): Integer;
begin
Result := ShellExecute(Application.Handle, 'open', 'rundll32.exe',
PChar('shell32.dll,OpenAs_RunDLL ' + FileName), '', SW_SHOW);
end;
//----------------------------------------------------------------------------//
//扩展的字符串操作函数 //
//----------------------------------------------------------------------------//
//判断s1是否包含在s2中
function InStr(const sShort: string; const sLong: string): Boolean;
var
s1, s2: string;
begin
s1 := LowerCase(sShort);
s2 := LowerCase(sLong);
Result := Pos(s1, s2) > 0;
end;
//扩展整数转字符串函数,参数分别为目标数、长度、填充字符(默认为0)
function IntToStrEx(Value: Integer; Len: Integer; FillChar: Char = '0'): string;
begin
Result := IntToStr(Value);
while Length(Result) < Len do
Result := FillChar + Result;
end;
//带分隔符的整数-字符转换
function IntToStrSp(Value: Integer; SpLen: Integer = 3; Sp: Char = ','): string;
var
s: string;
i, j: Integer;
begin
s := IntToStr(Value);
Result := '';
j := 0;
for i := Length(s) downto 1 do
begin
Result := s + Result;
Inc(j);
if ((j mod SpLen) = 0) and (i <> 1) then Result := Sp + Result;
end;
end;
//返回字符串右边的字符
function StrRight(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, Length(Str) - Len + 1, Len);
end;
//返回字符串左边的字符
function StrLeft(Str: string; Len: Integer): string;
begin
if Len >= Length(Str) then
Result := Str
else
Result := Copy(Str, 1, Len);
end;
//字节转二进制串
function ByteToBin(Value: Byte): string;
const
V: Byte = 1;
var
i: Integer;
begin
for i := 7 downto 0 do
if (V shl i) and Value <> 0 then
Result := Result + '1'
else
Result := Result + '0';
end;
//返回空格串
function Spc(Len: Integer): string;
var
i: Integer;
begin
Result := '';
for i := 0 to Len - 1 do
Result := Result + ' ';
end;
//交换字串
procedure SwapStr(var s1, s2: string);
var
tempstr: string;
begin
tempstr := s1;
s1 := s2;
s2 := tempstr;
end;
const
csLinesCR = #13#10;
csStrCR = '/n';
//多行文本转单行(换行符转'/n')
function LinesToStr(const Lines: string): string;
var
i: Integer;
begin
Result := Lines;
i := Pos(csLinesCR, Result);
while i > 0 do
begin
system.Delete(Result, i, Length(csLinesCR));
system.insert(csStrCR, Result, i);
i := Pos(csLinesCR, Result);
end;
end;
//单行文本转多行('/n'转换行符)
function StrToLines(const Str: string): string;
var
i: Integer;
begin
Result := Str;
i := Pos(csStrCR, Result);
while i > 0 do
begin
system.Delete(Result, i, Length(csStrCR));
system.insert(csLinesCR, Result, i);
i := Pos(csStrCR, Result);
end;
end;
//----------------------------------------------------------------------------//
//扩展的对话框函数 //
//----------------------------------------------------------------------------//
//显示提示窗口
procedure InfoDlg(Mess: string; Caption: string; Flags: Integer);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), Flags);
end;
//显示提示确认窗口
function InfoOk(Mess: string; Caption: string): Boolean;
begin
Result := Application.MessageBox(PChar(Mess), PChar(Caption),
MB_OKCANCEL + MB_ICONINFORMATION) = IDOK;
end;
//显示错误窗口
procedure ErrorDlg(Mess: string; Caption: string);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONSTOP);
end;
//显示警告窗口
procedure WarningDlg(Mess: string; Caption: string);
begin
Application.MessageBox(PChar(Mess), PChar(Caption), MB_OK + MB_ICONWARNING);
end;
//显示查询是否窗口
function QueryDlg(Mess: string; Caption: string): Boolean;
begin
Result := Application.MessageBox(PChar(Mess), PChar(Caption),
MB_YESNO + MB_ICONQUESTION) = IDYES;
end;
//----------------------------------------------------------------------------//
//位扩展日期时间操作函数 //
//----------------------------------------------------------------------------//
function GetYear(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := y;
end;
function GetMonth(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := m;
end;
function GetDay(Date: TDate): Integer;
var
y, m, d: WORD;
begin
DecodeDate(Date, y, m, d);
Result := d;
end;
function GetHour(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := h;
end;
function GetMinute(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := m;
end;
function GetSecond(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := s;
end;
function GetMSecond(Time: TTime): Integer;
var
h, m, s, ms: WORD;
begin
DecodeTime(Time, h, m, s, ms);
Result := ms;
end;
//----------------------------------------------------------------------------//
//位操作函数 //
//----------------------------------------------------------------------------//
//设置位
procedure SetBit(var Value: Byte; Bit: TByteBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
procedure SetBit(var Value: WORD; Bit: TWordBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
procedure SetBit(var Value: DWORD; Bit: TDWordBit; IsSet: Boolean);
begin
if IsSet then
Value := Value or (1 shl Bit)
else
Value := Value and not (1 shl Bit);
end;
//取位
function GetBit(Value: Byte; Bit: TByteBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
function GetBit(Value: WORD; Bit: TWordBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
function GetBit(Value: DWORD; Bit: TDWordBit): Boolean;
begin
Result := Value and (1 shl Bit) <> 0;
end;
//----------------------------------------------------------------------------//
//系统功能函数 //
//----------------------------------------------------------------------------//
//移动鼠标到控件
procedure MoveMouseIntoControl(AWinControl: TControl);
var
rtControl: TRect;
begin
rtControl := AWinControl.BoundsRect;
MapWindowPoints(AWinControl.Parent.Handle, 0, rtControl, 2);
SetCursorPos(rtControl.Left + (rtControl.Right - rtControl.Left) div 2,
rtControl.Top + (rtControl.Bottom - rtControl.Top) div 2);
end;
//动态设置分辨率
function DynamicResolution(x, y: WORD): Boolean;
var
lpDevMode: TDeviceMode;
begin
Result := EnumDisplaySettings(nil, 0, lpDevMode);
if Result then
begin
lpDevMode.dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
lpDevMode.dmPelsWidth := x;
lpDevMode.dmPelsHeight := y;
Result := ChangeDisplaySettings(lpDevMode, 0) = DISP_CHANGE_SUCCESSFUL;
end;
end;
//窗口最上方显示
procedure StayOnTop(Handle: HWND; OnTop: Boolean);
const
csOnTop: array[Boolean] of HWND = (HWND_NOTOPMOST, HWND_TOPMOST);
begin
SetWindowPos(Handle, csOnTop[OnTop], 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
end;
var
WndLong: Integer;
//设置程序是否出现在任务栏
procedure SetHidden(Hide: Boolean);
begin
ShowWindow(Application.Handle, SW_HIDE);
if Hide then
SetWindowLong(Application.Handle, GWL_EXSTYLE,
WndLong or WS_EX_TOOLWINDOW and not WS_EX_APPWINDOW or WS_EX_TOPMOST)
else
SetWindowLong(Application.Handle, GWL_EXSTYLE, WndLong);
ShowWindow(Application.Handle, SW_SHOW);
end;
const
csWndShowFlag: array[Boolean] of DWORD = (SW_HIDE, SW_RESTORE);
//设置任务栏是否可见
procedure SetTaskBarVisible(Visible: Boolean);
var
wndHandle: THandle;
begin
wndHandle := FindWindow('Shell_TrayWnd', nil);
ShowWindow(wndHandle, csWndShowFlag[Visible]);
end;
//设置桌面是否可见
procedure SetDesktopVisible(Visible: Boolean);
var
hDesktop: THandle;
begin
hDesktop := FindWindow('Progman', nil);
ShowWindow(hDesktop, csWndShowFlag[Visible]);
end;
//显示等待光标
procedure BeginWait;
begin
Screen.Cursor := crHourGlass;
end;
//结束等待光标
procedure EndWait;
begin
Screen.Cursor := crDefault;
end;
//检测是否Win95/98平台
function CheckWindows9598: Boolean;
var
V: TOSVersionInfo;
begin
V.dwOSVersionInfoSize := SizeOf(V);
Result := False;
if not GetVersionEx(V) then Exit;
if V.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS then
Result := True;
end;
// 输出限制在Min..Max之间
function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value < Min then
Result := Min
else
Result := Value;
end;
// 输出限制在0..255之间
function IntToByte(Value: Integer): Byte; overload;
asm
OR EAX, EAX
JNS @@@@Positive
XOR EAX, EAX
RET
@@@@Positive:
CMP EAX, 255
JBE @@@@OK
MOV EAX, 255
@@@@OK:
end;
// 由TRect分离出坐标、宽高
procedure DeRect(Rect: TRect; var x, y, Width, Height: Integer);
begin
x := Rect.Left;
y := Rect.Top;
Width := Rect.Right - Rect.Left;
Height := Rect.Bottom - Rect.Top;
end;
// 比较两个Rect
function RectEqu(Rect1, Rect2: TRect): Boolean;
begin
Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and
(Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;
// 产生TSize类型
function EnSize(cx, cy: Integer): TSize;
begin
Result.cx := cx;
Result.cy := cy;
end;
// 计算Rect的宽度
function RectWidth(Rect: TRect): Integer;
begin
Result := Rect.Right - Rect.Left;
end;
// 计算Rect的高度
function RectHeight(Rect: TRect): Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
// 判断范围
function InBound(Value: Integer; Min, Max: Integer): Boolean;
begin
Result := (Value >= Min) and (Value <= Max);
end;
// 交换两个数
procedure CnSwap(var A, B: Byte); overload;
var
Tmp: Byte;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Integer); overload;
var
Tmp: Integer;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Single); overload;
var
Tmp: Single;
begin
Tmp := A;
A := B;
B := Tmp;
end;
procedure CnSwap(var A, B: Double); overload;
var
Tmp: Double;
begin
Tmp := A;
A := B;
B := Tmp;
end;
//延时
procedure Delay(const uDelay: DWORD);
var
n: DWORD;
begin
n := GetTickCount;
while ((GetTickCount - n) <= uDelay) do
Application.ProcessMessages;
end;
//在Win9X下让喇叭发声
procedure BeepEx(const Freq: WORD = 1200; const Delay: WORD = 1);
const
FREQ_SCALE = $1193180;
var
Temp: WORD;
begin
Temp := FREQ_SCALE div Freq;
asm
in al,61h;
or al,3;
out 61h,al;
mov al,$b6;
out 43h,al;
mov ax,temp;
out 42h,al;
mov al,ah;
out 42h,al;
end;
Sleep(Delay);
asm
in al,$61;
and al,$fc;
out $61,al;
end;
end;
//显示Win32 Api运行结果信息
procedure ShowLastError;
var
ErrNo: Integer;
Buf: array[0..255] of Char;
begin
ErrNo := GetLastError;
FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil, ErrNo, $400, Buf, 255, nil);
if Buf = '' then StrCopy(@@Buf, PChar(SUnknowError));
MessageBox(Application.Handle, PChar(string(Buf) + #10#13 +
SErrorCode + IntToStr(ErrNo)),
SCnInformation, MB_OK + MB_ICONINFORMATION);
end;
//取汉字的拼音
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
i := 1;
while i <= Length(AHzStr) do
begin
if (AHzStr >= #160) and (AHzStr[i + 1] >= #160) then
begin
HzOrd := (Ord(AHzStr) - 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;
Inc(i);
end;
end;
//声卡是否存在
function SoundCardExist: Boolean;
begin
Result := WaveOutGetNumDevs > 0;
end;
initialization
WndLong := GetWindowLong(Application.Handle, GWL_EXSTYLE);
end.