commonuse.pas

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

  NumRead: Integer;
  FileLength: Longint;
Begin
  AssignFile(FromF, Source);
  reset(FromF);
  AssignFile(ToF, Destination);
  rewrite(ToF);
  FileLength := FileSize(FromF);
  With aGauge Do 
  Begin
    MinValue := 0;  
    Progress := 0;
    MaxValue := FileLength;
    While FileLength > 0 Do 
    Begin
      BlockRead(FromF, Buffer[0], SizeOf(Buffer), NumRead);
      FileLength := FileLength - NumRead;
      BlockWrite(ToF, Buffer[0], NumRead);
      Progress := Progress + NumRead;
    End;
    CloseFile(FromF);
    CloseFile(ToF);
  End;
End;

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

Function LocalIP: String;
Type
  TaPInAddr = Array[0..10] Of PInAddr;
  PaPInAddr = ^TaPInAddr;
Var
  phe: PHostEnt;
  pptr: PaPInAddr;
  Buffer: Array[0..63] Of Char;
  I: Integer;
  GInitData: TWSAData;
Begin
  WSAStartup($101, GInitData);
  Result := '';
  GetHostName(Buffer, SizeOf(Buffer));
  phe := GetHostByName(buffer);
  If phe = Nil Then Exit;
  pPtr := PaPInAddr(phe^.h_addr_list);
  I := 0;
  While pPtr^[I] <> Nil Do 
  Begin
    Result := inet_ntoa(pptr^[I]^);
    Inc(I);
  End;
  WSACleanup;
End;

Function IPAddrToName(IPAddr: String): String;
Var
  SockAddrIn: TSockAddrIn;
  HostEnt: PHostEnt;
  WSAData: TWSAData;
Begin
  WSAStartup($101, WSAData);
  SockAddrIn.sin_addr.s_addr := inet_addr(PChar(IPAddr));
  HostEnt := gethostbyaddr(@SockAddrIn.sin_addr.S_addr, 4, AF_INET);
  If HostEnt <> Nil Then 
  Begin
    Result := StrPas(Hostent^.h_name)
  End 
  Else 
  Begin
    Result := '';
  End;
End;

Function RetryCancelDialogDef1(Const Msg: String): Boolean;
Begin
  Result := True;
  If Application.MessageBox(PChar(Msg), PChar(Application.Title),
    MB_ICONWARNING + MB_RETRYCANCEL) = 2 Then
    Result := False;
End;

Function RetryCancelDialogDef2(Const Msg: String): Boolean;
Begin
  Result := True;
  If Application.MessageBox(PChar(Msg), PChar(Application.Title),
    MB_ICONWARNING + MB_RETRYCANCEL + MB_DEFBUTTON2) = 2 Then
    Result := False;
End;

Function GetPYIndexChar(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);
  End;
End;

Function SearchByPYIndexStr(SourceStrs: TStrings; PYIndexStr: String): String;
Label 
  NotFound;
Var
  i, j: Integer;
  hzchar: String;
Begin
  For i := 0 To SourceStrs.Count - 1 Do 
  Begin
    For j := 1 To Length(PYIndexStr) Do 
    Begin
      hzchar := SourceStrs[i][2 * j - 1] + SourceStrs[i][2 * j];
      If (PYIndexStr[j] <> '?') And (UpperCase(PYIndexStr[j]) <> GetPYIndexChar(hzchar)) Then
        Goto NotFound;
    End;
    If Result = '' Then
      Result := SourceStrs[i]
    Else 
      Result := Result + Char(13) + SourceStrs[i];
    NotFound:
  End;
End;

function WeekDay(iYear,iMonth,iDay:Integer):Integer;
begin
  Result:=DayOfWeek(EncodeDate(iYear,iMonth,iDay));
end;

function WeekNum(const TDT:TDateTime):Word;
var
  Y,M,D:Word;
  dtTmp:TDateTime;
begin
  DecodeDate(TDT,Y,M,D);
  dtTmp:=EnCodeDate(Y,1,1);
  Result:=(Trunc(TDT-dtTmp)+(DayOfWeek(dtTmp)-1)) div 7;
  if Result=0 then
    Result:=51
  else
    Result:=Result-1;
end;

function WeekNum(const iYear,iMonth,iDay:Integer):Word;
begin
  Result:=WeekNum(EncodeDate(iYear,iMonth,iDay));
end;

function MonthDays(iYear,iMonth:Integer):Integer;
begin
  case iMonth of
    1,3,5,7,8,10,12: Result:=31;
    4,6,9,11: Result:=30;
    2://如果是闰年
      if IsLeapYear(iYear) then
        Result:=29
      else
        Result:=28
  else
    Result:=0;
  end;
end;

function LunarMonthDays(iLunarYear,iLunarMonth:Integer):Integer;
var
  Height,Low,iBit:Integer;
begin
  if iLunarYear<START_YEAR then
  begin
    Result:=30;
    Exit;
  end;
  Height:=0;
  Low:=29;
  iBit:=16-iLunarMonth;
  if (iLunarMonth>GetLeapMonth(iLunarYear)) and
(GetLeapMonth(iLunarYear)>0) then
    Dec(iBit);
  if (gLunarMonthDay[iLunarYear-START_YEAR] and (1 shl iBit))>0 then
    Inc(Low);
  if iLunarMonth=GetLeapMonth(iLunarYear) then
    if (gLunarMonthDay[iLunarYear-START_YEAR] and (1 shl (iBit-1)))>0 then
      Height:=30
    else
      Height:=29;
  Result:=MakeLong(Low,Height);
end;

function LunarYearDays(iLunarYear:Integer):Integer;
var
  Days,i,tmp:Integer;
