chncalendar.pas

具有农历功能的Delphi Builder日历控件

  Trigon(Canvas,
    Point(TrigonLeft, TrigonTop),
    Point(TrigonLeft + 6, TrigonTop),
    Point(TrigonLeft + 3, TrigonTop + 3));
  ButtonRect := R;

end;


procedure DrawClt3D(aCanvas: TCanvas; R: TRect);
begin
  with aCanvas do
  begin
//    R := Label1.ClientRect; //Rect(0, H div 2 - 1, Panel1.Width, Panel1.Height);
    Brush.Color := clBtnHighlight;
    FillRect(R);
    FrameRect(R);

    Brush.Color := clBtnShadow;
    Pen.Color := clBtnShadow;
    MoveTo(r.Left, r.Top);
    LineTo(r.Right - 1, r.Top);
    MoveTo(r.Left, r.Top);
    LineTo(r.Left, r.Bottom - 1);

    InflateRect(R, -1, -1);
    Brush.Color := clBtnFace;
    FrameRect(R);

    Brush.Color := clBtnShadow;
    Pen.Color := clBtnShadow;
    MoveTo(r.Left, r.Top);
    LineTo(r.Right - 1, r.Top);
    MoveTo(r.Left, r.Top);
    LineTo(r.Left, r.Bottom - 1);
  end;
end;

procedure TChnCalendar.Paint;
var
  TextTop: integer;
begin
  YearEdit.Color := color;
  MonthEdit.Color := color;
  DayEdit.Color := Color;
//  ButtonRect := RECT(Width - 15, 1, Width - 1, Height - 1);

  Canvas.Pen.Color := FrameColor;
  Canvas.Brush.Color := Color;
  Canvas.FillRect(ClientRect);
  if Ctl3D then
  begin
    DrawClt3D(Canvas, ClientRect);
    Canvas.Pen.Color := FrameColor;
    Canvas.Brush.Color := Color;
  end
  else
  begin
    Canvas.Rectangle(ClientRect);
  end;


  canvas.Font.Color := Font.Color;
  TextTop := (Height - canvas.TextHeight('A')) div 2;
  Canvas.TextOut(33, TextTop, '-');
  Canvas.TextOut(60, TextTop, '-');
  canvas.Font.Color := FCnDateColor;
  Canvas.TextOut(84, TextTop, CnDate);
  canvas.Font.Color := Font.Color;


  DrawButton(0);
  inherited;
end;

procedure TChnCalendar.SetBackPicture(const Value: TbitMap);
begin
  FBackPicture.Assign(Value);

end;

procedure TChnCalendar.setButtonColor(const Value: TColor);
begin
  if FButtonColor <> Value then
  begin
    FButtonColor := Value;
    Invalidate;
  end;
end;

procedure TChnCalendar.setCnDateColor(const Value: TColor);
begin
  if FCnDateColor <> Value then
  begin
    FCnDateColor := Value;
    Invalidate;
  end;
end;

procedure TChnCalendar.SetDateTime(const Value: TDateTime);
begin
  if Value <> FDateTime then
  begin
    FDateTime := Value;
    YearEdit.Text := FormatDateTime('YYYY', FDateTime);
    MonthEdit.Text := FormatDateTime('m', FDateTime);
    DayEdit.Text := FormatDateTime('d', FDateTime);
    CnDate := CnanimalOfYear(DateTime) + CnMonthOfDate(DateTime) + CnDayOfDate(DateTime);
    Invalidate;
  end;
end;

procedure TChnCalendar.SetFrameColor(const Value: TColor);
begin
  FFrameColor := Value;
  Invalidate;
end;

function FormExists(FORM_NAME: string): BOOLEAN;
begin
  if Application.FindComponent(FORM_NAME) = nil then
    RESULT := FALSE
  else
    RESULT := TRUE;
end;

function DayOfMonth(Year, Month: Integer): integer; overload;
begin
  try
    Result := MonthDays[IsLeapYear(Year), Month];
  except
    Result := 0;
  end;
end;

function DayOfMonth(Dates: TDateTime): integer; overload;
var
  Year, Month, Day, Hour: Word;

begin
  DecodeDate(Dates, Year, Month, day);
  Result := MonthDays[IsLeapYear(Year), Month];
end;

function DaysOfMonth(Dates: TDateTime): Integer;
begin
  Result := DayOfMonth(YearOf(Dates), MonthOf(Dates));
end;


function SetDateTime(NYear, NMonth, NDay: Word): TDate;
var
  MyDay: Word;
begin
  MyDay := DayOfMonth(NYear, NMonth);
  if MyDay < NDay then
    NDay := MyDay;
  Result := EncodeDate(NYear, NMonth, NDay);

end;


procedure AdjustDropDownForm(AControl: TControl; HostControl: TControl);
var
  WorkArea: TRect;
  HostP, PDelpta: TPoint;
