unit_common.pas

航空人身保险信息管理系统使用SQL和DELHPI开发

begin
  MessageError(PChar(Format(InputFmt, Value)));
end;

procedure MessageAbort(InputMsg: string);
begin
  MessageInformation(InputMsg);
  Abort;
end;

procedure MessageAbort(InputFmt: string; Value: array of const);
begin
  MessageInformation(InputFmt, Value);
  Abort;
end;

function LocalUserName: string;
var
  Size: DWORD;
  tmName: PChar;
begin
  Size := 256;
  tmName := StrAlloc(Size);
  try
    GetUserName(tmName, Size);
    Result := Trim(StrPas(tmName));
  finally
    StrDispose(tmName);
  end; //try
end;

function LocalComputerName: string;
var
  Size: DWORD;
  tmName: PChar;
begin
  Size := 256;
  tmName := StrAlloc(Size);
  try
    GetComputerName(tmName, Size);
    Result := Trim(StrPas(tmName));
  finally
    StrDispose(tmName);
  end; //try
end;

function GetFileDateTime(const FileName: string; DateType: Integer): TDateTime;
var sr: TSearchRec;

  function CovFileDate(Fd: _FileTime): TDateTime;
{ 转换文件的时间格式 }
  var Tct: _SYSTEMTIME; Temp: _FileTime;
  begin
    FileTimeToLocalFileTime(Fd, Temp);
    FileTimeToSystemTime(Temp, Tct);
    CovFileDate := SystemTimeToDateTime(Tct);
  end;
begin
  if FindFirst(FileName, $27, sr) = 0 then
  begin
    case DateType of
      1: Result := CovFileDate(sr.FindData.ftCreationTime);
      2: Result := CovFileDate(sr.FindData.ftLastWriteTime);
      3: Result := CovFileDate(sr.FindData.ftLastAccessTime);
    else
      Result := CovFileDate(sr.FindData.ftCreationTime);
    end;
    FindClose(sr);
  end;
end;

function LocalTempPath: string;
var
  Size: DWORD;
  tmName: PChar;
begin
  Size := 256;
  tmName := StrAlloc(Size);
  try
    GetTempPath(Size, tmName);
    Result := Trim(StrPas(tmName));
  finally
    StrDispose(tmName);
  end; //try
end;

function GetLastErrorStr: string;
var
  pMsgBuf: PChar;
begin
  pMsgBuf := nil;
  FormatMessage(
    FORMAT_MESSAGE_ALLOCATE_BUFFER or
    FORMAT_MESSAGE_FROM_SYSTEM,
    nil,
    GetLastError(),
    LANG_NEUTRAL or SUBLANG_DEFAULT,
    pMsgBuf,
    0,
    nil);
  if Assigned(pMsgBuf) then
    Result := Strpas(pMsgBuf)
  else
    Result := '';
end;

function RectToScreen(AControl: TControl; const ARect: TRect): TRect;
var
  Pt: TPoint;
begin
  Pt := ARect.TopLeft;
  Pt := AControl.ClientToScreen(Pt);
  Result.TopLeft := Pt;
  Pt := ARect.BottomRight;
  Pt := AControl.ClientToScreen(Pt);
  Result.BottomRight := Pt;
end;

function ScreenToRect(AControl: TControl; const ARect: TRect): TRect;
var
  Pt: TPoint;
begin
  Pt := ARect.TopLeft;
  Pt := AControl.ScreenToClient(Pt);
  Result.TopLeft := Pt;
  Pt := ARect.BottomRight;
  Pt := AControl.ScreenToClient(Pt);
  Result.BottomRight := Pt;
end;

function IntToStrEx(const Number, Width: Integer): string;
begin
  Result := Format('%.*d', [Width, Number]);
end;

function FloatToCurrency(const Value: Extended; Digit: Integer): string;
begin
  Result := Format('%.*n', [Digit, Value]);
end;

//说明：把字符串在给定的长度范围内居左,字符串左边用指定字符补齐位数
//例如：PadL('love',8,'*') --> '****love'
//作者：Coach

function PadL(Str: string; Len: Integer; PadChar: Char): string;
var
  PadLen, SLen, I: Integer;
