adatectl.pas

来自「delphi编程控件」· PAS 代码 · 共 1,516 行 · 第 1/3 页

      Invalidate;
    end;
  end;
end;

procedure TCustomAutoDateControl.SetStartOfWeek(Value: TDayOfWeek);
begin
  if FStartOfWeek <> Value then
  begin
    FStartOfWeek := Value;
    if HandleAllocated then
    begin
      Perform(WM_NCPAINT, 0, 0);
      Invalidate;
    end;  
  end;
end;

procedure TCustomAutoDateControl.SetTopRow(Value: Integer);
begin
  if FTopRow <> Value then
  begin
    FTopRow := Value;
    Invalidate;
  end;
end;

procedure TCustomAutoDateControl.CMFontChanged(var Message: TMessage);
begin
  Canvas.Font := Font;
  inherited;
  SetSize;
end;

procedure TCustomAutoDateControl.WMEraseBkgnd(var Message: TWMEraseBkgnd);
begin
  Message.Result := 1;
end;

procedure TCustomAutoDateControl.WMGetDlgCode(var Message: TWMGetDlgCode);
begin
  Message.Result := DLGC_WANTARROWS;
end;

procedure TCustomAutoDateControl.WMActivate(var Message: TWMActivate);
begin
  inherited;
  if IsPopup and (Message.Active = WA_INACTIVE) then Hide;
end;

procedure TCustomAutoDateControl.WMMouseActivate(var Message: TWMMouseActivate);
begin
  inherited;
  if not (csDesigning in ComponentState) then
  begin
    if Message.Result = MA_ACTIVATE then SetFocus;
    if IsPopup then Message.Result := MA_NOACTIVATE;
  end;
end;

procedure TCustomAutoDateControl.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
  inherited;
  Inc(Message.CalcSize_Params^.rgrc[0].Top, RowHeight);
end;

procedure TCustomAutoDateControl.WMNCPaint(var Message: TWMNCPaint);
var
  DC: HDC;
  R, CR: TRect;
  I, J: Integer;
  OldFontHandle: HFONT;