begin
  SystemParametersInfo(SPI_GETWORKAREA, 0, @WorkArea, 0);
  HostP := HostControl.ClientToScreen(Point(0, 0));
  PDelpta := AControl.ClientToScreen(Point(0, 0));

  AControl.Left := HostP.x;
  AControl.Top := HostP.y + HostControl.Height + 1;

  if (AControl.Width > WorkArea.Right - WorkArea.Left) then
    AControl.Width := WorkArea.Right - WorkArea.Left;

  if (AControl.Left + AControl.Width > WorkArea.Right) then
    AControl.Left := WorkArea.Right - AControl.Width;
  if (AControl.Left < WorkArea.Left) then
    AControl.Left := WorkArea.Left;


  if (AControl.Top + AControl.Height > WorkArea.Bottom) then
  begin
    if (HostP.y - WorkArea.Top > WorkArea.Bottom - HostP.y - HostControl.Height) then
      AControl.Top := HostP.y - AControl.Height;
  end;

  if (AControl.Top < WorkArea.Top) then
  begin
    AControl.Height := AControl.Height - (WorkArea.Top - AControl.Top);
    AControl.Top := WorkArea.Top;
  end;

  if (AControl.Top + AControl.Height > WorkArea.Bottom) then
  begin
    AControl.Height := WorkArea.Bottom - AControl.Top;
  end;

end;


procedure TChnCalendar.WMLButtonDown(var Message: TWMLButtonDown);
var
  xy: TPoint;
  P: TPoint;
  bmp: TbitMap;
begin
  xy := Point(Message.Pos.x, Message.Pos.y);
  GetCursorPos(xy);
  xy := ScreenToClient(xy);
  if PtInRect(ButtonRect, xy) then
    if not IsWindowVisible(FRM_Date.Handle) then
    begin
      if MouseStyle <> 1 then
      begin
        MouseStyle := 1;
        DrawButton(1);
      end;
//    FRM_Date.ShowDateWin(YearEdit, MonthEdit, DayEdit, Self);
{  OutputDebugString(pchar(
    inttostr(ButtonRect.Left) + ',' +
    inttostr(ButtonRect.Right) + ',' +
    inttostr(ButtonRect.Top) + ',' +
    inttostr(ButtonRect.Bottom) + ' ' +
    inttostr(xy.X) + ',' +
    inttostr(xy.Y)
    ));
}
      FRM_Date.YearEdit := YearEdit;
      FRM_Date.MonthEdit := MonthEdit;
      FRM_Date.DayEdit := DayEdit;
      MHostControl := Self;
{
//if isChangeBmp then
    with FRM_Date do
    begin
      Image1.Picture.Bitmap.Assign(FBackPicture);
      Label16.Visible := FBackPicture.Width = 0;
      Label20.Visible := FBackPicture.Width = 0;
      if Image1.Picture.Graphic <> nil then
      begin
        bmp := TbitMap.Create;
        bmp.Width := Image1.Width;
        bmp.Height := Image1.Height;
        bmp.Canvas.Brush.Color := Color;
        bmp.Canvas.FillRect(RECT(0, 0, bmp.Width,
          bmp.Height));

        P := Point((bmp.Width - FBackPicture.Width) div 2,
          (bmp.Height - FBackPicture.Height) div 2);
        BmpAlphaBlend(bmp, FBackPicture, P, FAlphaBlend);
        Image1.Canvas.Draw(0, 0, bmp);
        bmp.free;

      end;
    end;
//    isChangeBmp := False;
}
      with FRM_Date do
      begin
        if Image1.Picture.Graphic = nil then
          StaticText1.Caption := 'aaaa';

        YearEdit.Text := IntToStr(StrTOIntDef(YearEdit.Text, YearOf(Date)));
        MonthEdit.Text := IntToStr(StrTOIntDef(MonthEdit.Text, MonthOf(Date)));
        DayEdit.Text := IntToStr(StrTOIntDef(DayEdit.Text, DayOfMonth(Date)));

        if (StrToInt(YearEdit.Text) > 2050) or (StrToInt(YearEdit.Text) < 1901) then
          YearEdit.Text := IntToStr(YearOf(Date));

        if (StrToInt(MonthEdit.Text) > 12) or (StrToInt(MonthEdit.Text) < 1) then
          MonthEdit.Text := IntToStr(MonthOf(Date));

        if StrToInt(DayEdit.Text) > DayOfMonth(StrToInt(YearEdit.Text), StrToInt(MonthEdit.Text)) then
          DayEdit.Text := IntToStr(DayOfMonth(StrToInt(YearEdit.Text), StrToInt(MonthEdit.Text)));

        NDate := EncodeDate(StrToInt(YearEdit.text), StrToInt(MonthEdit.text), StrToInt(DayEdit.text));
      end;
      AdjustDropDownForm(FRM_Date, Self);
      FRM_Date.Show;
//    ShowWindow(MonthWin.Handle, SW_SHOWNORMAL);
    end;

end;

procedure TChnCalendar.WMLButtonUp(var Message: TWMLButtonUp);
var
  xy: TPoint;
begin
  xy := Point(Message.Pos.x, Message.Pos.y);
  if PtInRect(ButtonRect, xy) then
  begin
    MouseStyle := 0;
    DrawButton(0);
  end;

end;

{
procedure TChnCalendar.WMMouseMove(var Message: TWMMouseMove);
var
  xy: TPoint;
begin
  xy := Point(Message.Pos.x, Message.Pos.y);
  if PtInRect(ButtonRect, xy) then
    if MouseStyle <> 1 then
    begin
      MouseStyle := 1;
      DrawButton(1);
    end;

end;
 }

procedure TChnCalendar.WMSize(var Msg: TWMSize);
begin
  YearEdit.Top := (Height - YearEdit.Height) div 2;
  MonthEdit.Top := YearEdit.Top;
  DayEdit.Top := YearEdit.Top;
end;

procedure TChnCalendar.CMCtl3DChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;

end;

procedure TChnCalendar.CMMouseLeave(var Message: TMessage);
begin
  if MouseStyle = 1 then
  begin
    MouseStyle := 0;
    DrawButton(0);
  end;

end;

end.