begin
  Days:=0;
  for i:=1 to 12 do
  begin
    tmp:=LunarMonthDays(iLunarYear,i);
    Days:=Days+HiWord(tmp);
    Days:=Days+LoWord(tmp);
  end;
  Result:=Days;
end;

function GetLeapMonth(iLunarYear:Integer):Integer;
var
  Flag:Byte;
begin
  Flag:=gLunarMonth[(iLunarYear-START_YEAR) div 2];
  if (iLunarYear-START_YEAR) mod 2=0 then
    Result:=Flag shr 4
  else
    Result:=Flag and $0F;
end;

procedure FormatLunarYear(iYear:Integer;var pBuffer:string);
var
  szText1,szText2,szText3:string;
begin
  szText1:='甲乙丙丁戊己庚辛壬癸';
  szText2:='子丑寅卯辰巳午未申酉戌亥';
  szText3:='鼠牛虎免龙蛇马羊猴鸡狗猪';
  pBuffer:=Copy(szText1,((iYear-4) mod 10)*2+1,2);
  pBuffer:=pBuffer+Copy(szText2,((iYear-4) mod 12)*2+1,2);
  pBuffer:=pBuffer+' ';
  pBuffer:=pBuffer+Copy(szText3,((iYear-4) mod 12)*2+1,2);
  pBuffer:=pBuffer+'年';
end;

function FormatLunarYear(iYear:Integer):string;
var
  pBuffer:string;
begin
  FormatLunarYear(iYear,pBuffer);
  Result:=pBuffer;
end;

procedure FormatMonth(iMonth:Integer;var pBuffer:string;bLunar:Boolean);
var
  szText:string;
begin
  if (not bLunar) and (iMonth=1) then
  begin
    pBuffer:='　一月';
    Exit;
  end;
  szText:='正二三四五六七八九十';
  if iMonth<=10 then
  begin
    pBuffer:='　';
    pBuffer:=pBuffer+Copy(szText,(iMonth-1)*2+1,2);
    pBuffer:=pBuffer+'月';
    Exit;
  end;
  if iMonth=11 then
    pBuffer:='十一'
  else
    pBuffer:='十二';
  pBuffer:=pBuffer+'月';
end;

function FormatMonth(iMonth:Integer;bLunar:Boolean):string;
var
  pBuffer:string;
begin
  FormatMonth(iMonth,pBuffer,bLunar);
  Result:=pBuffer;
end;

procedure FormatLunarDay(iDay:Integer;var pBuffer:string);
var
  szText1,szText2:string;
begin
  szText1:='初十廿三';
  szText2:='一二三四五六七八九十';
  if (iDay<>20) and (iDay<>30) then
  begin
    pBuffer:=Copy(szText1,((iDay-1) div 10)*2+1,2);
    pBuffer:=pBuffer+Copy(szText2,((iDay-1) mod 10)*2+1,2);
  end
  else
  begin
    pBuffer:=Copy(szText1,(iDay div 10)*2+1,2);
    pBuffer:=pBuffer+'十';
  end;
end;

function FormatLunarDay(iDay:Integer):string;
var
  pBuffer:string;
begin
  FormatLunarDay(iDay,pBuffer);
  Result:=pBuffer;
end;

function CalcDateDiff(iEndYear,iEndMonth,iEndDay:Integer;iStartYear:Integer;iStartMonth:Integer;iStartDay:Integer):Integer;
begin
  Result:=Trunc(EncodeDate(iEndYear,iEndMonth,iEndDay)-EncodeDate(iStartYear, iStartMonth, iStartDay));
end;

function CalcDateDiff(EndDate,StartDate:TDateTime):Integer;
begin
  Result:=Trunc(EndDate-StartDate);
end;

function GetLunarDate(iYear,iMonth,iDay:Integer;var iLunarYear,iLunarMonth,iLunarDay:Integer):Integer;
begin
  l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(iYear,iMonth ,iDay));
  Result:=l_GetLunarHolDay(iYear,iMonth,iDay);
end;

procedure GetLunarDate(InDate:TDateTime;var iLunarYear,iLunarMonth,iLunarDay:Integer);
begin
  l_CalcLunarDate(iLunarYear,iLunarMonth,iLunarDay,CalcDateDiff(InDate,EncodeDate(START_YEAR,1,1)));
end;

function GetLunarHolDay(InDate:TDateTime):string;
var
  i:Integer;
  iYear,iMonth,iDay:Word;
begin
  DecodeDate(InDate,iYear,iMonth,iDay);
  i:=l_GetLunarHolDay(iYear,iMonth,iDay);
  case i of
    1:Result:='小寒';
    2:Result:='大寒';
    3:Result:='立春';
    4:Result:='雨水';
    5:Result:='惊蛰';
    6:Result:='春分';
    7:Result:='清明';
    8:Result:='谷雨';
    9:Result:='立夏';
    10:Result:='小满';
    11:Result:='芒种';
    12:Result:='夏至';
    13:Result:='小暑';
    14:Result:='大暑';
    15:Result:='立秋';
    16:Result:='处暑';
    17:Result:='白露';
    18:Result:='秋分';
    19:Result:='寒露';
    20:Result:='霜降';
    21:Result:='立冬';
    22:Result:='小雪';
    23:Result:='大雪';
    24:Result:='冬至';
  else
    Result:='';
  end;
end;

function GetLunarHolDay(iYear,iMonth,iDay:Integer):string;
begin
  Result:=GetLunarHolDay(EncodeDate(iYear,iMonth,iDay));
end;

procedure l_CalcLunarDate(var iYear,iMonth,iDay:Integer;iSpanDays:Longint);
var
  tmp:Longint;
begin
  //阳历1901年2月19日为阴历1901年正月初一
  //阳历1901年1月1日到2月19日共有49天
  if iSpanDays<49 then
  begin