lunarcalendar.pas

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

Unit LunarCalendar;
Interface

Uses SysUtils,
  Windows,
  DateUtils,
  Classes,
  StdCtrls,
  Grids,
  Controls,
  UnitBitmapRgn,
  AAFont,
  Graphics,
  Forms,
  Math,
  ExtCtrls,
  LunarObj,
  MacForm,
  Messages;

Type

  TCalendarType = (liSolar, liLunar, liSolarLunar, liLunarSolar);

  TCalendarHint = Class;
  TLunarRec = Packed Record
    iSolarDay,
      iSolarMonth,
      iSolarYear,
      iWeekName,

    iLunarDay,
      iLunarMonth,
      iLunarYear: Integer;

    isMonthLeap,
      isToday,
      isThisMonth,
      isThisYear,
      isWeekEnd: Boolean;

    sEnWeekName,
      sCnWeekName,
      sLongWeekName,

    sLunarYear,
      sLunarMonth,
      sLunarDay,

    sSolarYear,
      sSolarMonth,
      sLongSolarMonth,
      sSolarDay: String;

    solarFestival,
      lunarFestival,
      solarTerm: String;
  End;
  PLunarRec = ^TLunarRec;

  TLunar = Class(TObject)
  Protected
    Procedure init;
  Public
    CalendarValue: Array[1..42] Of TLunarRec;

    Procedure Caculate(aYear, aMonth: Integer);
    Function CaculateToday: TLunarRec;
  End;

  TLunarPanel = Class(TCustomPanel)
  Private
    GridWidth, GridHeight, TopHeight: Integer;
    RectSize: TRect;
    FTodayRec: TLunarRec;
    SFont: TAAFontEx;

    CHint: TCalendarHint;
    Bmp: TBitmap;
    FCalendarType: TCalendarType;
    FDate: TDate;

    FLunar: TLunar;

    FBackFont,
      FSolarFont,
      FLunarFont,
      FWeekFont: TFont;

    FEnWeekName,
      FShowGrid,
      FShowBorder,
      FShowMonth: Boolean;

    FBorderColor,
      FTermColor,
      FTodayColor,
      FGridColor,
      FWeekEndColor: TColor;

    OldPos: Integer;
    Procedure Swap(Var oss, osl: String);
    Procedure SwapFont(Var ofs, ofl: TFont);
  Protected
    Procedure MouseLeave(Var Msg: TMessage); Message CM_MOUSELEAVE;
    Procedure PaintBmp(ABmp: TBitmap);
    Procedure SetBackFont(Value: TFont);
    Procedure SetBorderColor(Value: TColor);
    Procedure SetCalendarType(Value: TCalendarType);
    Procedure SetEnWeekName(Value: Boolean);
    Procedure SetLunarFont(Value: TFont);
    Procedure SetShowGrid(Value: Boolean);
    Procedure SetShowMonth(Value: Boolean);
    Procedure SetTermColor(Value: TColor);
    Procedure SetTodayColor(Value: TColor);
    Procedure SetWeekEndColor(Value: TColor);
    Procedure SetWeekFont(Value: TFont);
    Procedure SetSolarFont(Value: TFont);
    Function PosToRect(X, Y: Integer; Var ARect: TRect): Integer;
    Procedure MouseMove(Shift: TShiftState; X, Y: Integer); Override;
    Procedure CreateWnd; Override;
    Procedure Paint; Override;
    Procedure SetGridColor(Value: TColor);
    Procedure SetShowBorder(Value: Boolean);
    Procedure WMHIDELUNAR(Var Message: TMessage); Message WM_HIDELUNAR;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
    Procedure InvalidateDate;
    Procedure UpdateDate(y, m: WORD); Overload;
    Procedure UpdateDate(ADate: TDate); Overload;
    Procedure UpdateDateNow;
    Function CellValue(APos: integer): PLunarRec;
    Procedure NextMonth;
    Procedure PrevYear;
    Procedure PrevMonth;
    Procedure NextYear;
    Function DrawThis: TBitmap;
    Property Date: TDate Read FDate;
    Property Lunar: TLunar Read FLunar;
    Property TodayRec: TLunarRec Read FTodayRec;
    Property EffectFont: TAAFontEx Read SFont Write SFont;
  Published
    Property BackFont: TFont Read FBackFont Write SetBackFont;
    Property LunarFont: TFont Read FLunarFont Write SetLunarFont;
    Property WeekFont: TFont Read FWeekFont Write SetWeekFont;
    Property SolarFont: TFont Read FSolarFont Write SetSolarFont;

    Property CalendarType: TCalendarType Read FCalendarType Write
      SetCalendarType;

    Property EnWeekName: Boolean Read FEnWeekName Write SetEnWeekName;
    Property ShowGrid: Boolean Read FShowGrid Write SetShowGrid;
    Property ShowMonth: Boolean Read FShowMonth Write SetShowMonth;

    Property BorderColor: TColor Read FBorderColor Write SetBorderColor;
    Property TermColor: TColor Read FTermColor Write SetTermColor;
    Property TodayColor: TColor Read FTodayColor Write SetTodayColor;
    Property WeekEndColor: TColor Read FWeekEndColor Write SetWeekEndColor;
    Property GridColor: TColor Read FGridColor Write SetGridColor;
    Property ShowBorder: Boolean Read FShowBorder Write SetShowBorder;

    Property PopupMenu;
  End;

  TCalendarHint = Class(TCustomControl)
  Private
    FAlpha: Integer;
    FStrings, FNames: TStringlist;
    FMaxNameLen: Integer;
    Procedure CMTextChanged(Var Message: TMessage); Message CM_TEXTCHANGED;
    Procedure SetAlpha(Value: Integer);
    Procedure WMNCHitTest(Var Message: TWMNCHitTest); Message WM_NCHITTEST;
  Protected
    Procedure CreateParams(Var Params: TCreateParams); Override;
    Procedure Paint; Override;
    Procedure SetLayeredAttribs;
  Public
    Constructor Create(AOwner: TComponent); Override;
    Destructor Destroy; Override;
    Procedure SetPosition;
  Published
    Property Alpha: Integer Read FAlpha Write SetAlpha;
  End;