begin
  inherited;
  DC := GetWindowDC(Handle);
  try
    GetWindowRect(Handle, R);
    Windows.GetClientRect(Handle, CR);
    OffsetRect(R, -R.Left, -R.Top);
    InflateRect(R,
      -(R.Right - CR.Right - GetSystemMetrics(SM_CXVSCROLL)) div 2,
      -(R.Bottom - CR.Bottom - RowHeight) div 2);
    R.Bottom := R.Top + RowHeight;
    Brush.Color := clBtnFace;
    FillRect(DC, R, Brush.Handle);
    { write first letters of day's names }
    OldFontHandle := SelectObject(DC, Font.Handle);
    SetTextColor(DC, ColorToRGB(clWindowText));
    SetBkMode(DC, TRANSPARENT);
    for I := 0 to 6 do
    begin
      R.Left := GetSystemMetrics(SM_CXBORDER) + I * ColWidth;
      R.Right := R.Left + ColWidth;
      J := I + 1 + StartOfWeek;
      if J > 7 then Dec(J, 7);
      DrawText(DC, PChar(ShortDayNames[J]), 1, R,
        DT_CENTER or DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
    end;
    SelectObject(DC, OldFontHandle);
  finally
    ReleaseDC(Handle, DC);
  end;
end;

procedure TCustomAutoDateControl.WMSize(var Message: TWMSize);
begin
  inherited;
  Width := GetWidth;
end;

procedure TCustomAutoDateControl.WMVScroll(var Message: TWMVScroll);
var
  MonthName: string;
  P: TPoint;
begin
  inherited;
  case Message.ScrollCode of
    SB_LINEDOWN: TopRow := TopRow + 1;
    SB_LINEUP: TopRow := TopRow - 1;
    SB_PAGEDOWN: TopRow := TopRow + (VisibleRowCount - 2);
    SB_PAGEUP: TopRow := TopRow - (VisibleRowCount - 2);
    SB_THUMBTRACK:
      begin
        MonthName := FormatDateTime('mmmm yyyy',
          MonthAtRow(Message.Pos + VisibleRowCount div 2));
        if HintWindow = nil then
          HintWindow := TAutoDateHintWindow.Create(Self);
        P := ClientToScreen(Point(ClientWidth - 3, 12));
        TAutoDateHintWindow(HintWindow).ActivateHint(P, MonthName);
      end;
    SB_THUMBPOSITION:
      begin
        HintWindow.Free;
        HintWindow := nil;
        TopRow := Message.Pos;
      end;
  end;
end;

function TCustomAutoDateControl.ColOfDate(ADate: TDateTime): Integer;
begin
  Result := DayOfWeek(ADate) - StartOfWeek;
  if Result < 1 then Inc(Result, 7);
end;

procedure TCustomAutoDateControl.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
  begin
    if IsPopup then
    begin
      Style := WS_BORDER or WS_VSCROLL or WS_POPUP;
      ExStyle := WS_EX_TOOLWINDOW or WS_EX_TOPMOST;
    end
    else ExStyle := ExStyle or WS_EX_CLIENTEDGE;
    WindowClass.Style := WindowClass.Style or CS_SAVEBITS;
  end;
end;

procedure TCustomAutoDateControl.DoDateChange;
begin
  if Assigned(FOnDateChange) then FOnDateChange(Self);
end;

procedure TCustomAutoDateControl.DoBeginDateChange;
begin
  if Assigned(FOnBeginDateChange) then FOnBeginDateChange(Self);
end;

procedure TCustomAutoDateControl.DoEndDateChange;
begin
  if Assigned(FOnEndDateChange) then FOnEndDateChange(Self);
end;

function TCustomAutoDateControl.DateAtPos(const Pos: TPoint; var Found: Boolean): TDateTime;
var
  ACol, ARow, LastRow, AMonthTop, ADay, AWeek: Integer;
  AYear, AMonth, Day: Word;
begin
  ACol := 1 + Pos.X div ColWidth;
  ARow := TopRow + Pos.Y div RowHeight;
  LastRow := 0;
  DecodeDate(FDate, AYear, AMonth, Day);
  if ARow >= 0 then
    repeat
      Inc(LastRow, MonthHeight(AYear, AMonth, True));
      if LastRow >= ARow then Break;
      IncMonth(AYear, AMonth);
    until False
  else
    repeat
      DecMonth(AYear, AMonth);
      Dec(LastRow, MonthHeight(AYear, AMonth, True));
      if LastRow <= ARow then Break;
    until False;
  AMonthTop := MonthTop(AYear, AMonth) + 1;
  AWeek := ARow - AMonthTop;
  if AWeek = 0 then ADay := ACol - (7 - FirstWeekDays(AYear, AMonth))
  else
    ADay := FirstWeekDays(AYear, AMonth) + (AWeek - 1) * 7 + ACol;
  Found := (ADay >= 1) and (ADay <= DaysPerMonth(AYear, AMonth));
  if ADay < 1 then
  begin
    DecMonth(AYear, AMonth);
    ADay := DaysPerMonth(AYear, AMonth);
  end;
  if ADay > DaysPerMonth(AYear, AMonth) then
    ADay := DaysPerMonth(AYear, AMonth);
  Result := EncodeDate(AYear, AMonth, ADay);
end;

function TCustomAutoDateControl.FirstWeekDays(AYear, AMonth: Integer): Integer;
begin
  Result := 7 - (ColOfDate(EncodeDate(AYear, AMonth, 1)) - 1);
end;

procedure TCustomAutoDateControl.KeyDown(var Key: Word; Shift: TShiftState);
var
  AYear, AMonth, ADay: Word;
  P, P1, P2: TPoint;
  ADate: TDateTime;
  Found: Boolean;
  Row: Integer;
begin
  inherited KeyDown(Key, Shift);
  if (Key = VK_PRIOR) or (Key = VK_NEXT) then
    P := PosOfDate(FEndDate);
  case Key of
    VK_ESCAPE, VK_RETURN:
      if IsPopup then
      begin
        Hide;
        Exit;
      end;
    VK_LEFT: EndDate := FEndDate - 1;
    VK_RIGHT: EndDate := FEndDate + 1;
    VK_UP: EndDate := FEndDate - 7;
    VK_DOWN: EndDate := FEndDate + 7;
    VK_HOME:
      begin
        DecodeDate(FEndDate, AYear, AMonth, ADay);
        if ADay <= FirstWeekDays(AYear, AMonth) then
          EndDate := FEndDate - (ADay - 1)
        else
          EndDate := FEndDate - (ColOfDate(FEndDate) - 1);
      end;
    VK_END:
      begin
        DecodeDate(FEndDate, AYear, AMonth, ADay);
        if ADay > DaysPerMonth(AYear, AMonth) - LastWeekDays(AYear, AMonth) then
          EndDate := FEndDate + (DaysPerMonth(AYear, AMonth) - ADay)
        else
          EndDate := FEndDate + (7 - ColOfDate(FEndDate));
      end;
    VK_PRIOR: TopRow := TopRow - (VisibleRowCount - 2);
    VK_NEXT: TopRow := TopRow + (VisibleRowCount - 2);
  end;
  if (Key = VK_PRIOR) or (Key = VK_NEXT) then
  begin
    ADate := DateAtPos(P, Found);
    if Found then EndDate := ADate
    else
    begin
      P1 := PosOfDate(ADate);
      P2 := PosOfDate(ADate + 1);
      if Sqr(P1.X - P.X) + Sqr(P1.Y - P.Y) <
        Sqr(P2.X - P.X) + Sqr(P2.Y - P.Y) then EndDate := ADate
      else EndDate := ADate + 1;
    end;
  end;
  if SelectPeriod and (Shift <> [ssShift]) then BeginDate := FEndDate; 
  Row := RowOfDate(FEndDate);
  if Row < TopRow then TopRow := Row;
  if Row >= TopRow + VisibleRowCount then
    TopRow := Row - (VisibleRowCount - 1);
end;

function TCustomAutoDateControl.LastWeekDays(AYear, AMonth: Integer): Integer;
begin
  Result :=
    (DaysPerMonth(AYear, AMonth) - FirstWeekDays(AYear, AMonth)) mod 7;
  if Result = 0 then Result := 7; 
end;

function TCustomAutoDateControl.MonthAtRow(ARow: Integer): TDateTime;
var
  AYear, AMonth, ADay: Word;
  LastRow: Integer;
begin
  DecodeDate(Date, AYear, AMonth, ADay);
  LastRow := 0;
  if ARow >= 0 then
    repeat
      Inc(LastRow, MonthHeight(AYear, AMonth, True));
      if LastRow >= ARow then Break;
      IncMonth(AYear, AMonth);
    until False
  else
    repeat
      DecMonth(AYear, AMonth);
      Dec(LastRow, MonthHeight(AYear, AMonth, True));
      if LastRow <= ARow then Break;
    until False;
  Result := EncodeDate(AYear, AMonth, 1);  
end;

function TCustomAutoDateControl.MonthHeight(AYear, AMonth: Integer; Full: Boolean): Integer;
var
  DayCount: Integer;
begin
  DayCount := DaysPerMonth(AYear, AMonth) - FirstWeekDays(AYear, AMonth);
  Result := 1 + DayCount div 7 + Byte(DayCount mod 7 > 0);
  if Full then Inc(Result);  // for month's name
end;

function TCustomAutoDateControl.MonthTop(AYear, AMonth: Integer): Integer;
var
  Year, Month, Day: Word;
begin
  Result := 0;
  DecodeDate(FDate, Year, Month, Day);
  if (AYear > Year) or ((AYear = Year) and (AMonth > Month)) then
    while not ((Year = AYear) and (Month = AMonth)) do
    begin
      Inc(Result, MonthHeight(Year, Month, True));
      IncMonth(Year, Month);
    end
  else
    while not ((Year = AYear) and (Month = AMonth)) do
    begin
      DecMonth(Year, Month);
      Dec(Result, MonthHeight(Year, Month, True));
    end;
end;

procedure TCustomAutoDateControl.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
var
  CurDate: TDateTime;
  Found: Boolean;
begin
  inherited MouseDown(Button, Shift, X, Y);
  if Button = mbLeft then
  begin
    CurDate := DateAtPos(Point(X, Y), Found);
    if Found then
    begin
      FBeginDate := CurDate;
      EndDate := CurDate;
    end
    else
      if SelectPeriod then BeginDate := NullDate;
  end;
end;

var
  ScrollTimerID: Integer;
  ScrollTimerTopFlag: Boolean;

procedure ScrollTimerProc(Wnd: HWnd; Msg, TimerID, SysTime: Longint); stdcall;
var
  AControl: TCustomAutoDateControl;
  CurDate: TDateTime;
  Found: Boolean;
  P: TPoint;
begin
  AControl := TCustomAutoDateControl(FindControl(Wnd));
  if AControl <> nil then
    with AControl do
    begin
      GetCursorPos(P);
      P := ScreenToClient(P);
      CurDate := DateAtPos(P, Found);
      if Found then
        if BeginDate = NullDate then BeginDate := CurDate
        else EndDate := CurDate
      else
        if BeginDate > NullDate then
          if CurDate > BeginDate then EndDate := CurDate
          else EndDate := CurDate + 1;
      if ScrollTimerTopFlag then
        TopRow := TopRow - 1
      else TopRow := TopRow + 1;
    end
  else
  begin
    KillTimer(Wnd, ScrollTimerID);
    ScrollTimerID := -1;
  end;
end;

procedure TCustomAutoDateControl.MouseMove(Shift: TShiftState; X, Y: Integer);
Var
  CurDate: TDateTime;
  Found: Boolean;
begin
  if ScrollTimerID > -1 then
  begin
    KillTimer(Handle, ScrollTimerID);
    ScrollTimerID := -1;
  end;
//  if not PtInRect(ClientRect, Point(X, Y)) then Exit;
  inherited MouseMove(Shift, X, Y);
  if Shift = [ssLeft] then
  begin
    CurDate := DateAtPos(Point(X, Y), Found);
    if Found then
      if BeginDate = NullDate then BeginDate := CurDate
      else EndDate := CurDate
    else
      if BeginDate > NullDate then
        if CurDate > BeginDate then EndDate := CurDate
        else EndDate := CurDate + 1;
    if Y < RowHeight then
    begin
      ScrollTimerTopFlag := True;
      ScrollTimerID := SetTimer(Handle, 1, 100, @ScrollTimerProc);
    end;
    if Y > ClientHeight - RowHeight then
    begin
      ScrollTimerTopFlag := False;
      ScrollTimerID := SetTimer(Handle, 1, 100, @ScrollTimerProc);
    end;
  end;
end;

procedure TCustomAutoDateControl.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
  if IsPopup then Hide;
end;

procedure TCustomAutoDateControl.Paint;
var
  FirstYear, FirstMonth, LastYear, LastMonth, LastRow: Integer;
  Year, Month, Day: Word;
  Bitmap: TBitmap;
  ScrollInfo: TScrollInfo;

  procedure DrawMonth(AYear, AMonth: Integer);
  var
    AMonthTop, FirstWeek, I: Integer;
    ADate: TDateTime;
    R: TRect;
    S: string;
    MonthNameSelected: Boolean;

    function IsSelected(ADate: TDateTime): Boolean;
    begin
      Result := ((ADate >= BeginDate) and (ADate <= EndDate));
    end;

    procedure SelectColor(IsSelected: Boolean);
    const
      BrushColor: array[Boolean] of TColor = (clWindow, clHighlight);
      FontColor: array[Boolean] of TColor = (clWindowText, clHighlightText);
    begin
      with Bitmap.Canvas do
      begin
        Brush.Color := BrushColor[IsSelected];
        Font.Color := FontColor[IsSelected];
      end;
    end;

  begin
    with Bitmap.Canvas do
    begin
      AMonthTop := MonthTop(AYear, AMonth);
      FirstWeek := FirstWeekDays(AYear, AMonth);
      ADate := EncodeDate(AYear, AMonth, 1);
      MonthNameSelected := IsSelected(ADate - 1) and IsSelected(ADate);
      if AMonthTop >= TopRow then
      begin
        S := LongMonthNames[AMonth] + ' ' + IntToStr(AYear);
        with R do
        begin
          Left := 0;
          Top := (AMonthTop - TopRow) * RowHeight;
          Right := ClientWidth;
          Bottom := Top + RowHeight;
        end;
        SelectColor(MonthNameSelected);
        FillRect(R);
        DrawText(Handle, PChar(S), Length(S), R,
          DT_CENTER or DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
      end;
      for I := 1 to DaysPerMonth(AYear, AMonth) do
      begin
        if I > 1 then ADate := ADate + 1;
        with R do
        begin
          Left := (ColOfDate(ADate) - 1) * ColWidth;
          Right := Left + ColWidth;
          Top := AMonthTop + 1 - TopRow;
          if I > FirstWeek then Inc(Top, 1 + (I - FirstWeek - 1) div 7);
          Top := Top * RowHeight;
          Bottom := Top + RowHeight;
        end;
        SelectColor(IsSelected(ADate));
        S := IntToStr(I);
        FillRect(R);
        DrawText(Handle, PChar(S), Length(S), R,
          DT_CENTER or DT_NOCLIP or DT_SINGLELINE or DT_VCENTER);
        if I = 1 then