lunarobj.pas

Clock 桌面时钟 日历 阴历 看到的delphi程序 转发

    offset:= offset - temp;
    inc(i);
  end;

  if (offset = 0) and (leap > 0) and (i = leap + 1) then begin
    if Result.isLeap then
      Result.isLeap:= False
    else begin
      Result.isLeap:= True;
      i:= i - 1;
    end;
  end;

  if offset < 0 then begin
    offset:= offset + temp;
    i:= i - 1;
  end;

  Result.Month:= i;
  Result.Day:= offset + 1;
  
end;

function ChkLunarDate(aDate: TLunarDate): Boolean;
begin
  if (aDate.Year > 2099) or (aDate.Year < 1901) or (aDate.Month > 12) or
  (aDate.Day > 31) then begin
    Result:= False;
    exit;
  end;

  Result:= True;
  if aDate.isLeap then begin
    if leapMonth(aDate.Year) = aDate.Month then begin
      if leapDays(aDate.Year) < aDate.Day then
        Result:= False;
    end else
      Result:= False;
  end else begin
    if lMonthDays(aDate.Year,aDate.Month) < aDate.Day then
      Result:= False;
  end;
end;

function Solar(aDate: TLunarDate): TDate;
var
  i, j, t, leap, temp, offset: integer;
  isLeap: Boolean;
//  y, m: integer;
begin

  Result:= EncodeDate(1,1,1);
  if not ChkLunarDate(aDate) then
    exit;

  isLeap:= False;
  leap:= leapMonth(aDate.Year);

  //本年内从大年初一过来的天数
  offset:= 0;
  i:= 1;
  while i < aDate.Month do begin
    if i = leap then begin
      if isLeap then begin
        temp:= leapDays( aDate.Year );
        isLeap:= False;
      end else begin
        temp:= lMonthDays( aDate.Year , i);
        isLeap:= True;
        i:= i - 1;
      end;
    end else
      temp:= lMonthDays(aDate.Year , i);

    offset:= offset + temp;
    Inc(i);
  end;

  offset:= offset + aDate.Day - 1;
  if (aDate.Month = leap) and aDate.isLeap then  //若为闰月，再加上前一个非闰月天数
    offset:= offset + lMonthDays(aDate.Year , aDate.Month);

  // 该年到 2000.1.1 这几年的天数
  if aDate.Year > 2000 then begin
    i:= 2000;
    j:= aDate.Year - 1;
  end else begin
    i:= aDate.Year;
    j:= 1999;
  end;

  temp:= 0;
  for t:= i to j do begin
    temp:= temp + lYearDays(t);
  end;

  if aDate.Year > 1999 then
    offset:= offset + temp
  else
    offset:= offset - temp;

  //农历二零零零年大年初一的阳历为 2000.2.5
  Result:= incDay(EncodeDate(2000,2,5),offset);
end;

function Lunar(aYear, aMonth, aDay : Word): TLunarDate;
begin
  Result := Lunar(EncodeDate(aYear, aMonth, aDay));
end;

procedure Solar(aDate : TLunarDate ; var aYear, aMonth, aDay : Word);
begin
  DecodeDate(Solar(aDate), aYear, aMonth, aDay);
end;

// 取得指定日期的节气

function SolarTerm(aDate: TDate): string;
var
  y , m, d : Word;
begin
  DecodeDate(aDate , y,m,d);
  Result := SolarTerm( y,m,d);   
end;

function SolarTerm(aYear, aMonth, aDay : Word): string;
var
  jq: Integer;


  //一个节气年的毫秒长度
const jpConst = 31556925974.7;
//===== 某年的第n个节气为几日(从0小寒起算)
function sTerm: Word;
var
  offDate , tmp : Extended;
begin

  offDate := (aYear-1900) ;
  offDate := (jpConst * offDate) / 60000;
  tmp     := sTermInfo[jq] ;
  offDate := offDate + tmp;

  // 必须分开加大为Extended， 否则Delphi作Integer处理

  Result:= dayof(IncMinute(EncodeDateTime(1900,1,6,2,5,0,0), Round(offDate)));