Procedure Register;

Implementation
Uses Main;

Const
  START_YEAR = 1900;
  END_YEAR = 2100;

Procedure Register;
Begin
  Classes.RegisterComponents('Custom', [TLunarPanel]);
End;

Procedure TLunar.init;
Var
  i: Integer;
Begin
  For i := Low(CalendarValue) To High(CalendarValue) Do
    With CalendarValue[i] Do
    Begin
      iLunarDay := 0;
      iLunarMonth := 0;
      iLunarYear := 0;
      iWeekName := 0;

      iSolarDay := 0;
      iSolarMonth := 0;
      iSolarYear := 0;

      isWeekEnd := False;
      isMonthLeap := false;
      isToday := false;
      isThisMonth := false;
      isThisYear := false;

      sEnWeekName := '';
      sCnWeekName := '';
      sLongWeekName := '';

      sLunarMonth := '';
      sLunarDay := '';
      sLunarYear := '';

      sSolarYear := '';
      sSolarMonth := '';
      sLongSolarMonth := '';
      sSolarDay := '';

      solarTerm := '';
      solarFestival := '';
      lunarFestival := '';
    End;
End;

Procedure TLunar.Caculate(aYear, aMonth: Integer);
Var
  i, p, firstNode: Integer;
  SystemTime: TSystemTime;
  ld: TLunarDate;
