lunarcalendar.pas

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

End;

Procedure TLunarPanel.SetLunarFont(Value: TFont);
Begin
  FLunarFont.Assign(Value);
  PaintBmp(Bmp);
  Invalidate;
End;

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

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

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

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

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

Procedure TLunarPanel.SetWeekFont(Value: TFont);
Begin
  FWeekFont.Assign(Value);
  PaintBmp(Bmp);
  Invalidate;
End;

Procedure TLunarPanel.UpdateDate(y, m: WORD);
Var
  tmp: TDate;
Begin

  tmp := EncodeDate(y, m, 1);

  If FDate <> tmp Then
  Begin
    FDate := tmp;
    FLunar.Caculate(y, m);
  End;

  Self.HandleNeeded;
  PaintBmp(Bmp);
  Invalidate;
End;

Procedure TLunarPanel.UpdateDate(ADate: TDate);
Var
  d1, d2, d3: word;
Begin
  DecodeDate(ADate, d1, d2, d3);
  UpdateDate(d1, d2);
End;

Procedure TLunarPanel.UpdateDateNow;
Begin
  UpdateDate(Now);
End;

Procedure TLunarPanel.SetSolarFont(Value: TFont);
Begin
  FSolarFont.Assign(Value);
  PaintBmp(Bmp);
  Invalidate;
End;

Function TLunarPanel.CellValue(APos: integer): PLunarRec;
Begin
  Result := @(FLunar.CalendarValue[APos]);
End;

Procedure TLunarPanel.MouseMove(Shift: TShiftState; X, Y: Integer);
Var
  rt: TRect;
  p: Integer;
  val: PLunarRec;
  s: String;

Begin
  Inherited MouseMove(Shift, X, Y);
  p := PosToRect(X, Y, rt);

  If p = 0 Then
  Begin
    CHint.Hide;
    exit;
  End;

  val := CellValue(p);
  If val^.iSolarDay = 0 Then
  Begin
    CHint.Hide;
    exit;
  End
  Else
    If Not CHint.Visible Then
      CHint.Show;

  If p = OldPos Then
    Exit;

  OldPos := p;
  CHint.SetPosition;

  With val^ Do
  Begin
    s := Format('公元= %d年%d月%d日 星期%s', [iSolarYear, iSolarMonth,
      iSolarDay, sCnWeekName]) + #10 + Format('农历= %d年%d月%d日 %s',
      [iLunarYear, iLunarMonth, iLunarDay, sLunarYear]) + #10 +
      solarTerm;
  End;

  CHint.Caption := s;
End;

Function TLunarPanel.PosToRect(X, Y: Integer; Var ARect: TRect): Integer;
Var
  w, h, YY, XX: Integer;
Begin
  Result := 0;

  YY := RectSize.Top + TopHeight + 1;
  XX := RectSize.Left;
  If Not PtInRect(Bounds(XX, YY, GridWidth * 7 + 6,
    GridHeight * 6 + 5), Point(X, Y)) Then
    Exit;

  YY := Y - YY;
  XX := X - XX;
  w := XX Div (GridWidth + 1);
  h := yy Div (GridHeight + 1);

  Result := h * 7 + w + 1;
  ARect := Bounds(RectSize.Left + w * (GridWidth + 1), RectSize.Top + 2 +
    TopHeight + h * (GridHeight + 1), GridWidth, GridHeight);
End;

Procedure TLunarPanel.MouseLeave(Var Msg: TMessage);
Begin
  CHint.Hide;
End;

Procedure TLunarPanel.NextMonth;
Var
  d1, d2, d3: word;
Begin
  DecodeDate(FDate, d1, d2, d3);

  Inc(d2);
  If d2 > 12 Then
  Begin
    Inc(d1);
    d2 := 1;
  End;

  UpdateDate(d1, d2);
End;

Procedure TLunarPanel.PrevYear;
Var
  d1, d2, d3: word;
Begin
  DecodeDate(FDate, d1, d2, d3);

  Dec(d1);
  If d1 < START_YEAR Then
    d1 := END_YEAR;

  UpdateDate(d1, d2);
End;

Procedure TLunarPanel.PrevMonth;
Var
  d1, d2, d3: word;
