lsscalendar.pas

是一个免费并开源的支持农历的月历控件

      i := 1;
      while (i < length(S)) and (i < 6) do
      begin
        S1 := Copy(S,i,2);
        {$IFDEF AAFONT}
        if FSmoothText then
          AAFont.TextOut(R.Left + 2, YY,S1)
        else
        {$ENDIF}
          Canvas.TextOut(R.Left + 2, YY,S1);
        yy := yy + H;
        i := i + 2;
      end;
    end
    else if FLunarCalStyle = csRight then
      DrawString(S,R,DT_VCENTER OR DT_LEFT)
    else
      DrawString(S,R,DT_TOP OR DT_CENTER);
  end;

  procedure DrawFtvDay(R:TRect; TheDate:TDate);
  var
    S,S1:string;
    H, yy, i, j:integer;
    ch: char;
    fcolor: TColor;
  begin
    S:= GetFtv(TheDate, fcolor);
    if S = '' Then Exit;
    if Length(S) > MaxFtvLen then
    begin
      //计算S包含的single-byte ASCII字符
      j := 0;
      for i := 1 to MaxFtvLen - 2 do
      begin
        ch := S[i];
        if SizeOf(ch) = 1 then  //multibyte
        begin
          if (Ord(ch) and $80) = 0 then Inc(j);
        end;
      end;
      if j mod 2 > 0 then
        S := Copy(S, 1, MaxFtvLen - 3)
      else
        S := Copy(S, 1, MaxFtvLen - 2);
      S := S + '…';
    end;

    Canvas.Font := FCalColors.FtvTextFont;
    if M <> MonthOf(FViewDate) then
      Canvas.Font.Color := FCalColors.TrailingTextColor
    else if fcolor > -1 then     //说明：虽然在TFestivalList.Creat()中初始化为clRed,不知为什么GetFtv()返回的fcolor总是0。由于最近比较忙，没有进行深入分析这个bug。如果有哪位高手解决，请给我发一份[e-mail]。
      Canvas.Font.Color := fcolor;
    if (FFtvCalStyle = csRight) and FShowVertical then
    begin
      H:= Canvas.TextHeight(S);
      yy := R.Top + (R.Bottom - R.Top) div 3 - H;
      i := 1;
      while (i < length(S)) and (i < 6) do
      begin
        S1 := Copy(S,i,2);
        {$IFDEF AAFONT}
        if FSmoothText then
          AAFont.TextOut(R.Left + 2, YY,S1)
        else
        {$ENDIF}
          Canvas.TextOut(R.Left + 2, YY,S1);
        yy := yy + H;
        i := i + 2;
      end;
    end
    else if FFtvCalStyle = csRight then
      DrawString(S,R,DT_VCENTER OR DT_LEFT)
    else
      DrawString(S,R,DT_TOP OR DT_CENTER);
  end;

