commonuse.pas

Delphi的很有用的常用的方法和函数列表.

      If (money[j] = '0') And (money[j + 1] = '0') Then 
      Begin
        ch := ch + '整';
        break;
      End
    Else If (money[j] = '0') And (money[j + 1] <> '') Then
      ch := ch + '零'
    Else If (money[j] = '0') And (money[j + 1] = '') Then
    Else
      ch := ch + a[StrToInt(money[j])] + c[zheng - j]
  Else 
    ch := ch + '整';
  Result := ch;
End;

Function SmallToBig1(Const rmbSmall: Currency): String;
Var
  i: Integer;
  s1, s2, Str, rmbBig: String;
Begin
  Str := FormatFloat('0.00', rmbSmall);
  If Str = '' Then Str := '0';
  i := AnsiPos('.', Str);
  If i <> 0 Then 
  Begin
    s1 := LeftStr(Str, i - 1);
    s2 := RightStr(Str, Length(Str) - i);
    If Length(s2) < 1 Then s2 := s2 + '00';
    If Length(s2) < 2 Then s2 := s2 + '0';
    Str := s1 + s2;
  End 
  Else
    Str := Str + '00';
  rmbBig := '';
  For i := 1 To Length(Str) Do 
  Begin
    Case Str[i] Of
      '0': rmbBig := rmbBig + '０';
      '1': rmbBig := rmbBig + '１';
      '2': rmbBig := rmbBig + '２';
      '3': rmbBig := rmbBig + '３';
      '4': rmbBig := rmbBig + '４';
      '5': rmbBig := rmbBig + '５';
      '6': rmbBig := rmbBig + '６';
      '7': rmbBig := rmbBig + '７';
      '8': rmbBig := rmbBig + '８';
      '9': rmbBig := rmbBig + '９';
    End;
  End;
  rmbBig := '￥' + rmbBig;
  Case Length(rmbBig) Of
    2: rmbBig := '　　　　　　　' + rmbBig;
    4: rmbBig := '　　　　　　' + rmbBig;
    6: rmbBig := '　　　　　' + rmbBig;
    8: rmbBig := '　　　　' + rmbBig;
    10: rmbBig := '　　　' + rmbBig;
    12: rmbBig := '　　' + rmbBig;
    14: rmbBig := '　' + rmbBig;
  End;
  Result := rmbBig;
End;

Function SmallToBig2(Const rmbSmall: Currency): String;
Var
  i: Integer;
  str, s1, s2, rmbBig: String;
Begin
  rmbBig := '';
  str := FormatFloat('0.00', rmbSmall);
  i := AnsiPos('.', Str);
  If i <> 0 Then 
  Begin
    s1 := LeftStr(Str, i - 1);
    s2 := RightStr(Str, Length(Str) - i);
    If Length(s2) < 1 Then s2 := s2 + '00';
    If Length(s2) < 2 Then s2 := s2 + '0';
    Str := s1 + s2;
  End 
  Else
    Str := Str + '00';
  For i := Length(Str) Downto 1 Do 
  Begin
    Case Str[i] Of
      '0': rmbBig := '零' + rmbBig;
      '1': rmbBig := '壹' + rmbBig;
      '2': rmbBig := '贰' + rmbBig;
      '3': rmbBig := '叁' + rmbBig;
      '4': rmbBig := '肆' + rmbBig;
      '5': rmbBig := '伍' + rmbBig;
      '6': rmbBig := '陆' + rmbBig;
      '7': rmbBig := '柒' + rmbBig;
      '8': rmbBig := '捌' + rmbBig;
      '9': rmbBig := '玖' + rmbBig;
    End;
  End;
  Case Length(rmbBig) Of
    2: rmbBig := '※※※※※※※' + rmbBig;
    4: rmbBig := '※※※※※※' + rmbBig;
    6: rmbBig := '※※※※※' + rmbBig;
    8: rmbBig := '※※※※' + rmbBig;
    10: rmbBig := '※※※' + rmbBig;
    12: rmbBig := '※※' + rmbBig;
    14: rmbBig := '※' + rmbBig;
  End;
  Result := rmbBig;
End;

Function isReadWriteDisk(Drive: Char): Bool;
Var
  path: String;
