commonuse.pas

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

    iYear:=START_YEAR-1;
    if iSpanDays<19 then
    begin
      iMonth:=11;
      iDay:=11+Word(iSpanDays);
    end
    else
    begin
      iMonth:=12;
      iDay:=Word(iSpanDays)-18;
    end;
    Exit;
  end;
  //下面从阴历1901年正月初一算起
  iSpanDays:=iSpanDays-49;
  iYear:=START_YEAR;
  iMonth:=1;
  iDay:=1;
  //计算年
  tmp:=LunarYearDays(iYear);
  while iSpanDays>=tmp do
  begin
    iSpanDays:=iSpanDays-tmp;
    Inc(iYear);
    tmp:=LunarYearDays(iYear);
  end;
  //计算月
  tmp:=LoWord(LunarMonthDays(iYear,iMonth));
  while iSpanDays>=tmp do
  begin
    iSpanDays:=iSpanDays-tmp;
    if iMonth=GetLeapMonth(iYear) then
    begin
      tmp:=HiWord(LunarMonthDays(iYear,iMonth));
      if iSpanDays<tmp then
        Break;
      iSpanDays:=iSpanDays-tmp;
    end;
    Inc(iMonth);
    tmp:=LoWord(LunarMonthDays(iYear,iMonth));
  end;
  //计算日
  iDay:=iDay+Word(iSpanDays);
end;

function l_GetLunarHolDay(iYear,iMonth,iDay:Integer):Integer;
var
  Flag:Byte;
  Day:Integer;
begin
  Flag:=gLunarHolDay[(iYear-START_YEAR)*12+iMonth-1];
  if iDay<15 then
    Day:=15-((Flag shr 4) and $0f)
  else
    Day:=(Flag and $0f)+15;
  if iDay=Day then
    if iDay>15 then
      Result:=(iMonth-1)*2+2
    else
      Result:=(iMonth-1)*2+1
  else
    Result:=0;
end;

function GetLunarDateString(const InDate: TDateTime): String;
var
  sYear, sMonth, sDay: Integer;
begin
  GetLunarDate(InDate, sYear, sMonth, sDay);
  Result := Trim(FormatLunarYear(sYear)) + Trim(FormatMonth(sMonth)) + Trim(FormatLunarDay(sDay)) + GetLunarHolDay(InDate);
end;

function SfzOldIDToNewID(ID: String): String;
var
  i,SfzXy:Integer;
  XYM:String;
  a:array[0..17] of string;
begin
  a[0]:='0';
  a[1]:='7';
  a[2]:='9';
  a[3]:='10';
  a[4]:='5';
  a[5]:='8';
  a[6]:='4';
  a[7]:='2';
  a[8]:='1';
  a[9]:='6';
  a[10]:='3';
  a[11]:='7';
  a[12]:='9';
  a[13]:='10';
  a[14]:='5';
  a[15]:='8';
  a[16]:='4';
  a[17]:='2';
  SfzXy:=0;
  for i:=1 to 17 do
    SfzXy:=SfzXy+StrToInt(Copy(ID,i,1))*strtoInt(a[i]);
  Case (SfzXy Mod 11) of
    0: XYM :='1';
    1: XYM :='0';
    2: XYM :='X';
    3: XYM :='9';
    4: XYM :='8';
    5: XYM :='7';
    6: XYM :='6';
    7: XYM :='5';
    8: XYM :='4';
    9: XYM :='3';
    10:XYM :='2';
  end;
  Result:=XYM;
end;

function SFZ15to18(ID: string):string;
const 
  W:array [1..18] of integer = (7,9,10,5,8,4,2,1,6,3,7,9,10,5,8,4,2,1);
  A:array [0..10] of char = ('1','0','x','9','8','7','6','5','4','3','2');
var
  i, j, S: integer;
  NewID: string;
begin
  if Length(ID) <> 15 then
    result:= ''
  else begin
    NewID:= ID;
    Insert('19', NewID, 7);
    S:= 0;
    try
      for i:=1 to 17 do begin
        j:= StrToInt(NewID[i]) * W[i];
        S:= S + j;
      end;
    except
      result:= '';
      exit;
    end;
    S:= S mod 11;
    Result:= NewID + A[S];
  end; 
