zkutils.pas

在作数据库中个人认为必要的函数和过程

function GetWinDir: String;
var
  p: PChar;
  z: Integer;
begin
  z := 255;
  GetMem(p,z);
  GetWindowsDirectory(p,z);
  Result := FormatPath(String(p));
  FreeMem(p,z);
end;


function GetCurrentDir: String;
var
  p: PChar;
  z: Integer;
begin
  z := 255;
  GetMem(p,z);
  GetCurrentDirectory(z,p);
  Result := FormatPath(String(p));
  FreeMem(p,z);
end;

function GetInstallDir: String;
var
  s: String;
begin
  s := ParamStr(0);
  s := ExtractFilePath(s);
  Result := FormatPath(s);
end;

function GetFileDate(Filename: String): Tdatetime;
begin
  if FileExists(Filename) then
    Result := FileDateToDateTime(FileAge(Filename))
  else
    Result := MaxInt;
end;

function EncodeDate(const Year: Integer; Month, Day: Word): TDateTime; overload;
begin
  if (Year > 0) and (Year < EncodeDateMaxYear + 1) then
    Result := SysUtils.EncodeDate(Year, Month, Day)
  else
  begin
      if Year <= 0 then
        Result := Year * DaysPerYear + DateTimeBaseDay
      else      // Year >= 10000
        // for some reason year 0 does not exist so we switch from
        // the last day of year -1 (-693594) to the first days of year 1
        Result := (Year-1) * DaysPerYear + DateTimeBaseDay // BaseDate is 1/1/1
            + SolarDifference;                       // guarantee a smooth transition at 1/1/10000
      Result := Trunc(Result);
      Result := Result + (Month-1) * DaysPerMonth;
      Result := Round(Result) + (Day-1);
    end;
end;

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

procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Word);
begin
  SysUtils.DecodeDate(Date, Year, Month, Day);
end;

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

procedure DecodeDate(Date: TDateTime; var Year, Month, Day: Integer);
var
  WMonth, WDay: Word;
begin
  DecodeDate(Date, Year, WMonth, WDay);
  Month := Wmonth;
  Day := WDay;
end;

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

procedure DecodeDate(Date: TDateTime; var Year: Integer; var Month, Day: Word);
var
  WYear: Word;
  RDays, RMonths: TDateTime;
begin
  if (Date >= DateTimeBaseDay) and (Date < DateTimeMaxDay) then
  begin
    SysUtils.DecodeDate(Date, WYear, Month, Day);
    Year := WYear;
  end
  else
  begin
    Year := Trunc((Date - DateTimeBaseDay) / DaysPerYear);
    if Year <= 0 then
      Year := Year - 1
          // for some historical reason year 0 does not exist so we switch from
          // the last day of year -1 (-693594) to the first days of year 1
    else                                      // Year >= 10000
      Date := Date - SolarDifference;         // guarantee a smooth transition at 1/1/10000
    RDays := Date - DateTimeBaseDay;        // Days relative to 1/1/0001
    RMonths := RDays / DaysPerMonth;          // "Months" relative to 1/1/0001
    RMonths := RMonths - Year * 12.0;         // 12 "Months" per Year
    if RMonths < 0 then                       // possible truncation glitches
    begin
      RMonths := 11;
      Year := Year - 1;
    end;
    Month := Trunc(RMonths);
    Rmonths := Month;
    Month := Month + 1;
    RDays := RDays - Year * DaysPerYear;    // subtract Base Day ot the year
    RDays := RDays - RMonths * DaysPerMonth;// subtract Base Day of the month
    Day := Trunc (RDays)+ 1;
    if Year > 0 then                          // Year >= 10000
      Year := Year + 1;                      // BaseDate is 1/1/1
  end;
end;

//返回时间的字符串格式，用DivChar间隔
function DateStr(DateTime: TDateTime; DivChar: Char=' '): String;
var
  Y: Integer;
  M, D: Word;
  S: String;
begin
  DecodeDate(DateTime, Y, M, D);
  Result := IntToStr(Y);
  if DivChar <> ' ' then
    Result := Result + DivChar;
  S := IntToStr(M);
  if Length(S) = 1 then
    Result := Result + '0';
  Result := Result + S;
  if DivChar <> ' ' then
    Result := Result + DivChar;
  S := IntToStr(D);
  if Length(S) = 1 then
    Result := Result + '0';
  Result := Result + S;