Begin
  Result := False;
  If CreateDir(Drive + ':\Gui') Then 
  Begin
    path := Drive + ':\nsdata';
    RmDir(Drive + ':\Gui');
    If Not DirectoryExists(Path) Then CreateDir(path);
    Result := True;
  End;
End;

Function FindFirstCDROMDrive: Char;
Var
  drivemap, mask: DWORD;
  i: Integer;
  root: String;
Begin
  Result := #0;
  root := 'A:\';
  drivemap := GetLogicalDrives;
  mask := 1;
  For i := 1 To 32 Do 
  Begin
    If (mask And drivemap) <> 0 Then
      If GetDriveType(PChar(root)) = DRIVE_CDROM Then 
      Begin
        Result := root[1];
        Break;
      End;
    mask := mask Shl 1;
    Inc(root[1]);
  End;
End;

Procedure ShowInformation(Const Msg: String);
Begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONINFORMATION);
End;

Procedure ShowWarning(Const Msg: String);
Begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONWARNING);
End;

Function YesNoDialogDef1(Const Msg: String): Boolean;
Begin
  Result := True;
  If Application.MessageBox(PChar(Msg), PChar(Application.Title),
    MB_ICONQUESTION + MB_YESNO) = 7 Then
    Result := False;
End;

Function YesNoDialogDef2(Const Msg: String): Boolean;
Begin
  Result := True;
  If Application.MessageBox(PChar(Msg), PChar(Application.Title),
    MB_ICONQUESTION + MB_YESNO + MB_DEFBUTTON2) = 7 Then
    Result := False;
End;

Function OkCancelDialogDef1(Const Msg: String): Boolean;
Begin
  Result := True;
  If Application.MessageBox(PChar(Msg), PChar(Application.Title),
    MB_ICONQUESTION + MB_OKCANCEL + MB_DEFBUTTON1) = 2 Then
    Result := False;
End;

Function FindFirstRemoveDrive: Char;
Var
  drivemap, mask: DWORD;
  i: Integer;
  root: String;
Begin
  Result := #0;
  root := 'C:\';
  drivemap := GetLogicalDrives;
  mask := 1;
  For i := 1 To 32 Do 
  Begin
    If (mask And drivemap) <> 0 Then
      If GetDriveType(PChar(root)) = DRIVE_REMOVABLE Then 
      Begin
        Result := root[1];
        Break;
      End;
    mask := mask Shl 1;
    Inc(root[1]);
  End;
End;

Procedure GetScreenPic(ZipScale: Word);
Var
  bmpscreen: Tbitmap;
  jpegscreen: Tjpegimage;
  FullscreenCanvas: TCanvas;
  dc: HDC;
  sourceRect, destRect: TRect;
Begin
  If (ZipScale <= 0) Or (ZipScale > 100) Then 
  Begin
    ShowInformation('选择的JPG压缩比必须在1~100之间。');
    Exit;
  End;
  If FileExists('c:\temp.jpg') Then DeleteFile('c:\temp.jpg');
  dc := getdc(0);
  fullscreencanvas := Tcanvas.Create;
  fullscreencanvas.Handle := dc;
  bmpscreen := Tbitmap.Create;
  bmpscreen.Width := screen.Width;
  bmpscreen.Height := screen.Height;
  sourcerect := rect(0, 0, screen.Width, screen.Height);
  destrect := rect(0, 0, screen.Width, screen.Height);
  bmpscreen.Canvas.CopyRect(sourcerect, fullscreenCanvas, destrect);
  jpegscreen := Tjpegimage.Create;
  jpegscreen.Assign(bmpscreen);
  jpegscreen.CompressionQuality := ZipScale;
  jpegscreen.SaveToFile('c:\temp.jpg');
  FullscreenCanvas.Free;
  bmpscreen.Free;
  jpegscreen.Free;
  ReleaseDC(0, DC);
End;

Function GetMaskString(S, Mask: String; Position: Integer): String;
Var
  str: String;
  i, Len: Integer;