Begin
  DecodeDate(FDate, d1, d2, d3);

  Dec(d2);
  If d2 < 1 Then
  Begin
    Dec(d1);
    d2 := 12;
  End;

  UpdateDate(d1, d2);
End;

Procedure TLunarPanel.NextYear;
Var
  d1, d2, d3: word;
Begin
  DecodeDate(FDate, d1, d2, d3);

  Inc(d1);
  If d1 > END_YEAR Then
    d1 := START_YEAR;

  UpdateDate(d1, d2);
End;

Procedure TLunarPanel.CreateWnd;
Begin
  Inherited;
  UpdateDateNow;
End;

Procedure TLunarPanel.Paint;
Begin
  If Not bmp.Empty Then
    BitBlt(Canvas.Handle, 0, 0, Width, Height, Bmp.Canvas.Handle, 0, 0,
      SRCCOPY);
End;

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

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

Procedure TLunarPanel.WMHIDELUNAR(Var Message: TMessage);
Begin
  If chint.Visible Then
    CHint.Hide;
End;

Function TLunarPanel.DrawThis: TBitmap;
Var
  y, m, d: WORD;

  tmpRect: TRect;
  J, h, w, k1, k2, tmp: Integer;
  sz, sz1: TSize;
  s1, s2, tmpStr: String;
  isToday, isWeekEnd, hasTerm: Boolean;
  Value: PLunarRec;

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

    With Result.Canvas Do
    Begin
      sz := TextExtent(s);
      h := (TopHeight - sz.cy) Div 2;
      w := (GridWidth - sz.cx) Div 2;
      TextOut(ARect.Left + w, ARect.Top + h, s);
    End;

  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 Result.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;
    With Result.Canvas Do
    Begin
      Font.Assign(tFl);
      sz1 := TextExtent(sal);
      Font.Assign(tFs);
      sz := TextExtent(sas);

      Case FCalendarType Of
        liSolar, liLunar:
          Begin
            h := (GridHeight - sz.cy) Div 2;
            w := (GridWidth - sz.cx) Div 2;
            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;
            TextOut(ARect.Left + w, ARect.Top + h, sas);

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

            Font.Assign(tFl);
            TextOut(ARect.Left + w, ARect.Top + h, sal);
          End;
      End;
    End;
    tFs.Color := aColor;
    tFl.Color := aColor1;
  End;

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

      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;
  End;

Begin
  Result := TBitmap.Create;

  DecodeDate(Now, y, m, d);
  FLunar.Caculate(y, m);

  With Result Do
  Begin
    Width := self.Width;
    Height := self.Height;

    SFont.Canvas := Canvas;

    DrawBackground;

    Canvas.Brush.Style := bsClear;
    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;
    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;
  DecodeDate(FDate, y, m, d);
  FLunar.Caculate(y, m);
  SFont.Canvas := Canvas;

End;

Procedure TLunarPanel.Swap(Var oss, osl: String);
Var
  tmps: String;
Begin
  tmps := oss;
  oss := osl;
  osl := tmps;
End;

Procedure TLunarPanel.SwapFont(Var ofs, ofl: TFont);
Var
  tmpf: TFont;
Begin
  tmpf := ofs;
  ofs := ofl;
  ofl := tmpf;
End;

Constructor TCalendarHint.Create(AOwner: TComponent);
Begin
  Inherited Create(AOwner);
  FStrings := TStringlist.Create;
  FNames := TStringlist.Create;
  Color := $80FFFF;

  Canvas.Font := Screen.HintFont;
  Canvas.Brush.Style := bsClear;
End;

Procedure TCalendarHint.CreateParams(Var Params: TCreateParams);
Begin
  Inherited CreateParams(Params);
  With Params Do
  Begin
    Style := WS_POPUP Or WS_BORDER;

    WindowClass.Style := WindowClass.Style Or CS_SAVEBITS;

    // CS_DROPSHADOW requires Windows XP or above
    If CheckWin32Version(5, 1) Then
      WindowClass.Style := WindowClass.style Or CS_DROPSHADOW;

    If NewStyleControls Then
      ExStyle := WS_EX_TOOLWINDOW Or WS_EX_TOPMOST;

    AddBiDiModeExStyle(ExStyle);
  End;