end;

function Base64Encode(const s: string): string;
var
  s4: string;
  i, j, k: integer;
  b: byte;
const
  Base64: string = '23456789ABCDEFGHJKLMNPQRSTUVWXYZabcdefghijkmnopqrstuvwxyz~#%&*+-';
begin
  Result := '';
  SetLength(s4, 4);
  b := 0;
  i := 1;
  j := 2;
  k := 2;
  while i <= length(s) do begin
    b := b or ((ord(s[i]) and $C0) shr k);
    inc(k,2);
    s4[j] := Base64[(ord(s[i]) and $3F)+1];
    inc(i);
    inc(j);
    if j > 4 then begin
      s4[1] := Base64[b + 1];
      b := 0;
      j := 2;
      k := 2;
      Result := Result + s4;
    end;
  end;
  if j <> 2 then begin // Flush data in s4.
    s4[j] := '.';
    s4[1] := Base64[b + 1];
    Result := Result + s4;
    SetLength(Result, Length(Result) - (4 - j));
  end else
    Result := Result + '.';
end;

function Base64Decode(const s: string): string;
var
  i, j, k: integer;
  b: byte;
const
  UnBase64: array[0..255] of byte =
    (128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //0-15
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //16-31
     128,128,128, 58,128, 59, 60,128, 128,128, 61, 62,128, 63,128,128, //32-47
     128,128, 0, 1, 2, 3, 4, 5, 6, 7,128,128,128,128,128,128, //48-63
     128, 8, 9, 10, 11, 12, 13, 14, 15,128, 16, 17, 18, 19, 20,128, //64-79
     21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31,128,128,128,128,128, //80-95
     128, 32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42,128, 43, 44, 45, //96-111
     46, 47, 48, 49, 50, 51, 52, 53, 54, 55, 56,128,128,128, 57,128, //112-127
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //128-143
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //144-159
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //160-175
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //176-191
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //192-207
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //208-223
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128, //224-239
     128,128,128,128,128,128,128,128, 128,128,128,128,128,128,128,128); //240-255
begin
  Result := '';
  b := 0;
  i := 1;
  j := 0;
  while (i <= length(s)) and (s[i] <> '.') do begin
    if j = 0 then begin
      b := UnBase64[ord(s[i])];
      k := 2;
    end else begin
      Result := Result + chr(UnBase64[ord(s[i])] or ((b shl k) and $C0));
      inc(k, 2);
    end;
    inc(j);
    j := j and 3;
    inc(i);
  end;
end;

function Base64ToString(const Value : string): string;
var
 x, y, n, l: Integer;
 d: array[0..3] of Byte;
 Table : string;
begin
 Table :=
   #$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$3E +#$40
   +#$40 +#$40 +#$3F +#$34 +#$35 +#$36 +#$37 +#$38 +#$39 +#$3A +#$3B +#$3C
   +#$3D +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40 +#$00 +#$01 +#$02 +#$03
   +#$04 +#$05 +#$06 +#$07 +#$08 +#$09 +#$0A +#$0B +#$0C +#$0D +#$0E +#$0F
   +#$10 +#$11 +#$12 +#$13 +#$14 +#$15 +#$16 +#$17 +#$18 +#$19 +#$40 +#$40
   +#$40 +#$40 +#$40 +#$40 +#$1A +#$1B +#$1C +#$1D +#$1E +#$1F +#$20 +#$21
   +#$22 +#$23 +#$24 +#$25 +#$26 +#$27 +#$28 +#$29 +#$2A +#$2B +#$2C +#$2D
   +#$2E +#$2F +#$30 +#$31 +#$32 +#$33 +#$40 +#$40 +#$40 +#$40 +#$40 +#$40;
 SetLength(Result, Length(Value));
 x := 1;
 l := 1;
 while x < Length(Value) do
 begin
   for n := 0 to 3 do
   begin
     if x > Length(Value) then
       d[n] := 64
     else
     begin
       y := Ord(Value[x]);
       if (y < 33) or (y > 127) then
         d[n] := 64
       else
         d[n] := Ord(Table[y - 32]);
     end;
     Inc(x);
   end;
   Result[l] := Char((D[0] and $3F) shl 2 + (D[1] and $30) shr 4);
   Inc(l);
   if d[2] <> 64 then
   begin
     Result[l] := Char((D[1] and $0F) shl 4 + (D[2] and $3C) shr 2);
     Inc(l);
     if d[3] <> 64 then
     begin
       Result[l] := Char((D[2] and $03) shl 6 + (D[3] and $3F));
       Inc(l);
     end;
   end;
 end;
 Dec(l);
 SetLength(Result, l);
