calfunc.pas

以前写的一个利用P2P 技术的一个通讯的例子。里面用到了 DBISAM 、INDY 控件。

         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: Word): Word;
var
   Days, i: Word;
   tmp: Longword;
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;

procedure FormatLunarYear(iYear: Word; 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: Word): string;
var
   pBuffer: string;
begin
   FormatLunarYear(iYear, pBuffer);
   Result := pBuffer;
end;

procedure FormatMonth(iMonth: Word; 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: Word; bLunar: Boolean): string;
var
   pBuffer: string;
begin
   FormatMonth(iMonth, pBuffer, bLunar);
   Result := pBuffer;
end;

procedure FormatLunarDay(iDay: Word; 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: Word): string;
var
   pBuffer: string;
begin
   FormatLunarDay(iDay, pBuffer);
   Result := pBuffer;
end;

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

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

procedure l_CalcLunarDate(var iYear, iMonth, iDay: Word; iSpanDays: Longword);
var
   tmp: Longword;
begin
   //阳历1901年2月19日为阴历1901年正月初一
   //阳历1901年1月1日到2月19日共有49天
   if iSpanDays < 49 then
      begin
         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: Word): Word;
var
   Flag: Byte;
   Day: Word;
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 GetLunarHolDay(InDate: TDateTime): string;
var
   i, 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
         l_CalcLunarDate(iYear, iMonth, iDay, CalcDateDiff(InDate, EncodeDate(START_YEAR, 1, 1)));
         Result := trim(FormatMonth(iMonth) + FormatLunarDay(iDay));
   end;
end;

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

function GetConstellation(const DateTime: TDateTime): Integer;
var
   Y, M, D: Word;
begin
   DecodeDate(DateTime, Y, M, D);
   Y := M * 100 + D;
   if (Y >= 321) and (Y <= 419) then
      Result := 0
   else
      if (Y >= 420) and (Y <= 520) then
      Result := 1
   else
      if (Y >= 521) and (Y <= 620) then
      Result := 2
   else
      if (Y >= 621) and (Y <= 722) then
      Result := 3
   else
      if (Y >= 723) and (Y <= 822) then
      Result := 4
   else
      if (Y >= 823) and (Y <= 922) then
      Result := 5
   else
      if (Y >= 923) and (Y <= 1022) then
      Result := 6
   else
      if (Y >= 1023) and (Y <= 1121) then
      Result := 7
   else
      if (Y >= 1122) and (Y <= 1221) then
      Result := 8
   else
      if (Y >= 1222) or (Y <= 119) then
      Result := 9
   else
      if (Y >= 120) and (Y <= 218) then
      Result := 10
   else
      if (Y >= 219) and (Y <= 320) then
      Result := 11
   else
      Result := -1;
end;

function GetConstellationName(const Constellation: Integer): string;
begin
   case Constellation of
      0: Result := '白羊座';
      1: Result := '金牛座';
      2: Result := '双子座';
      3: Result := '巨蟹座';
      4: Result := '狮子座';
      5: Result := '处女座';
      6: Result := '天秤座';
      7: Result := '天蝎座';
      8: Result := '射手座';
      9: Result := '摩羯座';
      10: Result := '水瓶座';
      11: Result := '双鱼座';
      else
         Result := '';
   end;
end;

function GetConstellationName(const DateTime: TDateTime): string;
begin
   Result := GetConstellationName(GetConstellation(DateTime));
end;

end.