Delphi常用的函数库

Delphi常用的函数库，引用作者的话“今天在整理以前写过的代码，发现有些函数还是挺实用的，决定将其贴到Blog上，与众多好友一起分享。”

源文地址：http://blog.csdn.net/chris_mao/archive/2007/11/01/1862017.aspx

{*******************************************************************************

* 模块名称: 公用函数库

* 编写人员: Chris Mao

* 编写日期: 2004.10.30

******************************************************************************}

unit JrCommon;

interface

uses

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

ShellAPI, CommDlg, MMSystem, StdCtrls, Registry, JrConsts, Winsock;

//------------------------------------------------------------------------------

//窗体类函数

//------------------------------------------------------------------------------

function FindFormClass(FormClassName: PChar): TFormClass;

function HasInstance(FormClassName: PChar): Boolean;

//------------------------------------------------------------------------------

//公用对话框函数

//------------------------------------------------------------------------------

procedure InfoDlg(const Msg: String; ACaption: String = SInformation);

{ 信息对话框 }

procedure ErrorDlg(const Msg: String; ACaption: String = SError);

{ 错误对话框 }

procedure WarningDlg(const Msg: String; ACaption: String = SWarning);

{ 警告对话框 }

function QueryDlg(const Msg: String; ACaption: String = SQuery): Boolean;

{ 确认对话框 }

function QueryNoDlg(const Msg: string; ACaption: string = SQuery): Boolean;

{ 确认对话框，默认按钮为"否" }

function JrInputQuery(const ACaption, APrompt: String; var Value: string): Boolean;

{ 输入对话框 }

function JrInputBox(const ACaption, APrompt, ADefault: string): String;

{ 输入对话框 }

//------------------------------------------------------------------------------

//扩展文件目录操作函数

//------------------------------------------------------------------------------

procedure RunFile(const FileName: String; Handle: THandle = 0; Param: string = '');

{ 运行一个文件 }

function AppPath: string;

{ 应用程序路径 }

function GetProgramFilesDir: string;

{ 取Program Files目录 }

function GetWindowsDir: string;

{ 取Windows目录}

function GetWindowsTempPath: string;

{ 取临时文件路径 }

function GetSystemDir: string;

{ 取系统目录 }

//------------------------------------------------------------------------------

//扩展字符串操作函数

//------------------------------------------------------------------------------

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

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

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 GetYear(Date: TDate): Word;

{ 取日期年份分量 }

function GetMonth(Date: TDate): Word;

{ 取日期月份分量 }

function GetDay(Date: TDate): Word;

{ 取日期天数分量 }

function GetHour(Time: TTime): Word;

{ 取时间小时分量 }

function GetMinute(Time: TTime): Word;

{ 取时间分钟分量 }

function GetSecond(Time: TTime): Word;

{ 取时间秒分量 }

function GetMSecond(Time: TTime): Word;

{ 取时间毫秒分量 }

//------------------------------------------------------------------------------

// 位操作函数

//------------------------------------------------------------------------------

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 ChangeFocus(Handle: THandle; Forword: Boolean = False);

{ 改变焦点 }

procedure MoveMouseIntoControl(AWinControl: TControl);

{ 移动鼠标到控件 }

procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10);

{ 将 ComboBox 的文本内容增加到下拉列表中 }

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

{ 动态设置分辨率 }

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

{ 窗口最上方显示 }

procedure SetHidden(Hide: Boolean);

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

procedure SetTaskBarVisible(Visible: Boolean);

{ 设置任务栏是否可见 }

procedure SetDesktopVisible(Visible: Boolean);

{ 设置桌面是否可见 }

function GetWorkRect: TRect;

{ 取桌面区域 }

procedure BeginWait;

{ 显示等待光标 }

procedure EndWait;

{ 结束等待光标 }

function CheckWindows9598: Boolean;

{ 检测是否Win95/98平台 }

function GetOSString: string;

{ 返回操作系统标识串 }

function GetComputeNameStr : string;

{ 得到本机名 }

function GetLocalUserName: string;

{ 得到本机用户名 }

function GetLocalIP: String;

{ 得到本机IP地址 }

//------------------------------------------------------------------------------

