自己写的一些Delphi常用函数

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.