end;

function StringToBase64(const Value: string): string;
var
 c: Byte;
 n, l: Integer;
 Count: Integer;
 DOut: array[0..3] of Byte;
 Table : string;
begin
 Table :=
   'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=';

 setlength(Result, ((Length(Value) + 2) div 3) * 4);
 l := 1;
 Count := 1;
 while Count <= Length(Value) do
 begin
   c := Ord(Value[Count]);
   Inc(Count);
   DOut[0] := (c and $FC) shr 2;
   DOut[1] := (c and $03) shl 4;
   if Count <= Length(Value) then
   begin
     c := Ord(Value[Count]);
     Inc(Count);
     DOut[1] := DOut[1] + (c and $F0) shr 4;
     DOut[2] := (c and $0F) shl 2;
     if Count <= Length(Value) then
     begin
       c := Ord(Value[Count]);
       Inc(Count);
       DOut[2] := DOut[2] + (c and $C0) shr 6;
       DOut[3] := (c and $3F);
     end
     else
     begin
       DOut[3] := $40;
     end;
   end
   else
   begin
     DOut[2] := $40;
     DOut[3] := $40;
   end;
   for n := 0 to 3 do
   begin
     Result[l] := Table[DOut[n] + 1];
     Inc(l);
   end;
 end;
end;

function GetTitle(const Value: string): string;
var
 iPos: integer;
begin
 Result := Value;
 if Copy(Value, 1, 2) <> '=?' then exit;
 //'?B?'前面的都要去掉
 iPos := Pos('?B?', Value);
 Inc(iPos, 3);
 //最后的'?='也要去掉
 Result := Copy(Value, iPos, Length(Value) - iPos - 1);
 Result := Base64ToString(Result);
end;

function GetDirectorySize(const ADirectory: string): Integer;
var
  Dir: TSearchRec;
  Ret: integer;
  Path: string;
begin
  Result := 0;
  Path := ExtractFilePath(ADirectory);
  Ret := Sysutils.FindFirst(ADirectory, faAnyFile, Dir);
  if Ret <> NO_ERROR then
    exit;
  try
    while ret=NO_ERROR do begin
      inc(Result, Dir.Size);
      if (Dir.Attr in [faDirectory]) and (Dir.Name[1] <> '.') then
        Inc(Result, GetDirectorySize(Path + Dir.Name + '\*.*'));
      Ret := Sysutils.FindNext(Dir);
    end;
  finally
    Sysutils.FindClose(Dir);
  end;
end;

function EmptyDirectory(const TheDirectory :String ; const Recursive : Boolean) : Boolean;
var
  SearchRec : TSearchRec;
  Res : Integer;
begin
  Result := False;
  //TheDirectory := NormalDir(TheDirectory);
  Res := FindFirst(TheDirectory + '*.*', faAnyFile, SearchRec);
  try
    while Res = 0 do begin
      if (SearchRec.Name <> '.') and (SearchRec.Name <> '..') then begin
        if ((SearchRec.Attr and faDirectory) > 0) and Recursive then begin
          EmptyDirectory(TheDirectory + SearchRec.Name, True);
          RemoveDirectory(PChar(TheDirectory + SearchRec.Name));
        end else begin
          DeleteFile(pchar(TheDirectory + SearchRec.Name));
        end;
      end;
      Res := FindNext(SearchRec);
    end;
    Result := True;
  finally
    FindClose(SearchRec);
  end;
end;

End.