// 其它过程

//------------------------------------------------------------------------------

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

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

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

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

procedure Delay(const uDelay: DWORD);

{ 延时 }

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

{ 在Win9X下让喇叭发声 }

function GetHzPy(const AHzStr: string): string;

{ 取汉字的拼音 }

function UpperCaseMoney(const Money: Double): String;

{ 转换为大与金额 }

function SoundCardExist: Boolean;

{ 声卡是否存在 }

implementation

//------------------------------------------------------------------------------

//窗体类函数

//------------------------------------------------------------------------------

function FindFormClass(FormClassName: PChar): TFormClass;

begin

Result := TFormClass(GetClass(FormClassName));

end;

function HasInstance(FormClassName: PChar): Boolean;

var

i: integer;

begin

Result:=False;

for i := Screen.FormCount - 1 downto 0 do begin

Result := SameText(Screen.Forms[i].ClassName, FormClassName);

if Result then begin

TForm(Screen.Forms[i]).BringToFront;

Break;

end;

end;

end;

//------------------------------------------------------------------------------

//公用对话框函数

//------------------------------------------------------------------------------

procedure InfoDlg(const Msg: String; ACaption: String = SInformation);

begin

Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONINFORMATION);

end;

procedure ErrorDlg(const Msg: String; ACaption: String = SError);

begin

Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONERROR);

end;

procedure WarningDlg(const Msg: String; ACaption: String = SWarning);

begin

Application.MessageBox(PChar(Msg), PChar(ACaption), MB_OK + MB_ICONWARNING);

end;

function QueryDlg(const Msg: String; ACaption: String = SQuery): Boolean;

begin

Result := Application.MessageBox(PChar(Msg), PChar(ACaption),

MB_YESNO + MB_ICONQUESTION) = IDYES;

end;

function QueryNoDlg(const Msg: string; ACaption: string = SQuery): Boolean;

begin

Result := Application.MessageBox(PChar(Msg), PChar(ACaption),

MB_YESNO + MB_ICONQUESTION + MB_DEFBUTTON2) = IDYES;

end;

function GetAveCharSize(Canvas: TCanvas): TPoint;

var

I: Integer;

Buffer: array[0..51] of Char;

begin

for I := 0 to 25 do Buffer[I] := Chr(I + Ord('A'));

for I := 0 to 25 do Buffer[I + 26] := Chr(I + Ord('a'));

GetTextExtentPoint(Canvas.Handle, Buffer, 52, TSize(Result));

Result.X := Result.X div 52;

end;

function JrInputQuery(const ACaption, APrompt: String; var Value: string): Boolean;

var

Form: TForm;

Prompt: TLabel;

Edit: TEdit;

DialogUnits: TPoint;

ButtonTop, ButtonWidth, ButtonHeight: Integer;

begin

Result := False;

Form := TForm.Create(Application);

with Form do

try

Scaled := False;

Font.Name := SDefaultFontName;

Font.Size := SDefaultFontSize;

Font.Charset := SDefaultFontCharset;

Canvas.Font := Font;

DialogUnits := GetAveCharSize(Canvas);

BorderStyle := bsDialog;

Caption := ACaption;

ClientWidth := MulDiv(180, DialogUnits.X, 4);

ClientHeight := MulDiv(63, DialogUnits.Y, 8);

Position := poScreenCenter;

Prompt := TLabel.Create(Form);

with Prompt do

begin

Parent := Form;

AutoSize := True;

Left := MulDiv(8, DialogUnits.X, 4);

Top := MulDiv(8, DialogUnits.Y, 8);

Caption := APrompt;

end;

Edit := TEdit.Create(Form);

with Edit do

begin

Parent := Form;

Left := Prompt.Left;

Top := MulDiv(19, DialogUnits.Y, 8);

Width := MulDiv(164, DialogUnits.X, 4);

MaxLength := 255;

Text := Value;

SelectAll;

end;

ButtonTop := MulDiv(41, DialogUnits.Y, 8);

ButtonWidth := MulDiv(50, DialogUnits.X, 4);

ButtonHeight := MulDiv(14, DialogUnits.Y, 8);

with TButton.Create(Form) do

begin