Begin
  str := '';
  For i := 0 To Position - 1 Do 
  Begin
    If (Pos(Mask, S) <= 0) Then 
    Begin
      Str := S;
      Break;
    End;
    Str := Copy(S, 1, Pos(Mask, S) - 1);
    Len := Length(Str);
    S := Copy(S, Len + 2, Length(S) - Len - 1);
  End;
  Result := Str;
End;

Function DateStr(Const aDateTime: TDateTime): String;
Begin
  Result := FormatDateTime('YYYY''年''M''月''D''日''', aDateTime);
End;

Function DateTimeStr(Const aDateTime: TDateTime): String;
Begin
  Result := FormatDateTime('YYYY''年''M''月''D''日 ''h''点''mm''分''', aDateTime);
End;

Function TimeStr(Const aDateTime: TDateTime): String;
Begin
  Result := FormatDateTime('h''点''mm''分''ss''秒''', aDateTime);
End;

Procedure ShowError(Const Msg: String);
Begin
  Application.MessageBox(PChar(Msg), PChar(Application.Title), MB_ICONERROR);
End;

Function SuperQuestion(Msg: String; Title: String; Icon: Integer;
  defButton: Integer): Boolean;
Var 
  str, str1: Integer;
Begin
  str := 0;
  str1 := 0;
  Case icon Of
    1: str := Mb_IconInformation;
    2: str := Mb_IconQuestion;
    3: str := MB_ICONWARNING;
    4: str := MB_ICONSTOP;
  End;
  Case defbutton Of
    1: str1 := MB_DEFBUTTON1;
    2: str1 := MB_DEFBUTTON2;
  End;
  Result := True;
  If application.MessageBox(PChar(Msg), PChar(title), mb_yesno + str + str1) = 7 Then
    Result := False;
End;

Procedure SuperMsg(Text: String; Title: String; Icon: Integer);
Var
  str: Integer;
Begin
  str := 0;
  Case icon Of
    1: str := Mb_IconInformation;
    2: str := Mb_IconQuestion;
    3: str := MB_ICONWARNING;
    4: str := MB_ICONSTOP;
  End;
  application.MessageBox(PChar(Text), PChar(title), str);
End;

Procedure BMPToJPG(Const BmpFileName, JPGFileName: String);
Var
  jpeg: TJPEGImage;
  bmp: TBitmap;
Begin
  bmp := TBitmap.Create;
  Try
    bmp.LoadFromFile(BmpFileName);
    jpeg := TJPEGImage.Create;
    Try
      jpeg.Assign(bmp);
      jpeg.Compress;
      jpeg.SaveToFile(JPGFileName);
    Finally
      jpeg.Free;
    End;
  Finally
    bmp.Free;
  End;
End;

Function AppIsRunning: Boolean;
Var
  hSem: THandle;
  AppTitle: String;
Begin
  Result := False;
  AppTitle := Application.Title;
  hSem := CreateSemaphore(Nil, 0, 1, PChar(AppTitle));
  If ((hSem <> 0) And (GetLastError() = ERROR_ALREADY_EXISTS)) Then 
  Begin
    CloseHandle(hSem);
    Result := True;
  End;
  If Result Then Application.Terminate;
End;

Function KillTask(ExeFileName: String): Integer;
Const
  PROCESS_TERMINATE = $0001;
Var
  ContinueLoop: BOOL;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
Begin
  Result := 0;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := Sizeof(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  While Integer(ContinueLoop) <> 0 Do 
  Begin
    If ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) = UpperCase(ExeFileName))
      Or
      (UpperCase(FProcessEntry32.szExeFile) = UpperCase(ExeFileName))) Then
      Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE,
        BOOL(0), FProcessEntry32.th32ProcessID), 0));
    ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  End;
  CloseHandle(FSnapshotHandle);
End;

Function GetApplicationPath: String;
Begin
  Result := ExtractFilePath(Application.EXEName);
End;

Procedure RestoreDateType;
Begin
  DateSeparator := '-';
  ShortDateFormat := 'yyyy-mm-dd';
  LongDateFormat := 'yyyy''年''m''月''d''日''';
  TwoDigitYearCenturyWindow := 70;
End;

Procedure CopyFileWithProgressBar(Source, Destination: String; aGauge: TGauge);
Var
  FromF, ToF: File Of Byte;
  Buffer: Array[0..4096] Of Char;