begin
  Result := Str;
  SLen := Length(Str);
  PadLen := Len - SLen;
  if PadLen <= 0 then Exit;
  for I := 1 to PadLen do
  begin
    Result := PadChar + Result;
  end;
end;

//说明：把字符串在给定的长度范围内居右,字符串右边用指定字符补齐位数
//例如：PadR('love',8,'*') --> 'love****'
//作者：Coach

function PadR(Str: string; Len: Integer; PadChar: Char): string;
var
  PadLen, SLen, I: Integer;
begin
  Result := Str;
  SLen := Length(Str);
  PadLen := Len - SLen;
  if PadLen <= 0 then Exit;
  for I := 1 to PadLen do
    Result := Result + PadChar;
end;

//说明：把字符串在给定的长度范围内居中,两端用指定字符补齐位数;
//例如：PadC('love',8,'-') --> '--love--';
//作者：Coach

function PadC(Str: string; Len: Integer; PadChar: Char): string;
var
  PadLen, SLen: Integer;
begin
  Result := Str;
  SLen := Length(Str);
  if SLen >= Len then Exit;
  PadLen := (Len - SLen) div 2;
  Result := PadL(Result, PadLen + SLen, PadChar);
  Result := PadR(Result, Len, PadChar);
end;

function SetPCDateTime(ADateTime: TDateTime): Boolean;
var
  TST: TSystemTime;
  VDateBias: Variant;
  TSetDate: TDateTime;
  TTZI: TTimeZoneInformation;
begin
  GetTimeZoneInformation(TTZI);
  VDateBias := TTZI.Bias / 1440;
  TSetdate := ADateTime + VDateBias;
  with TST do
  begin
    WYear := StrToInt(FormatDateTime('yyyy', TSetDate));
    WMonth := StrToInt(FormatDateTime('mm', TSetDate));
    WDay := StrToInt(FormatDateTime('dd', TSetDate));
    WHour := StrToInt(FormatDateTime('hh', TSetDate));
    WMinute := StrToInt(FormatDateTime('nn', TSetDate));
    WSecond := StrToInt(FormatDateTime('ss', TSetDate));
    WMilliseconds := StrToInt(FormatDateTime('z', TSetDate));
  end; //with TST
  Result := SetSystemTime(TST);
end;

function GetTemporaryFileName: string;
var
  lpPathBuffer, lpBuffer: PChar;
begin
  GetMem(lpBuffer, MAX_PATH);
  GetMem(lpPathBuffer, MAX_PATH);
  GetTempPath(MAX_PATH, lpPathBuffer);
  GetTempFileName(lpPathBuffer, 'tmp', 0, lpBuffer);
  FreeMem(lpPathBuffer, MAX_PATH);
  Result := Strpas(lpBuffer);
  FreeMem(lpBuffer, MAX_PATH);
end;

const
  Crypt1 = 52845;
  Crypt2 = 22719;

function Encrypt(const S: string; Key: Word): string;
var
  I, Num: Integer;
begin
  Num := Length(S);
  SetLength(Result, Num);
  for I := 1 to Num do
  begin
    Result[I] := Char(Byte(S[I]) xor (Key shr 8));
    Key := (Byte(Result[I]) + Key) * Crypt1 + Crypt2;
  end; //for
end;

function Decrypt(const S: string; Key: Word): string;
var
  I, Num: Integer;
begin
  Num := Length(S);
  SetLength(Result, Num);
  for I := 1 to Num do
  begin
    Result[I] := Char(Byte(S[I]) xor (Key shr 8));
    Key := (Byte(S[I]) + Key) * Crypt1 + Crypt2;
  end;
end;

const
  MinBase = 2;
  MaxBase = 36;

function NumToStr(Num, Len, Base: Integer; Neg: Boolean; FillChar: Char): string;
//Num =  the number to convert
//Len =  minimum length of the resulting string
//Base = numeric base 2 = binary, 8 = octal, 10 = dec, 16 = hex
//Neg =  if treu Num is treated as negative number
//FillChar = character that ist used as FillChar in to get a string
//       of the length len
//
//Example:
//NumToStr (45, 8, 2, false, '0') > ''00101101''
//NumToStr (45, 4, 8, false, '0') > ''0055''
//NumToStr (45, 4, 10, false, ' ') > ''  45''
//NumToStr (45, 4, 16, false, '0') > ''002D''
//NumToStr (45, 0, 36, false, ' ') > ''19''
//
var
  S: string;
  Digit: Integer;