End;

Procedure TCalendarHint.CMTextChanged(Var Message: TMessage);
Var
  sw, sh: Integer;

  Procedure MultiLine(Const Value: String; Var ww, wh: integer);
  Var
    W, pp, w1: Integer;
    P, Start: PChar;
    S, S1: String;
    F: Boolean;
  Begin
    ww := 0;
    wh := 0;
    FMaxNameLen := 0;

    P := Pointer(Value);
    FStrings.Clear;
    FNames.Clear;

    f := pos('=', Value) > 0;

    If P <> Nil Then
      While P^ <> #0 Do
      Begin
        Start := P;

        While Not (P^ In [#0, #10, #13]) Do
          P := StrNextChar(P);

        SetString(S, Start, P - Start);
        W := Canvas.TextWidth(S) + 10;

        If f Then
        Begin
          s1 := '';
          pp := Pos('=', s);

          If pp > 0 Then
          Begin
            s1 := Trim(copy(s, 1, pp - 1)) + ':';
            FNames.Add(s1);

            w1 := Canvas.TextWidth(s1);
            If w1 > FMaxNameLen Then
              FMaxNameLen := w1;

            Delete(s, 1, pp);
          End
          Else
            FNames.Add('');
        End;

        FStrings.Add(s);

        If W > WW Then
          WW := W;
        While p^ In [#10, #13] Do
          Inc(p);

      End;
    If FStrings.Count > 0 Then
      wh := Canvas.TextHeight(Value) * FStrings.Count + 10;
  End;

Begin
  Inherited;

  MultiLine(Caption, sw, sh);

  If (sw = 0) Or (sh = 0) Then
    Hide
  Else
  Begin
    Width := sw;
    Height := sh;

    If Not Visible Then
      Show;
  End;

  Invalidate;
End;

Procedure TCalendarHint.SetAlpha(Value: Integer);
Begin
  If (FAlpha <> Value) And (Value > -1) And (Value < 256) Then
  Begin
    FAlpha := Value;
    SetLayeredAttribs;
  End;
End;

Procedure TCalendarHint.Paint;
Var
  R: TRect;
  i, p, h: Integer;
  s, s1: String;
Begin
  R := ClientRect;

  Inc(R.Left, 5);
  Inc(R.Top, 5);
  h := Canvas.TextHeight('H');

  p := r.Left;
  If FMaxNameLen > 0 Then
    p := r.Left + FMaxNameLen;

  For i := 0 To FStrings.Count - 1 Do
  Begin

    If FMaxNameLen > 0 Then
    Begin
      s := FNames[i];
      With Canvas Do
      Begin
        Font.Color := clRed; //Screen.HintFont.Color;
        TextOut(r.Left, r.Top + h * i, s);
      End;
    End;

    s1 := FStrings[i];
    With Canvas Do
    Begin
      Font.Color := Screen.HintFont.Color;
      TextOut(p, r.Top + h * i, s1);
    End;
  End;
End;

Destructor TCalendarHint.Destroy;
Begin
  FStrings.Free;
  FNames.Free;
  Inherited;
End;

Procedure TCalendarHint.WMNCHitTest(Var Message: TWMNCHitTest);
Begin
  Message.Result := HTTRANSPARENT;
End;

Procedure TCalendarHint.SetPosition;
Var
  pt: TPoint;
Begin
  GetCursorPos(pt);
  SetBounds(pt.X + 16, pt.Y + 16, Width, Height);
End;

Procedure TCalendarHint.SetLayeredAttribs;
Var
  AStyle: Integer;
Begin
  If Not (csDesigning In ComponentState) And
    (Assigned(SetLayeredWindowAttributes)) And HandleAllocated Then
  Begin

    AStyle := GetWindowLong(Handle, GWL_EXSTYLE);
    If (AStyle And WS_EX_LAYERED) <> WS_EX_LAYERED Then
      SetWindowLong(Handle, GWL_EXSTYLE, AStyle Or WS_EX_LAYERED);

    SetLayeredWindowAttributes(Handle, 0, FAlpha, LWA_ALPHA);
  End;
End;

End.