end;

function Year(DateTime: TDateTime): Integer;
var
  M, D: Word;
begin
  DecodeDate(DateTime, Result, M, D);
end;

function Month(DateTime: TDateTime): Integer;
var
  Y: Integer;
  M, D: Word;
begin
  DecodeDate(DateTime, Y, M, D);
  Result := M;
end;

function Day(DateTime: TDateTime): Integer;
var
  Y: Integer;
  M, D: Word;
begin
  DecodeDate(DateTime, Y, M, D);
  Result := D;
end;

function GetFileVersion(Filename: String): String;
var
  VerInfoSize, VerValueSize, Dummy: Dword;
  VerInfo: Pointer;
  VerValue: PVSFixedFileInfo;
  sVer: String;
  V1,V2,V3,V4: Word;
begin
  VerInfoSize := GetFileVersionInfoSize(PChar(Filename), Dummy);
  GetMem(VerInfo,VerInfoSize);
  GetFileVersionInfo(PChar(Filename), 0, VerInfoSize, VerInfo);
  VerQueryValue(VerInfo, '\', Pointer(VerValue), VerValueSize);
  With VerValue^ do
  begin
    V1:=dwFileVersionMS shr 16;
    V2:=dwFileVersionMS and $FFFF;
    V3:=dwFileVersionLS shr 16;
    V4:=dwFileVersionLS and $FFFF;
  end;
  FreeMem(VerInfo,VerInfoSize);
  sVer:=IntToStr(V1) + '.' + IntToStr(V2) + '.' +  IntToStr(V3) + '.' + IntToStr(V4);
  Result := sVer;
end;

function SQLString(const AStr: String): String;
var
  iStart, ipos: Integer;
  sResult, sTmp: String;
begin
  //
  iStart := 0;
  sResult := AStr;
  sTmp := AStr;
  ipos := Pos('''', sTmp);
  while ipos > 0 do
  begin
    iStart := iStart + ipos;
    Delete(sResult, iStart, 1);
    Insert('''''',sResult,iStart);
    Inc(iStart);
    sTmp := Copy(sTmp, ipos + 1, Length(sTmp) - ipos);
    ipos := Pos('''', sTmp);
  end;
  Result := sResult;
end;

function CreateFolder(const AFolderName: String): Boolean;
var
  s, tmp: String;
  i: Integer;
begin
  //建立文件夹
  tmp := FormatPath(AFolderName);
  while Pos('\', tmp) <> 0 do
  begin
    i := Pos('\', tmp);
    s := Copy(AFoldername, 0, i);
    if not DirectoryExists(s) then CreateDir(s);
    tmp[i] := ' ';
  end;
  Result := True;
end;

function IsInteger(Value: String): Boolean;
var
  i: Integer;
begin
  try
    i := StrToInt(Value);
    Result := True;
  except
    Result := False;
  end;
end;

function IsNumeric(Value: String): Boolean;
var
  d: Double;
begin
  try
    d := StrToFloat(Value);
    Result := True;
  except
    Result := False;
  end;
end;

Function GetPYIndexChar(const hzChar: String): Char;
begin
  case WORD(hzChar[1]) shl 8 + WORD(hzChar[2]) of
    $B0A1..$B0C4 : Result := 'A';
    $B0C5..$B2C0 : Result := 'B';
    $B2C1..$B4ED : Result := 'C';
    $B4EE..$B6E9 : Result := 'D';
    $B6EA..$B7A1 : Result := 'E';
    $B7A2..$B8C0 : Result := 'F';
    $B8C1..$B9FD : Result := 'G';
    $B9FE..$BBF6 : Result := 'H';
    $BBF7..$BFA5 : Result := 'J';
    $BFA6..$C0AB : Result := 'K';
    $C0AC..$C2E7 : Result := 'L';
    $C2E8..$C4C2 : Result := 'M';
    $C4C3..$C5B5 : Result := 'N';
    $C5B6..$C5BD : Result := 'O';
    $C5BE..$C6D9 : Result := 'P';
    $C6DA..$C8BA : Result := 'Q';
    $C8BB..$C8F5 : Result := 'R';
    $C8F6..$CBF9 : Result := 'S';
    $CBFA..$CDD9 : Result := 'T';
    $CDDA..$CEF3 : Result := 'W';
    $CEF4..$D188 : Result := 'X';
    $D1B9..$D4D0 : Result := 'Y';
    $D4D1..$D7F9 : Result := 'Z';
  else
    Result := Char(0);//hzchar[1]
  end;
end;

Function NumberToChinese(const n0 : Real) :String;
Function IIF(b :Boolean; s1,s2:String): String;
begin //本函数在VFP和VB中均为系统内部函数
  if b then IIF:=s1  else IIF:=s2;
end;
Const c = '零壹贰叁肆伍陆柒捌玖◇分角圆拾佰仟万拾佰仟亿拾佰仟万';
var L,i,n, code :integer;
Z :boolean;
s, st,st1 :string;
begin
  s :=FormatFloat( '0.00', n0);
  L :=Length(s);
  Z :=n0<1;
  For i:= 1 To L-3 do
  begin
    Val(Copy(s, L-i-2, 1), n, code);
    st := IIf((n=0) And (Z Or (i=9) Or (i=5) Or (i=1)), '', Copy(c, n*2+1, 2))
        + IIf((n=0)And((i<>9)And(i<>5)And(i<>1)Or Z And(i=1)),'',Copy(c,(i+13)*2-1,2))
        + st;
    Z := (n=0);
  end;
  Z := False;
  For i:= 1 To 2 do
  begin
    Val(Copy(s, L-i+1, 1), n, code);
    st1:= IIf((n=0)And((i=1)Or(i=2)And(Z Or (n0<1))), '', Copy(c, n*2+1, 2))
        + IIf((n>0), Copy(c,(i+11)*2-1, 2), IIf((i=2) Or Z, '', '整'))
        + st1;
    Z := (n=0);
  end;
  For i := 1 To Length(st) do If Copy(st, i, 4) = '亿万' Then Delete(st,i+2,2);
  Result := IIf( n0=0, '零', st + st1);
End;

Function GetRandomString(const Len: Integer): String;
const
	c = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
var
	i: Integer;
begin
  Randomize;
	for i := 0 to Len-1 do 
    Result := Result + c[Random(Length(c)-1)+1]; 
end;

function CharArrayToStr(D: array of Char): String;
var
	I: byte;
const
	Digits: array[0..15] of char =
		('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
begin
	Result := '';
	for I := 0 to 15 do Result := Result + Digits[(Ord(D[I]) shr 4) and $0f] + Digits[Ord(D[I]) and $0f];
end;

function ByteArrayToStr(D: array of Byte): String;
var
	I: byte;
const
	Digits: array[0..15] of char =
		('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
begin
	Result := '';
	for I := 0 to 15 do Result := Result + Digits[(D[I] shr 4) and $0f] + Digits[D[I] and $0f];
end;

//根据字符串，拆分字符串，相当于vb中的split函数
function SplitString(const Source,ch: String): TStringList;
var
  temp: String;
  i: Integer;
begin
  Result := TStringList.Create;
  //如果是空自符串则返回空列表
  if Source = '' then Exit;
  temp := Source;
  i := pos(ch,Source);
  while i<>0 do
  begin
     Result.Add(Copy(temp,0,i-1));
     Delete(temp,1,i);
     i := Pos(ch,temp);
  end;
  Result.Add(temp);
end;

/// <summary>
/// MD5Hash函数
/// </summary>
/// <param name="Source">源字符串</param>
/// <returns>结果字符串，是个32字节长的字符串</returns>
function MD5Hash(const Source: String): String;
var
  MD5Hash: TMD5;
  OutputArray: array[0..15] of Byte;
begin
  MD5Hash := TMD5.Create;
  try
    MD5Hash.InputType    := itString;
    MD5Hash.InputString  := Source;
    MD5Hash.POutputArray := @OutputArray;
    MD5Hash.HashCalc;
    Result := ByteArrayToStr(OutputArray);
  finally
    MD5Hash.Free;
  end;
end;
function  DataFieldToString(VData: Variant): String;
begin
  if VarIsNull(VData) then
    Result:=''
  else
    Result:=VData;
end;
function  DataFieldToInt(VData: Variant): Integer;
begin
  if VarIsNull(VData) then
    Result:=0
  else
    Result:=VData;
end;
function  DataFieldToCurr(VData: Variant): Currency;
begin
  if VarIsNull(VData) then
    Result:=0.0
  else
    Result:=VData;
end;
end.