end;

begin
  Result := '';

  jq:= (aMonth - 1) * 2;  
  if aDay = sTerm then
    Result := sTermName[jq]
  else begin
    Inc(jq);
    if aDay = sTerm then
      Result := sTermName[jq]
  end;
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;

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 FormatLunarMonth(iMonth:Integer;var pBuffer:string; bLeapMonth : 
    boolean = false;bLunar:Boolean=True);
var
  szText:string;
begin
  if (not bLunar) and (iMonth=1) then begin
    pBuffer:='一月';
    Exit;
  end;
  
  szText:='正二三四五六七八九十';
  if iMonth<=10 then begin
    pBuffer:=Copy(szText,(iMonth-1)*2+1,2) + '月';

    if bLunar and bLeapMonth then
      pBuffer:='闰' + pBuffer;

    Exit;
  end;

  if iMonth=11 then
    pBuffer:='十一月'
  else
    pBuffer:='十二月';

  if bLunar and bLeapMonth then
    pBuffer:='闰' + pBuffer;
end;

function FormatLunarMonth(iMonth:Integer; bLeapMonth : boolean = false;
    bLunar:Boolean=True): string;
var
  pBuffer:string;
begin
  FormatLunarMonth(iMonth,pBuffer,bLeapMonth, bLunar);
  Result:=pBuffer;
end;

function lunarFestival(aYear, aMonth , aDay:  Integer): string;
begin
  Result := '';
end;

function solarFestival(aYear, aMonth , aDay:  Integer): string;
begin
  Result := '';
end;

function WeekEnName(aWeekDay : Integer ; l : boolean = false): string;
const
  DefShortDayNames: array[1..7] of string = (SShortDayNameSun,
    SShortDayNameMon, SShortDayNameTue, SShortDayNameWed,
    SShortDayNameThu, SShortDayNameFri, SShortDayNameSat);

  DefLongDayNames: array[1..7] of string = (SLongDayNameSun,
    SLongDayNameMon, SLongDayNameTue, SLongDayNameWed,
    SLongDayNameThu, SLongDayNameFri, SLongDayNameSat);
begin
  case l of
    False :
       Result := DefShortDayNames[aWeekDay];
    True :
       Result := DefLongDayNames[aWeekDay];
  end;
end;

function MonthEnName(aMonth : Integer ; l : Boolean = false): string;
const
  DefShortMonthNames: array[1..12] of string = (SShortMonthNameJan,
    SShortMonthNameFeb, SShortMonthNameMar, SShortMonthNameApr,
    SShortMonthNameMay, SShortMonthNameJun, SShortMonthNameJul,
    SShortMonthNameAug, SShortMonthNameSep, SShortMonthNameOct,
    SShortMonthNameNov, SShortMonthNameDec);

  DefLongMonthNames: array[1..12] of string = (SLongMonthNameJan,
    SLongMonthNameFeb, SLongMonthNameMar, SLongMonthNameApr,
    SLongMonthNameMay, SLongMonthNameJun, SLongMonthNameJul,
    SLongMonthNameAug, SLongMonthNameSep, SLongMonthNameOct,
    SLongMonthNameNov, SLongMonthNameDec);

begin
  case l of
    True : Result := DefLongMonthNames[aMonth];
    False: Result := DefShortMonthNames[aMonth];
  end;
end;

function WeekCnName(aWeekDay : Integer ): string;
const
  nStr1 : Array[1..7] of string =('日','一','二','三','四','五','六');
begin
  Result := nStr1[aWeekDay];
end;

function MonthDays(aYear, aMonth : Word): Integer;
begin
  Result := DaysInAMonth(aYear, aMonth);
end;

function WeekDay(aYear, aMonth , aDay:  Integer): Integer;
begin
  //DayOfWeek '日','一','二','三','四','五','六'
  //DayOfTheWeek '一','二','三','四','五','六' ,'日'
  result := DayOfTheWeek(EncodeDate(aYear, aMonth , aDay));
end;

end.