delphi 万年历

轉貼萬年曆 <原始碼>

{ $HDR$}
{**********************************************************************}
{ Unit archived using Team Coherence        }
{ Team Coherence is Copyright 2001 by Quality Software Components    }
{        }
{ For further information / comments, visit our WEB site at        }
{ http://www.TeamCoherence.com        }
{**********************************************************************}
{}
{ $Log: 10065: CAL.pas
{
{ Rev 1.0    2001/12/24 下午 05:53:06 levi    Version: 2.0.0.0
}
{
{ Rev 1.0    2001/12/24 下午 05:53:06 levi
{ 為函數集 為改版後目前為1.2.0.1
}
{* =================================Blue Fox================================= *}
{* 單 元 名 稱：cal        
{* 建 檔 日 期：2001/1/24
{* 檔 案 製 作：彭宏傑
{* =================================Blue Fox================================= *}
{* 附 屬 檔 案：
{* 說 明&用 途：取得或轉換國曆與農曆合而為一之月曆
{*
{* 參 考 資 料：
{*
{* 更 新 說 明：
{*
{* =================================Blue Fox================================= *}
{*    不要覺得註解長，註解是給以後的你或別人看的，請保持註解的完整性        *}
{* =======================================================================2.0 *}
{* 注解說明：        *}
{*        1. 在程式敘述中加入注解 格式為        *}
{*        // @ 程式師, 修改日期,工作模式, 修改描述        *}
{*        例如 // @levi,01/12/21,Add,取得日期。        *}        
{*        而工作模式有 Add,A 為新增敘述 ;        *}        
{*        Edit,E 為修改舊有敘述;        *}        
{*        Make,M 為刪除但不能將敘述刪除而是改變為注解;    *}        
{*        O    為其它不在上面的模式;        *}        
{*        2. 在宣告程序的後方必加入本程序的功能說明用 // 為注解符號。    *}        
{* ========================================================================== *}
//以下為舊說明
{
    國曆與農曆合而為一之月曆. (不用Delpi 3.0 中文應用組件)
    (範圍 : 民國一年至民國一百年)

    新增 Property :
        LYear : 農曆之民國年份
        LMonth : 農曆之月份(負數為閏月)
        LDay : 農曆之天數
        LYearName : 農曆之六十甲子名稱(readonly)

    作者: 彭宏傑
    E-Mail : [e-mail]

    此版本為 FreeWare, 可自由散播, 但儘量保持其完整性, 如有Bug請E-Mail給我,
    如您要更改也請E-Mail一份給我. OK! :)
}
unit cal;

interface

uses Classes, Controls, Messages, Windows, Forms, Graphics, StdCtrls,
    Grids, SysUtils, Lunar;

type
    TDayOfWeek = 0..6;

    TRexCalendar = class(TCustomGrid)
    private
    FDate: TDateTime;
    FMonthOffset: Integer;
    FOnChange: TNotifyEvent;
    FReadOnly: Boolean;
    FStartOfWeek: TDayOfWeek;
    FUpdating: Boolean;
    FUseCurrentDate: Boolean;
    FLYear: integer;
    FLMonth: Integer;
    FLDay: Integer;
    FLYearName : String;
    function GetCellText(ACol, ARow: Integer): string;
    function GetDateElement(Index: Integer): Integer;
    procedure SetCalendarDate(Value: TDateTime);
    procedure SetDateElement(Index: Integer; Value: Integer);
    procedure SetStartOfWeek(Value: TDayOfWeek);
    procedure SetUseCurrentDate(Value: Boolean);
    procedure SetLDay(Value : Integer);
    function GetLDay: Integer;
    procedure SetLMonth(Value: Integer);
    function GetLMonth : Integer;
    procedure SetLYear(Value: Integer);
    function GetLYear : Integer;
    function StoreCalendarDate: Boolean;
    function GetLYearName : string;
    function GToL(y, m , d: integer) : string;
    protected
    procedure Change; dynamic;
    procedure ChangeMonth(Delta: Integer);
    procedure Click; override;
    function DaysPerMonth(AYear, AMonth: Integer): Integer; virtual;
    function DaysThisMonth: Integer; virtual;
    procedure DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState); override;
    function IsLeapYear(AYear: Integer): Boolean; virtual;
    function SelectCell(ACol, ARow: Longint): Boolean; override;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    public
    constructor Create(AOwner: TComponent); override;
    property CalendarDate: TDateTime read FDate write SetCalendarDate stored StoreCalendarDate;
    property CellText[ACol, ARow: Integer]: string read GetCellText;
    procedure NextMonth;
    procedure NextYear;
    procedure PrevMonth;
    procedure PrevYear;
    procedure UpdateCalendar; virtual;
    published
    property Align;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property Day: Integer index 3 read GetDateElement write SetDateElement stored False;
    property LDay: integer read GetLDay write SetLDay;
    property LYearName : string read GetLYearName;
    property Enabled;
    property Font;
    property GridLineWidth;
    property Month: Integer index 2 read GetDateElement write SetDateElement stored False;
    property LMonth: Integer read GetLMonth write SetLMonth;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly: Boolean read FReadOnly write FReadOnly default False;
    property ShowHint;
    property StartOfWeek: TDayOfWeek read FStartOfWeek write SetStartOfWeek;
    property TabOrder;
    property TabStop;
    property UseCurrentDate: Boolean read FUseCurrentDate write SetUseCurrentDate default True;
    property Visible;
    property Year: Integer index 1 read GetDateElement write SetDateElement stored False;
    property LYear: integer read GetLYear write SetLYear;
    property forbidden;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property forbidden;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property forbidden;
    property forbidden;
    property forbidden;
    property OnStartDrag;
    end;

procedure Register;

implementation

constructor TRexCalendar.Create(AOwner: TComponent);
var
    AYear, AMonth, ADay : Word;
    //daterec : Tdaterec;
begin
    inherited Create(AOwner);
    { defaults }
    FUseCurrentDate := True;
    FixedCols := 0;
    FixedRows := 1;
    ColCount := 7;
    RowCount := 7;
    ScrollBars := ssNone;
    Options := Options - [goRangeSelect] + [goDrawFocusSelected];
    Font.Name := '細明體';
    Font.Size := 12;
    FDate := Date;
    decodedate(FDate, AYear, AMonth, ADay);
    {daterec.GregYear := AYear;
    daterec.wMonth := AMonth;
    daterec.wDay := ADay;
    if GregorianToLunarDate(@daterec) then begin
    FLYear := LunarYearName(daterec.LunarYear);
    FLMonth := daterec.wMonth;
    FLDay := daterec.wDay;
    end;}
    Solar2Lunar(AYear-1911, AMonth, ADay, FLYear, FLMonth, FLDay);
    UpdateCalendar;
end;

procedure TRexCalendar.Change;
begin
    if Assigned(FOnChange) then FOnChange(Self);
end;

function CutStr(const str : string) : integer;
var
    i : integer;
begin
    for i := 1 to length(str) do
        if str[i] > #127 then
        break;
    result := i;
end;

procedure TRexCalendar.Click;
var
    TheCellText: string;
    P: integer;
begin
    inherited Click;
    TheCellText := CellText[Col, Row];
    P := CutStr(TheCellText);
    TheCellText := Copy(TheCellText, 1, P-1);
    if TheCellText <> '' then Day := StrToInt(TheCellText);
end;

function TRexCalendar.IsLeapYear(AYear: Integer): Boolean;
begin
    Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;

function TRexCalendar.DaysPerMonth(AYear, AMonth: Integer): Integer;
const
    DaysInMonth: array[1..12] of Integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
    Result := DaysInMonth[AMonth];
    if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;

function TRexCalendar.DaysThisMonth: Integer;
begin
    Result := DaysPerMonth(Year, Month);
end;

procedure TRexCalendar.DrawCell(ACol, ARow: Longint; ARect: TRect; AState: TGridDrawState);
var
    LText: string;
    TheText: string;
    P, fs : integer;
    cl : TColor;
begin
    TheText := CellText[ACol, ARow];
    if ARow <> 0 then begin
    P := CutStr(TheText);
    LText := copy(Thetext, P, Length(TheText)-P+1);
    TheText := Copy(TheText, 1, P-1);
    end;
    cl := Canvas.Font.Color;
    if ACol = ((7-FStartOfWeek) mod 7) then
    Canvas.Font.Color := clRed
    else
    Canvas.Font.Color := cl;
    with ARect, Canvas do begin
    if ARow = 0 then begin
        TextRect(ARect, Left + (Right - Left - TextWidth(TheText)) div 2,
        Top + (Bottom - Top - TextHeight(TheText)) div 2, TheText);
    end else begin
    fs := Font.Size;
    TextOut(Left + 2, Top + 2, TheText);
    Font.Size := fs div 2;
    TextOut(Right-TextWidth(LText)-2, Bottom-TextHeight(LText)-2, LText);
    Font.Size := fs;
    end;
    end;
end;

function TRexCalendar.GToL(y, m, d : integer): string;
const
    LDayName : array[1..30] of string = ('初一', '初二', '初三', '初四', '初五', '初六', '初七', '初八', '初九', '初十',
        '十一', '十二', '十三', '十四', '十五', '十六', '十七', '十八', '十九', '二十',
        '廿一', '廿二', '廿三', '廿四', '廿五', '廿六', '廿七', '廿八', '廿九', '三十');
    LMonthName : array[1..12] of string = ('正月', '二月', '三月', '四月', '五月', '六月', '七月', '八月', '九月', '十月', '十一月', '十二月');
var
    //daterec : TDaterec;
    ly, lm, ld : integer;
begin
    //daterec.GregYear := y;
    //daterec.wMonth := m;
    //daterec.wDay := d;
    Solar2Lunar(y-1911, m, d, ly, lm, ld);
    //if GregorianToLunarDate(@daterec) then begin
        if ld = 1 then begin
        if lm < 0 then
        result := '閏';
        result := result + LMonthName[abs(lm)]
        end else
        result := LDayName[ld];
    //end;
end;

function TRexCalendar.GetCellText(ACol, ARow: Integer): string;
var
    DayNum: Integer;
begin
    if ARow = 0 then { day names at tops of columns }
    Result := ShortDayNames[(StartOfWeek + ACol) mod 7 + 1]
    else
    begin
    DayNum := FMonthOffset + ACol + (ARow - 1) * 7;
    if (DayNum < 1) or (DayNum > DaysThisMonth) then Result := ''
    else Result := IntToStr(DayNum)+GToL(year, month, DayNum);
    end;
end;

function TRexCalendar.SelectCell(ACol, ARow: Longint): Boolean;
begin
    if ((not FUpdating) and FReadOnly) or (CellText[ACol, ARow] = '') then
    Result := False
    else Result := inherited SelectCell(ACol, ARow);
end;

{function DaysPerLunarMonth(GYear, LYear, AMonth: Integer): Integer;
var
    daterec: TDateRec;
begin
    daterec.GregYear := GYear;
    daterec.LunarYear := LYear;
    daterec.wMonth := AMonth;
    daterec.wDay := 0;
    Result := DaysInLunarMonth(@daterec);
end;}

function TRexCalendar.GetLYearName : string;
begin
    result := YearName(FLYear);
end;

procedure TRexCalendar.SetLDay(Value: integer);
var
    //daterec : Tdaterec;
    sy, sm, sd : integer;
begin
    if Value > DaysPerLunarMonth(FLyear, FLMonth) then
        exit
    else
        FLDay := Value;
    //FDate := EncodeLunarDate(Year, LunarYearNameToNumeric(FLYear), FLMonth, FLDay);
    {daterec.GregYear := Year;
    daterec.LunarYear := LunarYearNameToNumeric(FLYear);
    daterec.wMonth := FLMonth;
    daterec.wDay := FLDay;
    if LunarToGregorianDate(@daterec) then
        FDate := EncodeDate(daterec.GregYear, daterec.wMonth, daterec.wDay);
    }
    Lunar2Solar(FLYear, FLMonth, FLDay, SY, SM, SD);
    FDate := StrToDate(Format('%.4d/%.2d/%.2d', [sy+1911, sm, sd]));
    UpdateCalendar;
    Change;
end;

function TRexCalendar.GetLDay: integer;
var
    //daterec : Tdaterec;
    AYear, AMonth, ADay : Word;
begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    //DecodeLunarDate(FDate, LY, LM, LD);
    {daterec.GregYear := AYear;
    daterec.wMonth := AMonth;
    daterec.wDay := ADay;
    if GregorianToLunarDate(@daterec) then begin
        result := daterec.wDay;
        FLYear := LunarYearName(daterec.LunarYear);
    end;}
    Solar2Lunar(AYear-1911, AMonth, ADay, FLYear, FLMonth, FLDay);
    result := FLDay;
end;

procedure TRexCalendar.SetLMonth(Value: Integer);
var
    //daterec : Tdaterec;
    sy, sm, sd : integer;
begin
    if Value > 12 then exit else FLMonth := Value;
    //FDate := EncodeLunarDate(Year, LunarYearNameToNumeric(FLYear), FLMonth, FLDay);
    {daterec.GregYear := Year;
    daterec.LunarYear := LunarYearNameToNumeric(FLYear);
    daterec.wMonth := FLMonth;
    daterec.wDay := FLDay;
    if LunarToGregorianDate(@daterec) then
        FDate := EncodeDate(daterec.GregYear, daterec.wMonth, daterec.wDay);}
    Lunar2Solar(FLYear, FLMonth, FLDay, SY, SM, SD);
    FDate := StrToDate(Format('%.4d/%.2d/%.2d', [sy+1911, sm, sd]));
    UpdateCalendar;
    Change;
end;

function TRexCalendar.GetLMonth: Integer;
var
    //daterec : Tdaterec;
    AYear, AMonth, ADay : Word;
begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    //DecodeLunarDate(FDate, LY, LM, LD);
    {daterec.GregYear := AYear;
    daterec.wMonth := AMonth;
    daterec.wDay := ADay;
    if GregorianToLunarDate(@daterec) then begin
        result := daterec.wMonth;
        FLYear := LunarYearName(daterec.LunarYear);
    end;}
    Solar2Lunar(AYear-1911, AMonth, ADay, FLYear, FLMonth, FLDay);
    result := FLMonth;
end;

procedure TRexCalendar.SetLYear(Value: Integer);
var
    //daterec : Tdaterec;
    sy, sm, sd : integer;
begin
    if (Value > 100) and (Value < 1) then exit else FLYear := Value;
    //FDate := EncodeLunarDate(Year, LunarYearNameToNumeric(FLYear), FLMonth, FLDay);
    {daterec.GregYear := Year;
    daterec.LunarYear := LunarYearNameToNumeric(FLYear);
    daterec.wMonth := FLMonth;
    daterec.wDay := FLDay;
    if LunarToGregorianDate(@daterec) then
        FDate := EncodeDate(daterec.GregYear, daterec.wMonth, daterec.wDay);}
    Lunar2Solar(FLYear, FLMonth, FLDay, SY, SM, SD);
    FDate := StrToDate(Format('%.4d/%.2d/%.2d', [sy+1911, sm, sd]));
    UpdateCalendar;
    Change;
end;

function TRexCalendar.GetLYear: Integer;
var
    //daterec : Tdaterec;
    AYear, AMonth, ADay : Word;
begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    //DecodeLunarDate(FDate, LY, LM, LD);
    {daterec.GregYear := AYear;
    daterec.wMonth := AMonth;
    daterec.wDay := ADay;
    if GregorianToLunarDate(@daterec) then begin
        result := daterec.wMonth;
        FLYear := LunarYearName(daterec.LunarYear);
    end;}
    Solar2Lunar(AYear-1911, AMonth, ADay, FLYear, FLMonth, FLDay);
    result := FLYear;
end;

procedure TRexCalendar.SetCalendarDate(Value: TDateTime);
var
    AYear, AMonth, ADay : Word;
    //daterec : TDateRec;
begin
    FDate := Value;
    DecodeDate(FDate, AYear, AMonth, ADay);
    {daterec.GregYear := AYear;
    daterec.wMonth := AMonth;
    daterec.wDay := ADay;
    if GregorianToLunarDate(@daterec) then begin
    FLYear := LunarYearName(daterec.LunarYear);
    FLMonth := daterec.wMonth;
    FLDay := daterec.wDay;
    end;}
    Solar2Lunar(AYear-1911, AMonth, ADay, FLYear, FLMonth, FLDay);
    UpdateCalendar;
    Change;
end;

function TRexCalendar.StoreCalendarDate: Boolean;
begin
    Result := not FUseCurrentDate;
end;

function TRexCalendar.GetDateElement(Index: Integer): Integer;
var
    AYear, AMonth, ADay: Word;
begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    case Index of
    1: Result := AYear;
    2: Result := AMonth;
    3: Result := ADay;
    else Result := -1;
    end;
end;

procedure TRexCalendar.SetDateElement(Index: Integer; Value: Integer);
var
    AYear, AMonth, ADay: Word;
begin
    if Value > 0 then
    begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    case Index of
        1: if AYear <> Value then AYear := Value else Exit;
        2: if (Value <= 12) and (Value <> AMonth) then AMonth := Value else Exit;
        3: if (Value <= DaysThisMonth) and (Value <> ADay) then ADay := Value else Exit;
        else Exit;
    end;
    FDate := EncodeDate(AYear, AMonth, ADay);
    FUseCurrentDate := False;
    UpdateCalendar;
    Change;
    end;
end;

procedure TRexCalendar.SetStartOfWeek(Value: TDayOfWeek);
begin
    if Value <> FStartOfWeek then
    begin
    FStartOfWeek := Value;
    UpdateCalendar;
    end;
end;

procedure TRexCalendar.SetUseCurrentDate(Value: Boolean);
begin
    if Value <> FUseCurrentDate then
    begin
    FUseCurrentDate := Value;
    if Value then
    begin
        FDate := Date; { use the current date, then }
        UpdateCalendar;
    end;
    end;
end;

{ Given a value of 1 or -1, moves to Next or Prev month accordingly }
procedure TRexCalendar.ChangeMonth(Delta: Integer);
var
    AYear, AMonth, ADay: Word;
    NewDate: TDateTime;
    CurDay: Integer;
begin
    DecodeDate(FDate, AYear, AMonth, ADay);
    CurDay := ADay;
    if Delta > 0 then ADay := DaysPerMonth(AYear, AMonth)
    else ADay := 1;
    NewDate := EncodeDate(AYear, AMonth, ADay);
    NewDate := NewDate + Delta;
    DecodeDate(NewDate, AYear, AMonth, ADay);
    if DaysPerMonth(AYear, AMonth) > CurDay then ADay := CurDay
    else ADay := DaysPerMonth(AYear, AMonth);
    CalendarDate := EncodeDate(AYear, AMonth, ADay);
end;

procedure TRexCalendar.PrevMonth;
begin
    ChangeMonth(-1);
end;

procedure TRexCalendar.NextMonth;
begin
    ChangeMonth(1);
end;

procedure TRexCalendar.NextYear;
begin
    if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
    Year := Year + 1;
end;

procedure TRexCalendar.PrevYear;
begin
    if IsLeapYear(Year) and (Month = 2) and (Day = 29) then Day := 28;
    Year := Year - 1;
end;

procedure TRexCalendar.UpdateCalendar;
var
    AYear, AMonth, ADay: Word;
    FirstDate: TDateTime;
begin
    FUpdating := True;
    try
    DecodeDate(FDate, AYear, AMonth, ADay);
    FirstDate := EncodeDate(AYear, AMonth, 1);
    FMonthOffset := 2 - ((DayOfWeek(FirstDate) - StartOfWeek + 7) mod 7); { day of week for 1st of month }
    if FMonthOffset = 2 then FMonthOffset := -5;
    MoveColRow((ADay - FMonthOffset) mod 7, (ADay - FMonthOffset) div 7 + 1,
        False, False);
    Invalidate;
    finally
    FUpdating := False;
    end;
end;

procedure TRexCalendar.WMSize(var Message: TWMSize);
var
    GridLines: Integer;
begin
    GridLines := 6 * GridLineWidth;
    DefaultColWidth := (Message.Width - GridLines) div 7;
    DefaultRowHeight := (Message.Height - GridLines) div 7;
end;

procedure Register;
begin
    RegisterComponents('中文專用', [TRexCalendar]);
end;

end.
================================

{* =================================Blue Fox================================= *}
{* 單 元 名 稱：Lunar        
{* 建 檔 日 期：2001/12/21 加入說明檔頭
{* 檔 案 製 作：Levi        
{* =================================Blue Fox================================= *}
{* 附 屬 檔 案：
{* 說 明&用 途：國曆與農曆互相轉換的相關函數集
{*
{* 參 考 資 料：
{*
{* 更 新 說 明：
{*    01/12/15 1.準備增加關節氣，干支，生肖
{*        2.在程式中因作者使用常數給值的方式在D6中是不可以的此BUG要找時間處理
{*
{* =================================Blue Fox================================= *}
{*    不要覺得註解長，註解是給以後的你或別人看的，請保持註解的完整性        *}
{* =======================================================================2.0 *}
{* 注解說明：        *}
{*        1. 在程式敘述中加入注解 格式為        *}
{*        // @ 程式師, 修改日期,工作模式, 修改描述        *}
{*        例如 // @levi,01/12/21,Add,取得日期。        *}        
{*        而工作模式有 Add,A 為新增敘述 ;        *}        
{*        Edit,E 為修改舊有敘述;        *}        
{*        Make,M 為刪除但不能將敘述刪除而是改變為注解;    *}        
{*        O    為其它不在上面的模式;        *}        
{*        2. 在宣告程序的後方必加入本程序的功能說明用 // 為注解符號。    *}        
{* ========================================================================== *}
//以下為舊說明
{
    這是一個國曆與農曆互相轉的Unit.

    其中年份皆用民國年份, 請自行轉換 (西元年-1911 = 民國年).
    ***************************************************************************
    *國農曆對映表之說明 :        *
    ***************************************************************************
    * 前二數字 = 閏月月份, 如果為 13 則沒有閏月        *
    * 第三至第六數字 = 12 個月之大小月之2進位碼->10進位        *
    * 例如:        *
    *    101010101010 = 2730        *
    *    1 : 代表大月(30天) 0 : 代表小月(29天) ==> 1月大2月小3月大.....    *
    * 第七位數字為閏月天數        *
    *        0 : 沒有閏月之天數        *
    *        1 : 閏月為小月(29天)        *
    *        2 : 閏月為大月(30天)        *
    * 最後2位數字代表陽曆之1月1日與陰曆之1月1日相差天數        *
    ***************************************************************************
    這對映表只有民國一年至民國一百年, 如不敷您的使用請按照上述之方式自行增加.

    這個程式沒有判斷您所輸入之年,月,日是否正確, 請自行判斷.

    如果轉換出來之農曆的月份是閏月則傳給您的值是***負數***
    如果農曆要轉換國曆如果是閏月請輸入***負數***

    此版本為FreeWare Version : 0.1
    您可以自行修改, 但最好可以將修改過之程式Mail一份給我.
    如果您要用於商業用途, 請mail給我告知您的用途及原因.

    作者 : 彭宏傑
    E-Mail : [e-mail]
}
unit Lunar;

interface
uses SysUtils;

//國曆轉農曆(民國年, 月, 日, var 農曆年, 農曆月, 農曆日)
procedure Solar2Lunar(SYear, SMonth, SDay: Integer; var LYear, LMonth, LDay: Integer);
//農曆轉國曆(農曆年, 農曆月, 農曆日, var 民國年, 月, 日)
procedure Lunar2Solar(LYear, LMonth, LDay: Integer; var SYear, SMonth, SDay: Integer);
//輸入農曆年份換算六十甲子名稱
function YearName(LYear: integer): string;
//得知農曆之月份天數
function DaysPerLunarMonth(LYear, LMonth: Integer): Integer;

implementation
const
    SMDay: array[1..12] of integer = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
    c1: array[1..10] of string[2] = ('甲', '乙', '丙', '丁', '戊', '己', '庚', '辛', '壬', '癸');
    c2: array[1..12] of string[2] = ('子', '丑', '寅', '卯', '辰', '巳', '午', '未', '申', '酉', '戌', '亥');

// Magic String :
    LongLife: array[1..100] of string[9] = (
    '132637048', '133365036', '053365225', '132900044', '131386034', '022778122', //6
    '132395041', '071175231', '131175050', '132635038', '052891127', '131701046', //12
    '131748035', '042741223', '130694043', '132391032', '021327122', '131175040', //18
    '061623129', '133402047', '133402036', '051769125', '131453044', '130694034', //24
    '032158223', '132350041', '073213230', '133221049', '133402038', '063466226', //30
    '132901045', '131130035', '042651224', '130605043', '132349032', '023371121', //36
    '132709040', '072901128', '131738047', '132901036', '051333226', '131210044', //42
    '132651033', '031111223', '131323042', '082714130', '133733048', '131706038', //48
    '062794127', '132741045', '131206035', '042734124', '132647043', '131318032', //54
    '033878120', '133477039', '071461129', '131386047', '132413036', '051245126', //60
    '131197045', '132637033', '043405122', '133365041', '083413130', '132900048', //66
    '132922037', '062394227', '132395046', '131179035', '042711124', '132635043', //72
    '102855132', '131701050', '131748039', '062804128', '132742047', '132359036', //78
    '051199126', '131175045', '131611034', '031866122', '133749040', '081717130', //84
    '131452049', '132742037', '052413127', '132350046', '133222035', '043477123', //90
    '133402042', '133493031', '021877121', '131386039', '072747128', '130605048', //96
    '132349037', '053243125', '132709044', '132890033');

var
    LMDay: array[1..13] of integer;
    InterMonth, InterMonthDays, SLRangeDay: integer;


function IsLeapYear(AYear: Integer): Boolean;
begin
    Result := (AYear mod 4 = 0) and ((AYear mod 100 <> 0) or (AYear mod 400 = 0));
end;

function YearName(LYear: integer): string;
var
    x, y, ya: integer;
begin
    ya := LYear;
    if ya < 1 then
    ya := ya + 1;
    if ya < 12 then
    ya := ya + 60;
    x := (ya + 8 - ((ya + 7) div 10) * 10);
    y := (ya - ((ya - 1) div 12) * 12);
    result := c1[x] + c2[y];
end;

procedure CovertLunarMonth(magicno: integer);
var
    i, size, m: integer;
begin
    m := magicno;
    for i := 12 downto 1 do begin
        size := m mod 2;
        if size = 0 then
        LMDay[i] := 29
        else
        LMDay[i] := 30;
        m := m div 2;
    end;
end;

procedure ProcessMagicStr(yy: integer);
var
    magicstr: string;
    dsize, LunarMonth: integer;
begin
    magicstr := LongLife[yy];
    InterMonth := StrToInt(Copy(magicstr, 1, 2));
    LunarMonth := StrToInt(copy(magicstr, 3, 4));
    CovertLunarMonth(LunarMonth);
    dsize := StrToInt(Copy(magicstr, 7, 1));
    case dsize of
    0: InterMonthDays := 0;
    1: InterMonthDays := 29;
    2: InterMonthDays := 30;
    end;
    SLRangeDay := StrToInt(Copy(Magicstr, 8, 2));
end;

function DaysPerLunarMonth(LYear, LMonth: Integer): Integer;
begin
    ProcessMagicStr(LYear);
    if LMonth < 0 then
    Result := InterMonthDays
    else
    Result := LMDay[LMonth];
end;

procedure Solar2Lunar(SYear, SMonth, SDay: integer; var LYear, LMonth, LDay: integer);
var
    i, day: integer;
begin
    day := 0;
    if isLeapYear(SYear + 1911) then //判斷是否為閏年        011205 levi C
    SMDay[2] := 29;
    ProcessMagicStr(SYear);
    if SMonth = 1 then
    day := SDay
    else
    begin
        for i := 1 to SMonth - 1 do
        day := day + SMDay[i];
        day := day + SDay;
    end;
    if day <= SLRangeDay then
    begin
        day := day - SLRangeDay;
        processmagicstr(SYear - 1);
        for i := 12 downto 1 do
        begin
        day := day + LMDay[i];
        if day > 0 then
        break;
        end;
        LYear := SYear - 1;
        LMonth := i;
        LDay := day;
    end
    else
    begin
        day := day - SLRangeDay;
        for i := 1 to InterMonth - 1 do begin
        day := day - LMDay[i];
        if day <= 0 then
        break;
        end;
        if day <= 0 then
        begin
        LYear := SYear;
        LMonth := i;
        LDay := day + LMDay[i];
        end
        else
        begin
        day := day - LMDay[InterMonth];
        if day <= 0 then begin
        LYear := SYear;
        LMonth := InterMonth;
        LDay := day + LMDay[InterMonth];
        end
        else
        begin
        LMDay[InterMonth] := InterMonthDays;
        for i := InterMonth to 12 do begin
        day := day - LMDay[i];
        if day <= 0 then
        break;
        end;
        if i = InterMonth then
        LMonth := 0 - InterMonth
        else
        LMonth := i;
        LYear := SYear;
        LDay := day + LMDay[i];
        end;
        end;
    end;
end;

procedure Lunar2Solar(LYear, LMonth, LDay: integer; var SYear, SMonth, SDay: integer);
var
    i, day: integer;
begin
    day := 0;
    SYear := LYear;
    if isLeapYear(SYear + 1911) then //判斷是否為閏年        011205 levi C
    SMDay[2] := 29;
    processmagicstr(SYear);
    if LMonth < 0 then
    day := LMDay[InterMonth];
    if LMonth <> 1 then
    for i := 1 to LMonth - 1 do
        day := day + LMDay[i];
    day := day + LDay + SLRangeDay;
    if (InterMonth <> 13) and (InterMonth < LMonth) then
    day := day + InterMonthDays;
    for i := 1 to 12 do begin
        day := day - SMDay[i];
        if day <= 0 then
        break;
    end;
    if day > 0 then begin
        SYear := SYear + 1;
        if isLeapYear(SYear + 1911) then //判斷是否為閏年        011205 levi C
        SMDay[2] := 29;
        for i := 1 to 12 do begin
        day := day - SMDay[i];
        if day <= 0 then
        break;
        end;
    end;
    //i := i - 1;
    day := day + SMDay[i];
    //if i = 0 then begin
    // i := 12;
    // SYear := SYear - 1;
    // day := day + 31;
    //end;// else
        //day := day + SMDay[i];
    SMonth := i;
    SDay := day;
end;

end.


發表人 - banson1716 於 2003/02/18 18:53:18