begin {= TLssCalendar.Paint =}
  inherited;
  Canvas.Font.Assign(Font);
  {$IFDEF AAFONT}
  if FSmoothText then
  begin
    AAFont := TAAFontEx.Create(Canvas);
    AAFont.Quality := aqHigh;
    AAFont.Effect.Shadow.Enabled := FShadowFont;
  end;
  {$ENDIF}
  
  try
    with Canvas,FCalColors do
    begin   
      // 画年月
      if RectVisible(Canvas.Handle,FTitleRect) then
      begin
        Brush.Color := TitleBackColor;
        Brush.Style := bsSolid;
        FillRect(FTitleRect);

        Brush.Style := bsClear;
        Font := TitleTextFont;
        Gzdate := GetGz(FViewDate);
        if FChineseEar then
        begin
          Outputstr := Cyclical(Gzdate.Year) + '(' + GetAnimal(GzDate.year) +
          ')年' + Cyclical(GzDate.Month) + '月';
        end
        else begin
          if FEnWeekName then
            OutputStr := MonthEnName(Month, True) + ' ' + InttoStr(Year)
          else
            OutputStr := FormatDateTime('yyyy年m月',FViewDate);
        end;
        DrawString(OutputStr,FTitleRect,DT_CENTER or DT_VCENTER);

        if FShowArrow then
        begin
          Font.Color := ArrowColor;
          Font.Size := Font.Size * 3 div 5;
          DrawString('《',FPrevYearRect,DT_CENTER or DT_VCENTER);
          DrawString('〈',FPrevMonthRect,DT_CENTER or DT_VCENTER);
          DrawString('〉',FNextMonthRect,DT_CENTER or DT_VCENTER);
          DrawString('》',FNextYearRect,DT_CENTER or DT_VCENTER);
        end;
      end;

      //////////////////////////////////////

      //画星期
      R := Bounds(FWeekRect.Left,FWeekRect.Top,FCellWidth,FCellHeight);
      if RectVisible(Canvas.Handle, FWeekRect) then
      begin
        Brush.Color := WeekBackColor;
        Brush.Style := bsSolid;
        FillRect(FWeekRect);

        Brush.Style := bsClear;
        for i := 0 to 6 do
        begin
          aWeekDay := i;
          if FUseISO8601 then Inc(aWeekDay);

          Font := FWeekTextFont;
          if (aWeekDay = 0) or (aWeekDay = 7) then  //Sunday
            Font.Color := FSundayColor
          else if aWeekDay = 6 then   //Saturday
            Font.Color := FSaturdayColor;

          if FEnWeekName then
            OutputStr := WeekEnName(aWeekDay)
          else
            OutputStr := FormatWeekDay(aWeekDay);
          drawstring(OutputStr,R,DT_CENTER or DT_VCENTER);
          OffsetRect(R, FCellWidth , 0 );
        end;
        if not FShowGrid then
        begin
          Pen.Color := WeekTextFont.Color;
          Pen.Width := 1;
          Pen.Mode := pmCopy;
          PenPos := Point(2,FWeekRect.Bottom - 2);
          LineTo(FWeekRect.Right - 2 , FWeekRect.Bottom - 2);
        end;
      end;

      //////////////////////////////////////

      //画背景
      Brush.Color := Color;
      Brush.Style := bsSolid;
      FillRect(FDaysRect);
  
      if FShowBackImage and (FBackImage <> nil) then
      begin
        StretchDraw(FDaysRect, FBackImage.Picture.Bitmap);
      end;

      Brush.Style := bsClear;   //透明
      if FShowBackMonth then
      begin
        Font := BackMonthTextFont;
        OutputStr := FormatDateTime('m',FViewDate);
        TextSize := TextExtent(OutputStr);
        {$IFDEF AAFONT}
        if FSmoothText then
          AAFont.TextOut(FDaysRect.Left + (Width - TextSize.cx) div 2,
              FDaysRect.Top + (FDaysRect.Bottom - FDaysRect.Top - TextSize.cy) div 2,OutputStr)
        else
        {$ENDIF}
          Canvas.TextOut(FDaysRect.Left + (Width - TextSize.cx) div 2,
              FDaysRect.Top + (FDaysRect.Bottom - FDaysRect.Top - TextSize.cy) div 2,OutputStr);
      end;
      
      if FShowBorder then
      begin
        Brush.Color := FCalColors.FBorderColor;
        //Brush.Style := bsSolid;
        FrameRect(ClientRect);
        //Brush.Style := bsClear;
      end;
      if FShowGrid then
        DrawGrid;

      //////////////////////////////////////

      //画日期
      R := Bounds(FDaysRect.Left, FDaysRect.Top , FCellWidth , FCellHeight);
      for i := 0 to 41 do
      begin
        Col := i mod 7;
        if FUseISO8601 then Inc(Col);
        if RectVisible(Canvas.Handle, R) then
        begin
          TempDate := IncDay(FFirstDate, i);
          DeCodeDate(TempDate,Y,M,D);

          Font := DayTextFont;
          if M = MonthOf(FViewDate) then
            if (Col = 0) or (Col = 7) then
              Font.Color := SundayColor
            else
              if col = 6 then
                Font.Color := SaturdayColor
              else
                Font.Color := DayTextFont.Color
          else
            Font.Color := TrailingTextColor;

          if GetMark(TempDate) > -1 then
          begin
            Brush.Style := bsSolid;
            Brush.Color := GetMark(TempDate);
            FillRect(R);
          end;

          if TempDate = FViewDate then      //高亮显示月历日期
          begin
            Brush.Style := bsSolid;
            Brush.Color := HightlightBackColor;
            Font.Color := HightlightTextColor;
            FillRect(R);
            FOldRect := R;
            DR := R;
            InflateRect(DR,-2,-2);
            //if Focused then Windows.DrawFocusRect(Handle,dR);
            DrawFocusRect(DR);
            //Brush.Style := bsClear;
          end;

          Brush.Style := bsClear;
          if TempDate = DateOf(Now) then      //在当前日期画一红色框
          begin
            Pen.Color := ClRed;
            Pen.Width := 1;
            Rectangle(R.Left, R.Top, R.Right, R.Bottom );
          end;

          OutputStr := intToStr(D);
          SR := FSolarRect;
          OffsetRect(SR, R.Left, R.Top);
          DrawString(OutputStr,SR,DT_VCENTER OR DT_CENTER);

          if not IsRectEmpty(FFtvRect) and (FLunarCalStyle = FFtvCalStyle) then
          begin
            if GetFtv(TempDate) <> '' then
            begin
              FR := FFtvRect;
              OffsetRect(FR, R.Left, R.Top);
              DrawFtvDay(FR,TempDate);
            end
            else begin
              DR := FLunarRect;
              OffsetRect(DR, R.Left, R.Top);
              DrawHzDay(DR,TempDate);
            end;
          end
          else begin
            if not IsRectEmpty(FLunarRect) then
            begin
              DR := FLunarRect;
              OffsetRect(DR, R.Left, R.Top);
              DrawHzDay(DR,TempDate);
            end;

            if not IsRectEmpty(FFtvRect) then
            begin
              FR := FFtvRect;
              OffsetRect(FR, R.Left, R.Top);
              DrawFtvDay(FR,TempDate);
            end;
          end;
        end;

        OffsetRect(R, 0, 0);
        if (FUseISO8601 and (col = 7)) or (not FUseISO8601 and (col = 6)) then
          OffsetRect(R, FDaysRect.Left - R.Left , FCellHeight)
        else
          OffsetRect(R,FCellWidth,0);
      end; {end for}
    end; {end with}
  finally
    {$IFDEF AAFONT}
    if FSmoothText then AAFont.Free;
    {$ENDIF}
  end;