Begin
  init;

  GetLocalTime(SystemTime);
  firstNode := WeekDay(aYear, aMonth, 1); //1号为周几

  For i := 1 To MonthDays(aYear, aMonth) Do
  Begin
    p := i + firstNode;

    With CalendarValue[p] Do
    Begin
      iWeekName := WeekDay(aYear, aMonth, i);

      sEnWeekName := WeekEnName(iWeekName);
      sLongWeekName := WeekEnName(iWeekName, true);
      sCnWeekName := WeekCnName(iWeekName);

      isWeekEnd := iWeekName In [6, 7];

      iSolarDay := i;
      sSolarDay := IntToStr(i);

      iSolarMonth := aMonth;

      sSolarMonth := MonthEnName(aMonth);
      sLongSolarMonth := MonthEnName(aMonth, true);

      iSolarYear := aYear;
      sSolarYear := IntToStr(aYear);

      isThisMonth := aMonth = SystemTime.wMonth;
      isThisYear := aYear = SystemTime.wYear;
      isToday := isThisYear And isThisMonth And (i = SystemTime.wDay);

      ld := Lunar(aYear, aMonth, i);

      iLunarYear := ld.Year;
      iLunarMonth := ld.Month;
      iLunarDay := ld.Day;
      isMonthLeap := ld.isLeap;

      sLunarYear := FormatLunarYear(iLunarYear);
      sLunarMonth := FormatLunarMonth(iLunarMonth, isMonthLeap);
      sLunarDay := FormatLunarDay(iLunarDay);

      solarTerm := LunarObj.SolarTerm(aYear, aMonth, i);
      solarFestival := LunarObj.solarFestival(aYear, aMonth, i);
      lunarFestival := LunarObj.lunarFestival(iLunarYear, iLunarMonth,
        iLunarDay);
    End;
  End;
End;

Function TLunar.CaculateToday: TLunarRec;
Var
  y, m, d: word;
  ld: TLunarDate;
Begin
  DecodeDate(Now, y, m, d);

  With Result Do
  Begin
    iWeekName := WeekDay(y, m, d);

    sEnWeekName := WeekEnName(iWeekName);
    sLongWeekName := WeekEnName(iWeekName, true);
    sCnWeekName := WeekCnName(iWeekName);

    isWeekEnd := iWeekName In [1, 7];

    iSolarDay := d;
    sSolarDay := IntToStr(d);

    iSolarMonth := m;

    sSolarMonth := MonthEnName(m);
    sLongSolarMonth := MonthEnName(m, true);

    iSolarYear := y;
    sSolarYear := IntToStr(y);

    isThisMonth := true;
    isThisYear := true;
    isToday := true;

    ld := Lunar(y, m, d);

    iLunarYear := ld.Year;
    iLunarMonth := ld.Month;
    iLunarDay := ld.Day;
    isMonthLeap := ld.isLeap;

    sLunarYear := FormatLunarYear(iLunarYear);
    sLunarMonth := FormatLunarMonth(iLunarMonth, isMonthLeap);
    sLunarDay := FormatLunarDay(iLunarDay);

    solarTerm := LunarObj.SolarTerm(y, m, d);
    solarFestival := LunarObj.solarFestival(y, m, d);
    lunarFestival := LunarObj.lunarFestival(iLunarYear, iLunarMonth, iLunarDay);
  End;
End;

Constructor TLunarPanel.Create(AOwner: TComponent);
Begin
  Inherited Create(AOwner);
  OldPos := -1;

  CHint := TCalendarHint.Create(Self);
  With CHint Do
  Begin
    Parent := Self;
    Hide;
  End;

  FLunar := TLunar.Create;
  FTodayRec := FLunar.CaculateToday;

  FDate := Now;

  GridWidth := 45;
  GridHeight := 36;
  TopHeight := 25;
  FBorderColor := $808080;

  RectSize.Left := 1;
  RectSize.Top := 1;

  RectSize.Right := GridWidth * 7 + 6 + RectSize.Left;
  RectSize.Bottom := (GridHeight + 1) * 6 + TopHeight + RectSize.Top;

  Height := RectSize.Top + RectSize.Bottom;
  Width := RectSize.Right + RectSize.Left;

  FEnWeekName := True;
  FShowGrid := False;
  FShowMonth := True;
  FShowGrid := True;

  FWeekFont := TFont.Create;
  With FWeekFont Do
  Begin
    Size := 12;
    Style := [fsBold];
  End;

  FTodayColor := clLime;
  FWeekEndColor := clRed;
  FGridColor := $C0C0C0;

  FSolarFont := TFont.Create;
  With FSolarFont Do
  Begin
    Size := 12;
    Style := [fsBold];
  End;

  FLunarFont := TFont.Create;

  FBackFont := TFont.Create;
  With FBackFont Do
  Begin
    Color := clYellow;
    Size := 80;
    Style := [fsBold];
  End;

  Bmp := TBitmap.Create;
  With Bmp Do
  Begin
    Height := self.Height;
    Width := self.Width;
  End;

  SFont := TAAFontEx.Create(bmp.Canvas);
  SFont.Quality := aqHigh;
