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;
//------------------------------------------------------------------------------
// 其它过程
//------------------------------------------------------------------------------
function TrimInt(Value, Min, Max: Integer): Integer; overload;
begin
if Value > Max then
Result := Max
else if Value <</span> 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.