end; {= TLssCalendar.Paint =}

procedure TLssCalendar.Resize;
begin
  inherited;
  CalcRect;
end;

procedure TLssCalendar.CalcRect;
var
  TextSize: TSize;
  S: string;
  w, h: integer;
begin
  Canvas.Font.Assign(Font);
  FCellWidth := ClientRect.Right div 7;
  FCellHeight := ClientRect.Bottom div 8;
  FTitleRect := ClientRect;
  FTitleRect.Bottom := FCellHeight;

  FWeekRect := Bounds(0, FTitleRect.Bottom, ClientRect.Right, FCellHeight);
  FDaysRect := Bounds(0, FWeekRect.Bottom, ClientRect.Right, ClientRect.Bottom - FWeekRect.Bottom);

  FSolarRect := Bounds(0, 0, FCellWidth, FCellHeight);
  FLunarRect := Bounds(0, 0, 0, 0);
  FFtvRect := Bounds(0, 0, 0, 0);
  w := Round(FCellWidth / FHorizonScale);
  h := Round(FCellHeight / FVerticalScale);
  case FLunarCalStyle of
    csNone:
      case FFtvCalStyle of
        csNone: ;
        csRight:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth - w, FCellHeight);
            FFtvRect := Bounds(FSolarRect.Right, 0, w, FCellHeight);
          end;
        csBottom:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth, FCellHeight - h);
            FFtvRect := Bounds(0, FSolarRect.Bottom, FCellWidth, h);
          end;
      end;
    csRight:
      case FFtvCalStyle of
        csNone:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth - w, FCellHeight);
            FLunarRect := Bounds(FSolarRect.Right, 0, w, FCellHeight);
          end;
        csRight:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth - w, FCellHeight);
            FLunarRect := Bounds(FSolarRect.Right, 0, w, FCellHeight);
            FFtvRect := FLunarRect;
          end;
        csBottom:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth - w, FCellHeight - h);
            FLunarRect := Bounds(FSolarRect.Right, 0, w, FCellHeight - h);
            FFtvRect := Bounds(0, FSolarRect.Bottom, FCellWidth, h);
          end;
      end;
    csBottom:
      case FFtvCalStyle of
        csNone:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth, FCellHeight - h);
            FLunarRect := Bounds(0, FSolarRect.Bottom, FCellWidth, h);
          end;
        csRight:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth - w, FCellHeight - h);
            FLunarRect := Bounds(0, FSolarRect.Bottom, FCellWidth, h);
            FFtvRect := Bounds(FSolarRect.Right, 0, w, FCellHeight - h);
          end;
        csBottom:
          begin
            FSolarRect := Bounds(0, 0, FCellWidth, FCellHeight - h);
            FLunarRect := Bounds(0, FSolarRect.Bottom, FCellWidth, h);
            FFtvRect := FLunarRect;
          end;
      end;
  end;

  with FCalColors do
  begin
    if FAutoFontSize then
    begin
      BackMonthTextFont.Size := GetMaxTextSize('9',FDaysRect.Right,Round((FDaysRect.Bottom - FDaysRect.Top) * 0.9));;
      TitleTextFont.Size := GetMaxTextSize(FormatDateTime('yyyy年mm月',FViewDate),FTitleRect.Right,Round((FTitleRect.Bottom - FTitleRect.Top) * 0.8 ));
      WeekTextFont.Size := GetMaxTextSize(FormatDateTime('ddd',FViewDate),Round(FCellWidth * 0.9),FCellHeight);

      DayTextFont.Size := GetMaxTextSize(FormatDateTime('dd',FViewDate),FSolarRect.Right, FSolarRect.Bottom);