Parent := Form;

Caption := SMsgDlgOK;

ModalResult := mrOk;

Default := True;

SetBounds(MulDiv(38, DialogUnits.X, 4), ButtonTop, ButtonWidth,

ButtonHeight);

end;

with TButton.Create(Form) do

begin

Parent := Form;

Caption := SMsgDlgCancel;

ModalResult := mrCancel;

Cancel := True;

SetBounds(MulDiv(92, DialogUnits.X, 4), ButtonTop, ButtonWidth,

ButtonHeight);

end;

if ShowModal = mrOk then

begin

Value := Edit.Text;

Result := True;

end;

finally

Form.Free;

end;

end;

function JrInputBox(const ACaption, APrompt, ADefault: string): String;

begin

Result := ADefault;

JrInputQuery(ACaption, APrompt, Result);

end;

//------------------------------------------------------------------------------

//扩展文件目录操作函数

//------------------------------------------------------------------------------

procedure RunFile(const FileName: String; Handle: THandle = 0; Param: string = '');

begin

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

end;

function AppPath: string;

begin

Result := ExtractFilePath(Application.ExeName);

end;

const

HKLM_CURRENT_VERSION_WINDOWS = 'SoftwareMicrosoftWindowsCurrentVersion';

function RelativeKey(const Key: string): PChar;

begin

Result := PChar(Key);

if (Key <> '') and (Key[1] = '') then

Inc(Result);

end;

function RegReadStringDef(const RootKey: HKEY; const Key, Name, Def: string): string;

var

RegKey: HKEY;

Size: DWORD;

StrVal: string;

RegKind: DWORD;

begin

Result := Def;

if RegOpenKeyEx(RootKey, RelativeKey(Key), 0, KEY_READ, RegKey) = ERROR_SUCCESS then

begin

RegKind := 0;

Size := 0;

if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, nil, @Size) = ERROR_SUCCESS then

if RegKind in [REG_SZ, REG_EXPAND_SZ] then

begin

SetLength(StrVal, Size);

if RegQueryValueEx(RegKey, PChar(Name), nil, @RegKind, PByte(StrVal), @Size) = ERROR_SUCCESS then

begin

SetLength(StrVal, StrLen(PChar(StrVal)));

Result := StrVal;

end;

end;

RegCloseKey(RegKey);

end;

end;

procedure StrResetLength(var S: AnsiString);

begin

SetLength(S, StrLen(PChar(S)));

end;

function GetProgramFilesDir: string;

begin

Result := RegReadStringDef(HKEY_LOCAL_MACHINE, HKLM_CURRENT_VERSION_WINDOWS, 'ProgramFilesDir', '');

end;

function GetWindowsDir: string;

var

Required: Cardinal;

begin

Result := '';

Required := GetWindowsDirectory(nil, 0);

if Required <> 0 then

begin

SetLength(Result, Required);

GetWindowsDirectory(PChar(Result), Required);

StrResetLength(Result);

end;

end;

function GetWindowsTempPath: string;

var

Required: Cardinal;

begin

Result := '';

Required := GetTempPath(0, nil);

if Required <> 0 then

begin

SetLength(Result, Required);

GetTempPath(Required, PChar(Result));

StrResetLength(Result);

end;

end;

function GetSystemDir: string;

var

Required: Cardinal;

begin

Result := '';

Required := GetSystemDirectory(nil, 0);

if Required <> 0 then

begin

SetLength(Result, Required);

GetSystemDirectory(PChar(Result), Required);

StrResetLength(Result);

end;

end;

//------------------------------------------------------------------------------

//扩展字符串操作函数

//------------------------------------------------------------------------------

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

var

s1, s2: string;

begin

s1 := LowerCase(sShort);

s2 := LowerCase(sLong);

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

end;

function 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);

if ((j mod SpLen) = 0) and (i <> 1) then Result := Sp + Result;

end;

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 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 Spc(Len: Integer): string;

begin

SetLength(Result, Len);

FillChar(PChar(Result)^, Len, ' ');

end;

procedure SwapStr(var s1, s2: string);

var

tempstr: string;

begin

tempstr := s1;

s1 := s2;

s2 := tempstr;