End;

Destructor TLunarPanel.Destroy;
Begin
  FLunar.Free;
  bmp.Free;

  SFont.Free;
  CHint.Free;

  FSolarFont.Free;
  FLunarFont.Free;
  FWeekFont.Free;
  FBackFont.Free;
  Inherited;
End;

Procedure TLunarPanel.InvalidateDate;
Begin
  UpdateDate(FDate);
End;

Procedure TLunarPanel.PaintBmp(ABmp: TBitmap);
Var
  tmpRect: TRect;
  J, h, w, k1, k2, tmp: Integer;
  sz, sz1: TSize;
  s1, s2, tmpStr: String;
  isToday, isWeekEnd, hasTerm: Boolean;
  Value: PLunarRec;

  Procedure DrawGrid;
  Var
    i, p: Integer;
  Begin // $c0c0c0
    With ABmp.Canvas Do
    Begin
      Pen.Color := FGridColor;
      p := RectSize.Left + GridWidth + 1;

      For i := 1 To 6 Do
      Begin
        MoveTo(p, RectSize.Top);
        LineTo(p, RectSize.Bottom);
        Inc(p, (GridWidth + 1));
      End;
      // draw head line
      p := TopHeight + RectSize.Top + 1;
      MoveTo(RectSize.Left, p);
      LineTo(RectSize.Right, p);

      For i := 1 To 5 Do
      Begin
        Inc(p, (GridHeight + 1));
        MoveTo(RectSize.Left, p);
        lineto(RectSize.Right, p);
      End;
    End;
  End;

  Procedure DrawBackground;
  Var
    s: String;
  Begin
    With ABmp.Canvas, ABmp Do
    Begin
      Brush.Color := clWhite;
      FillRect(ClientRect);

      If FShowMonth Then
      Begin
        Font.Assign(FBackFont);

        s := cellvalue(15)^.sSolarYear; // need change
        sz := sFont.TextExtent(s);

        h := (Height - 2 * sz.cy) Div 2;
        w := (Width - sz.cx) Div 2;

        SFont.TextOut(w, h, s);

        s := cellvalue(15)^.sSolarMonth; // need change
        sz := sFont.TextExtent(s);

        h := (Height - 2 * sz.cy) Div 2 + sz.cy;
        w := (Width - sz.cx) Div 2;

        SFont.TextOut(w, h, s);
      End;

      If FShowBorder Then
      Begin
        Brush.Color := FBorderColor;
        FrameRect(ClientRect);
      End;
    End;
  End;

  Procedure DrawWeekName(APos: Integer; ARect: TRect);
  Var
    s: String;
  Begin
    Case FEnWeekName Of
      True: s := WeekEnName(APos);
      False: s := WeekCnName(APos);
    End;

    sz := sFont.TextExtent(s);

    h := (TopHeight - sz.cy) Div 2;
    w := (GridWidth - sz.cx) Div 2;

    SFont.TextOut(ARect.Left + w, ARect.Top + h, s);
  End;

  Procedure DrawCal(ARect: TRect; Sas, Sal: String);
  Var
    tFs, tFl: TFont;
    aColor, aColor1: TColor;
  Begin
    tFs := FSolarFont;
    tFl := FLunarFont;

    aColor := tFs.Color;
    aColor1 := tfl.Color;

    If isWeekEnd Then
      tFs.Color := FWeekEndColor;

    If isToday Then
    Begin
      With ABmp.Canvas Do
      Begin
        Brush.Color := FTodayColor;
        FillRect(ARect);
        DrawFocusRect(ARect);
        Brush.Style := bsClear;
      End;
    End;

    If hasTerm Then
      tFl.Color := FTermColor;

    If FCalendarType In [liLunar, liLunarSolar] Then
    Begin
      Swap(Sas, Sal);
      SwapFont(tFs, tFl);
    End;

    ABmp.Canvas.Font.Assign(tFl);
    sz1 := sFont.TextExtent(sal);
    ABmp.Canvas.Font.Assign(tFs);
    sz := sFont.TextExtent(sas);

    Case FCalendarType Of
      liSolar, liLunar:
        Begin
          h := (GridHeight - sz.cy) Div 2;
          w := (GridWidth - sz.cx) Div 2;
          SFont.TextOut(ARect.Left + w, ARect.Top + h, sas);
        End;
      liSolarLunar, liLunarSolar:
        Begin

          h := (GridHeight - sz.cy - sz1.cy) Div 2;
          w := (GridWidth - sz.cx) Div 2;
          SFont.TextOut(ARect.Left + w, ARect.Top + h, sas);

          w := (GridWidth - sz1.cx) Div 2;
          h := h + sz.cy;
          ABmp.Canvas.Font.Assign(tFl);
          SFont.TextOut(ARect.Left + w, ARect.Top + h, sal);
        End;
    End;
    tFs.Color := aColor;
    tFl.Color := aColor1;
  End;

