calendarfun.pas

Barcode And LabelPrint

      Result := 0;
  end;
end;

function GetLeapMonth(iLunarYear: Word): Word;
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;

function LunarMonthDays(iLunarYear, iLunarMonth: Word): Longword;
var
  Height, Low: Word;
  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: 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 GetCuurDateInfo: string;
var
  Year, Month, Day, MonthDaynum: Word;
  SpanDays: Longword;
  datestr, jieqi, nianming: string;
begin
  SpanDays := CalcDateDiff(Date, strtodate('1901-01-01'));
  DecodeDate(Date, Year, Month, Day);
  l_CalcLunarDate(Year, Month, Day, SpanDays);
  datestr := intToStr(Year) + '-' + intToStr(Month) + '-' + intToStr(day); //农历
  jieqi := GetLunarHolDay(Date);
  nianming := FormatLunarYear(Year);
  if Length(jieqi) < 8 then Result := nianming + datestr + '  节气:' + jieqi //''
  else Result := nianming + datestr; //'农历： '
end;

end.