end;

//------------------------------------------------------------------------------

// 扩展日期时间操作函数

//------------------------------------------------------------------------------

function GetYear(Date: TDate): Word;

var

m, d: WORD;

begin

DecodeDate(Date, Result, m, d);

end;

function GetMonth(Date: TDate): Word;

var

y, d: WORD;

begin

DecodeDate(Date, y, Result, d);

end;

function GetDay(Date: TDate): Word;

var

y, m: WORD;

begin

DecodeDate(Date, y, m, Result);

end;

function GetHour(Time: TTime): Word;

var

h, m, s, ms: WORD;

begin

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

end;

function GetMinute(Time: TTime): Word;

var

h, s, ms: WORD;

begin

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

end;

function GetSecond(Time: TTime): Word;

var

h, m, ms: WORD;

begin

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

end;

function GetMSecond(Time: TTime): Word;

var

h, m, s: WORD;

begin

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

end;

//------------------------------------------------------------------------------

// 位操作函数

//------------------------------------------------------------------------------

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

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); overload;

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); overload;

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; overload;

begin

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

end;

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

begin

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

end;

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

begin

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

end;

//------------------------------------------------------------------------------

// 系统功能函数

//------------------------------------------------------------------------------

procedure ChangeFocus(Handle: THandle; Forword: Boolean = False);

begin

if ForWord then

PostMessage(Handle, WM_NEXTDLGCTL, 1, 0)

else

PostMessage(Handle, WM_NEXTDLGCTL, 0, 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;

procedure AddComboBoxTextToItems(ComboBox: TComboBox; MaxItemsCount: Integer = 10);

begin

if (ComboBox.Text <> '') and (ComboBox.Items.IndexOf(ComboBox.Text) < 0) then

begin

ComboBox.Items.Insert(0, ComboBox.Text);

while (MaxItemsCount > 1) and (ComboBox.Items.Count > MaxItemsCount) do

ComboBox.Items.Delete(ComboBox.Items.Count - 1);

end;

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;

function GetWorkRect: TRect;

begin

SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0)

end;

procedure BeginWait;

begin

Screen.Cursor := crHourGlass;

end;

procedure EndWait;

begin

Screen.Cursor := crDefault;

end;

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;

function GetOSString: string;

var

OSPlatform: string;

BuildNumber: Integer;

begin

Result := 'Unknown Windows Version';

OSPlatform := 'Windows';

BuildNumber := 0;

case Win32Platform of

VER_PLATFORM_WIN32_WINDOWS:

begin

BuildNumber := Win32BuildNumber and $0000FFFF;

case Win32MinorVersion of

0..9:

begin

if Trim(Win32CSDVersion) = 'B' then

OSPlatform := 'Windows 95 OSR2'

else

OSPlatform := 'Windows 95';

end;

10..89:

begin

if Trim(Win32CSDVersion) = 'A' then

OSPlatform := 'Windows 98'

else

OSPlatform := 'Windows 98 SE';

end;

90:

OSPlatform := 'Windows Millennium';

end;

end;

VER_PLATFORM_WIN32_NT:

begin

if Win32MajorVersion in [3, 4] then

OSPlatform := 'Windows NT'

else if Win32MajorVersion = 5 then

begin

case Win32MinorVersion of

0: OSPlatform := 'Windows 2000';

1: OSPlatform := 'Windows XP';

end;

end;

BuildNumber := Win32BuildNumber;

end;

VER_PLATFORM_WIN32s:

begin

OSPlatform := 'Win32s';

BuildNumber := Win32BuildNumber;

end;

end;

if (Win32Platform = VER_PLATFORM_WIN32_WINDOWS) or

(Win32Platform = VER_PLATFORM_WIN32_NT) then

begin

if Trim(Win32CSDVersion) = '' then

Result := Format('%s %d.%d (Build %d)', [OSPlatform, Win32MajorVersion,

Win32MinorVersion, BuildNumber])

else

Result := Format('%s %d.%d (Build %d: %s)', [OSPlatform, Win32MajorVersion,

Win32MinorVersion, BuildNumber, Win32CSDVersion]);

end

else