Begin
  ABmp.Canvas.Brush.Style := bsClear;
  DrawBackground;

  If FShowGrid Then
    DrawGrid;

  ABmp.Canvas.Brush.Style := bsClear;
  ABmp.Canvas.Font.Assign(FWeekFont);
  For j := 0 To 6 Do
  Begin
    tmpRect := Bounds(RectSize.Left + j * (GridWidth + 1), RectSize.Top,
      GridWidth, TopHeight);
    DrawWeekName(j + 1, tmpRect);
  End;

  k1 := 0;
  k2 := 0;
  ABmp.Canvas.Brush.Style := bsClear;
  For j := 1 To 42 Do
  Begin
    tmpRect := Bounds(RectSize.Left + k1 * (GridWidth + 1), RectSize.Top + 2 +
      TopHeight + k2 * (GridHeight + 1), GridWidth, GridHeight);

    Inc(k1);
    If k1 = 7 Then
    Begin
      k1 := 0;
      Inc(k2);
    End;

    Value := CellValue(j);

    tmp := Value^.iSolarDay;
    If tmp = 0 Then
      Continue;

    isToday := Value^.isToday;
    isWeekEnd := Value^.isWeekEnd;

    s1 := Value^.sSolarDay;
    s2 := Value^.sLunarDay;

    If Value^.iLunarDay = 1 Then
      s2 := Value^.sLunarMonth;

    tmpStr := value^.solarTerm;
    hasTerm := tmpStr <> '';
    If hasTerm Then
      s2 := tmpStr;

    DrawCal(tmpRect, s1, s2);
  End;
End;

Procedure TLunarPanel.SetBackFont(Value: TFont);
Begin
  FBackFont.Assign(Value);

  PaintBmp(Bmp);
  Invalidate;
End;

Procedure TLunarPanel.SetBorderColor(Value: TColor);
Begin
  If FBorderColor <> Value Then
  Begin
    FBorderColor := Value;
    PaintBmp(Bmp);
    Invalidate;
  End;
End;

Procedure TLunarPanel.SetCalendarType(Value: TCalendarType);
Begin
  If FCalendarType <> Value Then
  Begin
    FCalendarType := Value;
    PaintBmp(Bmp);
    Invalidate;
  End;
End;

Procedure TLunarPanel.SetEnWeekName(Value: Boolean);
Begin
  If FEnWeekName <> Value Then
  Begin
    FEnWeekName := Value;
    PaintBmp(Bmp);
    Invalidate;
  End;