begin
  Num := ABS(Num);
  if ((Base >= MinBase) and (base <= MaxBase)) then begin
    S := '';
    repeat
      digit := Num mod base;
      if digit < 10 then Insert(CHR(digit + 48), S, 1)
      else Insert(CHR(digit + 55), S, 1);
      Num := Num div base;
    until Num = 0;
    if neg then Insert('-', S, 1);
    while Length(S) < len do
      Insert(FillChar, S, 1);
  end;
  Result := S;
end;

//Back from string to Number:

function StrToNum(const S: string; Base: Integer; Neg: Boolean; MaxValue: Integer): Integer;
// S = the string containing the number
// Base = numeric base that is expected
// Neg = string maybe contains ''-'' to show if its < 0
// MaxValue = maximum number that can be containd (normally MaxInt)
//
// Example:
// i:= StrToNum ('00101101', 2, false, MaxInt);
// i:= StrToNum ('002D', 16, false, MaxInt);
// i:= StrToNum ('-45', 10, true, MaxInt);
// i:= StrToNum ('ZZ', 36, true, MaxInt);
var
  c: Char;
  negate, done: Boolean;
  i, len, mdb, res, digit, mmb: Integer;
begin
  res := 0; i := 1; digit := 0;
  if (base >= MinBase) and (base <= MaxBase) then
  begin
    mmb := MaxValue mod base;
    mdb := MaxValue div base;
    len := Length(S);
    negate := False;
    while (i <= len) and (S[i] = ' ') do Inc(i);
    if neg then
    begin
      case S[i] of
        '+': Inc(i);
        '-':
          begin
            Inc(i); negate := TRUE;
          end;
      end; //CASE
    end; //IF neg
    done := len > i;
    while (i <= len) and done do
    begin
      c := UpCase(S[i]);
      case c of
        '0'..'9': digit := ORD(c) - 48;
        'A'..'Z': digit := ORD(c) - 55;
      else done := FALSE
      end; //CASE
      done := done and (digit < base);
      if done then
      begin
        done := (res < mdb) or ((res = mdb) and (digit <= mmb));
        if done then
        begin
          res := res * base + digit;
          Inc(i);
        end; //IF done
      end; //IF done
    end; //WHILE
    if negate then res := -res;
  end; //IF done
  Result := res;
end;

function NumToRoman(Num: Integer): string;
const
  aRomans: array[1..13] of string = ('I', 'IV', 'V', 'IX', 'X', 'XL', 'L', 'XC', 'C', 'CD', 'D', 'CM', 'M');
  aArabics: array[1..13] of Integer = (1, 4, 5, 9, 10, 40, 50, 90, 100, 400, 500, 900, 1000);
var
  I: Integer;
begin
  Result := '';
  for I := 13 downto 1 do
    while (Num >= aArabics[i]) do
    begin
      Num := Num - aArabics[i];
      Result := Result + aRomans[i];
    end;
end;

function StrSimilar(S1, S2: string; Tolerant: Boolean): Integer;
var
  hit: Integer; // Number of identical chars
  p1, p2: Integer; // Position count
  diff: Integer; // unsharp factor
  l1, l2, l: Integer; // Length of strings
  hstr: string; // help var for swapping strings
  test: Classes.TBits; // Array shows if position is already tested

  function CompChar(ch1, ch2: Char): Boolean; //german "umlauts" and similar charactes
  begin
    if tolerant then begin
      ch1 := UpCase(ch1); // compare case insensitive
      ch2 := UpCase(ch2);
      case ch1 of
        '?', 'E': Result := ch2 in ['?', 'E'];
        'B', 'P': Result := ch2 in ['B', 'P'];
        'C', 'Z': Result := ch2 in ['C', 'Z'];
        'D', 'T': Result := ch2 in ['D', 'T'];
        'F', 'V': Result := ch2 in ['F', 'V'];
        'G', 'K': Result := ch2 in ['G', 'K'];
        'S': Result := ch2 in ['S', '?'];
        'I', 'J', 'Y': Result := ch2 in ['I', 'J', 'Y', '?'];
      else Result := ch1 = ch2;
      end;