Result := Format('%s %d.%d', [OSPlatform, Win32MajorVersion, Win32MinorVersion])

end;

function GetComputeNameStr : string;

var

dwBuff : DWORD;

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

begin

Result := '';

dwBuff := 256;

FillChar(CmpName, SizeOf(CmpName), 0);

if GetComputerName(CmpName, dwBuff) then

Result := StrPas(CmpName);

end;

function GetLocalUserName: string;

var

Count: DWORD;

begin

Count := 256 + 1; // UNLEN + 1

// set buffer size to 256 + 2 characters

SetLength(Result, Count);

if GetUserName(PChar(Result), Count) then

StrResetLength(Result)

else

Result := '';

end;

function GetLocalIP: String;

type

TaPInAddr = array [0..10] of PInAddr;

PaPInAddr = ^TaPInAddr;

var

phe : PHostEnt;

pptr : PaPInAddr;

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

I : Integer;

GInitData : TWSADATA;

begin

WSAStartup($101, GInitData);

Result := '';

GetHostName(Buffer, SizeOf(Buffer));

phe :=GetHostByName(buffer);

if phe = nil then Exit;

pptr := PaPInAddr(Phe^.h_addr_list);

I := 0;

while pptr^[I] <> nil do begin

result:=StrPas(inet_ntoa(pptr^[I]^));

Inc(I);

end;

WSACleanup;

end;

//------------------------------------------------------------------------------

// 其它过程

//------------------------------------------------------------------------------

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;

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

begin

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

end;

procedure Delay(const uDelay: DWORD);

var

n: DWORD;

begin

n := GetTickCount;

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

Application.ProcessMessages;

end;

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;

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[i] >= #160) and (AHzStr[i + 1] >= #160) then

begin

HzOrd := (Ord(AHzStr[i]) - 160) * 100 + Ord(AHzStr[i + 1]) - 160;

for j := 0 to 25 do

begin

if (HzOrd >= ChinaCode[j][0]) and (HzOrd <= ChinaCode[j][1]) then

begin

Result := Result + Char(Byte('A') + j);

Break;

end;

end;

Inc(i);

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

Inc(i);

end;

end;

function UpperCaseMoney(const Money: Double): String;

var

tmp1,rr :string;

l,i,j,k:integer;

r: Double;

const

n1: array[0..9] of string = ('零', '壹', '贰', '叁', '肆',

'伍', '陆', '柒', '捌', '玖');

n2: array[0..3] of string = ('', '拾' ,'佰', '仟');

n3: array[0..2] of string = ('元', '万', '亿');

begin

r:=Money;

tmp1:=FormatFloat('#.00',r);

l:=length(tmp1);

rr:='';

if strtoint(tmp1[l])<>0 then begin

rr:='分';

rr:=n1[strtoint(tmp1[l])]+rr;

end;

if strtoint(tmp1[l-1])<>0 then begin

rr:='角'+rr;

rr:=n1[strtoint(tmp1[l-1])]+rr;

end;

i:=l-3;

j:=0;k:=0;

while i>0 do begin

if j mod 4=0 then begin

rr:=n3[k]+rr;

inc(k);if k>2 then k:=1;

j:=0;

end;

if strtoint(tmp1[i])<>0 then

rr:=n2[j]+rr;

rr:=n1[strtoint(tmp1[i])]+rr;

inc(j);

dec(i);

end;

while pos('零零',rr)>0 do

rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);

rr:=stringreplace(rr,'零亿','亿零',[rfReplaceAll]);

while pos('零零',rr)>0 do

rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);

rr:=stringreplace(rr,'零万','万零',[rfReplaceAll]);

while pos('零零',rr)>0 do

rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);

rr:=stringreplace(rr,'零元','元零',[rfReplaceAll]);

while pos('零零',rr)>0 do

rr:= stringreplace(rr,'零零','零',[rfReplaceAll]);

rr:=stringreplace(rr,'亿万','亿',[rfReplaceAll]);

if copy(rr,length(rr)-1,2)='零' then

rr:=copy(rr,1,length(rr)-2);

result:=rr;

end;

function SoundCardExist: Boolean;

begin

Result := WaveOutGetNumDevs > 0;

end;

initialization

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

end.