jvtmtimeline.pas

East make Tray Icon in delphi

  with FLeftBtn do
  begin
    Align := alLeft;
    Width := FButtonWidth;
    Parent := Self;
    Transparent := False;
    Layout := blGlyphTop;
    Glyph.LoadFromResourceName(HInstance, 'JvCustomTMTimelineSCROLLLEFT');

    OnMouseDown := DoLMouseDown;
    OnMouseUp := DoMouseUp;
    //    OnClick := LeftClick;
  end;

  FRightBtn := TSpeedButton.Create(Self);
  with FRightBtn do
  begin
    Align := alRight;
    Width := FButtonWidth;
    Parent := Self;
    Transparent := False;
    Layout := blGlyphTop;
    Glyph.LoadFromResourceName(HInstance, 'JvCustomTMTimelineSCROLLRIGHT');

    OnMouseDown := DoRMouseDown;
    OnMouseUp := DoMouseUp;
  end;
  {$IFDEF COMPILER6_UP}
  FLeftBtn.SetSubComponent(True);
  FRightBtn.SetSubComponent(True);
  {$ENDIF COMPILER6_UP}
  Height := 56;
  BevelInner := bvNone;
  BevelOuter := bvNone;
  Color := clWindow;
  Align := alTop;
  BorderStyle := bsSingle;
end;

destructor TJvCustomTMTimeline.Destroy;
begin
  FChangeLink.Free;
  FMonthFont.Free;
  FSelection.Free;
  FDateImages.Free;
  FObjects.Free;
  inherited Destroy;
end;

procedure TJvCustomTMTimeline.StartTimer;
begin
  if not Assigned(FTimer) then
  begin
    FTimer := TTimer.Create(Self);
    FTimer.OnTimer := DoTimer;
    FTimer.Interval := 400;
  end;
  FTimer.Enabled := True;
end;

procedure TJvCustomTMTimeline.StopTimer;
begin
  FTimer.Free;
  FTimer := nil;
end;

procedure TJvCustomTMTimeline.DoLMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbRight then
    Exit;
  if ssCtrl in Shift then
    ScrollDate(Sender, -LargeChange)
  else
    ScrollDate(Sender, -SmallChange);
  FBtnDown := bdLeft;
  FShift := Shift;
  StartTimer;
end;

procedure TJvCustomTMTimeline.DoRMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button = mbRight then
    Exit;
  if ssCtrl in Shift then
    ScrollDate(Sender, LargeChange)
  else
    ScrollDate(Sender, SmallChange);
  FShift := Shift;
  FBtnDown := bdRight;
  StartTimer;
end;

procedure TJvCustomTMTimeline.DoMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FBtnDown := bdNone;
  StopTimer;
end;

procedure TJvCustomTMTimeline.DoTimer(Sender: TObject);
begin
  FTimer.Enabled := False;
  case FBtnDown of
    bdLeft:
      if ssCtrl in FShift then
        ScrollDate(Sender, -LargeChange)
      else
        ScrollDate(Sender, -SmallChange);
    bdRight:
      if ssCtrl in FShift then
        ScrollDate(Sender, LargeChange)
      else
        ScrollDate(Sender, SmallChange);
    bdNone:
      begin
        FTimer.Interval := 400;
        Exit;
      end;
  end;
  FTimer.Interval := 70;
  FTimer.Enabled := True;
end;

procedure TJvCustomTMTimeline.DoChange(Sender: TObject);
begin
  Invalidate;
end;

procedure TJvCustomTMTimeline.ScrollDate(Sender: TObject; Delta: Integer);
begin
  Delta := Trunc(Self.Date + Delta);
  if ((MinDate = 0) or (Delta > MinDate)) and
    ((MaxDate = 0) or (Delta < MaxDate)) then
    Self.Date := Delta;
end;

function TJvCustomTMTimeline.GetRectForDate(ADate: TDate): TRect;
begin
  // all rects are the same size...
  Result := Rect(0, 0, DayWidth, ClientHeight + 1);
  // ...but we must move the entire rect to the correct date
  OffsetRect(Result, Trunc(ADate - Self.Date) * DayWidth, 0);
  // ...and finally compensate for the inital offset
  if ReadOnly then
    OffsetRect(Result, 1, 0) // no buttons showing
  else
    OffsetRect(Result, ButtonWidth, 0);
end;

function TJvCustomTMTimeline.DateFromPos(APos: Integer): TDate;
var
  Tmp: Integer;
begin
  if not ReadOnly then
    Tmp := APos - ButtonWidth
  else
    Tmp := APos - 1;
  Result := Self.Date + (Tmp div FDayWidth);
end;

procedure TJvCustomTMTimeline.DrawToday(ACanvas: TCanvas; const ARect: TRect);
var
  Tmp: TColor;
  Bmp: TBitmap;
  R: TRect;
begin
  if ShowTodayIcon then
    Bmp := TBitmap.Create
  else
    Bmp := nil;
  Tmp := ACanvas.Brush.Color;
  try
    if ShowTodayIcon then
      Bmp.LoadFromResourceName(HInstance, 'JvCustomTMTimelineMILESTONELARGE');
    if ShowToday then
    begin
      ACanvas.Brush.Color := FTodayColor;
      ACanvas.FillRect(ARect);
    end;
    if ShowTodayIcon then
    begin
      R := Rect(ARect.Left + ((ARect.Right - ARect.Left) - Bmp.Width) div 2,
        ARect.Top + CanvasMaxTextHeight(ACanvas) + 2,
        ARect.Left + ((ARect.Right - ARect.Left) - Bmp.Width) div 2 + Bmp.Width,
        ARect.Top + Bmp.Height + CanvasMaxTextHeight(ACanvas) + 2);
(*      {$IFDEF VCL}
      ACanvas.BrushCopy(R, Bmp, Rect(0, 0, Bmp.Width, Bmp.Height), clFuchsia);
      {$ENDIF VCL}
      {$IFDEF VisualCLX}
      *)
      Bmp.Transparent := True;
      ACanvas.Draw(R.Left, R.Top, Bmp);
//      {$ENDIF VisualCLX}
    end;
  finally
    ACanvas.Brush.Color := Tmp;
    Bmp.Free;
  end;
end;

procedure TJvCustomTMTimeline.DrawDates(ACanvas: TCanvas);
var
  I, FirstOffset: Integer;
  Y, M, D: Word;
  R: TRect;
  Size: TSize;
  S: string;
  FTmpStyle: TFontStyles;
  AContinue: Boolean;
begin
  AContinue := True;
  // DoBeforeDraw(ACanvas);
  if not AContinue then
    Exit;
  if not ReadOnly then
    FirstOffset := ButtonWidth
  else
    FirstOffset := 1;
  // first loop: draw dates, today and images
  FTmpStyle := Font.Style;
  for I := 0 to Width div FDayWidth do
  begin
    R := GetRectForDate(Self.Date + I);
    if Self.Date + I = SysUtils.Date then
      DrawToday(ACanvas, R);

    DecodeDate(Self.Date + I, Y, M, D);
    R := Rect(I * FDayWidth, 4, I * FDayWidth + FDayWidth, Font.Size + 4);
    OffsetRect(R, FirstOffset, 0);
    S := Format('%.2d', [D]);
    SetBkMode(ACanvas.Handle, TRANSPARENT);
    if Objects[Self.Date + I] <> nil then
      ACanvas.Font.Style := FObjectsFontStyle
    else
      ACanvas.Font.Style := FTmpStyle;

    DrawText(ACanvas.Handle, PChar(S), Length(S), R,
      DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);
    DrawImage(ACanvas, Self.Date + I, GetRectForDate(Self.Date + I));
    // frame should be drawn on top of text and image
    if (Trunc(SelDate) = Trunc(Self.Date + I)) and not ReadOnly then
      DrawSelectionFrame(ACanvas, GetRectForDate(SelDate));

    ACanvas.Font := Font;
    if not Enabled then
      ACanvas.Font.Color := clGrayText;
  end;

  // second loop: draw months and years and separators
  if ShowWeeks or ShowMonths then
    for I := 0 to (Width div DayWidth) do
    begin
      R := GetRectForDate(Self.Date + I);
      DecodeDate(FDate + I, Y, M, D);
      if ShowWeeks and (DayOfWeek(Self.Date + I) = 1) then
        with ACanvas do
        begin
          // draw the dotted week separator between sunday and monday
          Brush.Color := Color;
          Pen.Width := 1;
          Pen.Style := psDot;
          Pen.Color := FLineColor;
          MoveTo(I * FDayWidth + FDayWidth + FirstOffset, 0);
          LineTo(I * FDayWidth + FDayWidth + FirstOffset, Height);
        end;

      ACanvas.Font := MonthFont;
      if not Enabled then
        ACanvas.Font.Color := clGrayText;
      if ShowMonths then
      begin
        if MonthDays[IsLeapYear(Y), M] = D then
        begin
          // draw text for end of this month:
          S := ShortMonthNames[M];
          Size := ACanvas.TextExtent(S);
          R := Rect(I * FDayWidth + FDayWidth - Size.cx - 8,
            Height - Size.cy - 4, I * FDayWidth + FDayWidth, Height - 4);
          OffsetRect(R, FirstOffset, 0);
          SetBkMode(ACanvas.Handle, TRANSPARENT);
          DrawText(ACanvas.Handle, PChar(S), Length(S), R,
            DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);
        end
        else
        if D = 1 then
        begin
          // draw text for start of this month and the year:
          S := Format('%s %d', [ShortMonthNames[M], Y]);
          Size := ACanvas.TextExtent(S);
          R := Rect(I * FDayWidth + 4, Height - Size.cy - 4, I * FDayWidth + Size.cx + 4, Height - 4);
          OffsetRect(R, FirstOffset, 0);
          SetBkMode(ACanvas.Handle, TRANSPARENT);
          DrawText(ACanvas.Handle, PChar(S), Length(S), R,
            DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX or DT_NOCLIP);

          // Draw the separator
          with ACanvas do
          begin
            Pen.Width := 1;
            Pen.Style := psSolid;
            Pen.Color := FLineColor;
            MoveTo(I * FDayWidth + FirstOffset, 0);
            LineTo(I * FDayWidth + FirstOffset, Height);
          end;
        end;
      end;
    end;

  // finally, clean up the display
  if (ButtonWidth > 0) and not ReadOnly then
    with ACanvas do
    begin
      // draw a vertical line just to the right of the left scroll button and
      // just to the left of the right scroll button to
      // make them stand out a little bit more when buttons are flat:
      Pen.Width := 1;
      Pen.Color := clBlack;
      Pen.Style := psSolid;
      if BorderStyle = bsNone then
      begin
        MoveTo(FLeftBtn.Width, 0);
        LineTo(FLeftBtn.Width, Height);
      end;
      MoveTo(FRightBtn.Left - 1, 0);
      LineTo(FRightBtn.Left - 1, Height);
    end;
  // DoAfterDraw(ACanvas);
end;

procedure TJvCustomTMTimeline.DrawSelectionFrame(ACanvas: TCanvas; ARect: TRect);
begin
  if not FSelection.Visible then
    Exit;
  if (ARect.Right > 0) and (ARect.Left <= Width) then
  begin
    ARect.Bottom := ARect.Bottom - ACanvas.Pen.Width;
    with FSelection do
      DrawFrame(ACanvas, Pen.Color, Pen.Width, ARect);
  end;
end;

procedure TJvCustomTMTimeline.DrawImage(ACanvas: TCanvas; ADate: TDate; const ARect: TRect);
var
  I, X, Y: Integer;
begin
  if DateHasImage(ADate) then
  begin
    I := ImageIndex[ADate];
    X := ARect.Left + (FDayWidth - Images.Width) div 2;
    //    Y := Max((Height  - Images.Height) div 4, CanvasMaxTextHeight(ACanvas) + 2);
    Y := CanvasMaxTextHeight(ACanvas) + 2;
    Images.Draw(ACanvas, X, Y, I);
  end;
end;

procedure TJvCustomTMTimeline.Paint;
begin
  if not Showing or (csLoading in ComponentState) then
    Exit;
  inherited Canvas.Font := Font;
  DrawDates(inherited Canvas);
end;

procedure TJvCustomTMTimeline.DrawFrame(ACanvas: TCanvas; AColor: TColor;
  ALineWidth: Integer; ARect: TRect);
var
  Tmp: TColor;
begin
  if ALineWidth = 0 then
    Exit;
  Tmp := ACanvas.Brush.Color;
  try
    ACanvas.Brush.Color := AColor;
    {$IFDEF VCL}
    ACanvas.FrameRect(ARect);
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    FrameRect(ACanvas, ARect);
    {$ENDIF VisualCLX}
    InflateRect(ARect, -Abs(ALineWidth) + 1, -Abs(ALineWidth) + 1);
    {$IFDEF VCL}
    ACanvas.FrameRect(ARect);
    ACanvas.FloodFill(ARect.Left - 1, ARect.Top - 1, AColor, fsBorder);
    {$ENDIF VCL}
    {$IFDEF VisualCLX}
    FrameRect(ACanvas, ARect);
    InflateRect(ARect, -1, -1);
    ACanvas.FillRect(ARect);
    {$ENDIF VisualCLX}
  finally
    ACanvas.Brush.Color := Tmp;
  end;
end;

procedure TJvCustomTMTimeline.SetFirstDate(const Value: TDate);
begin
  if Trunc(FDate) <> Trunc(Value) then
  begin
    if (FMinDate > 0) and (Trunc(FMinDate) > Trunc(FDate)) then
      FDate := FMinDate
    else
    if (FMaxDate > 0) and (Trunc(FMaxDate) < Trunc(FDate)) then
      FDate := Trunc(FMaxDate)
    else
      FDate := Trunc(Value);
    Change;
    Invalidate;
  end;
end;

procedure TJvCustomTMTimeline.SetReadOnly(const Value: Boolean);
begin
  if FReadOnly <> Value then
  begin
    FReadOnly := Value;
    FLeftBtn.Visible := not FReadOnly;
    FRightBtn.Visible := not FReadOnly;
    Invalidate;
  end;
end;

procedure TJvCustomTMTimeline.SetMonthFont(const Value: TFont);
begin
  FMonthFont.Assign(Value);
  Invalidate;
end;

procedure TJvCustomTMTimeline.SetSelDate(const Value: TDate);
var
  R: TRect;
begin
  if FSelDate <> Value then
  begin
    // erase old selection
    R := GetRectForDate(FSelDate);
    InflateRect(R, Selection.Pen.Width + 1, Selection.Pen.Width + 1);
    Windows.InvalidateRect(Handle, @R, True);
    FSelDate := Value;
    if Enabled then
    begin
      // draw new selection
      R := GetRectForDate(FSelDate);
      InflateRect(R, Selection.Pen.Width + 1, Selection.Pen.Width + 1);
      Windows.InvalidateRect(Handle, @R, True);
    end;
  end;
end;

procedure TJvCustomTMTimeline.SetDayWidth(const Value: Integer);
begin
  if (FDayWidth <> Value) and (Value > 0) then
  begin
    FDayWidth := Value;
    Invalidate;
  end;
end;

procedure TJvCustomTMTimeline.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited;
  if (Button = mbLeft) or ((Button = mbRight) and RightClickSelect) then
    SelDate := DateFromPos(X);
  if CanFocus and not Focused then
    SetFocus;
end;

procedure TJvCustomTMTimeline.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  inherited MouseUp(Button, Shift, X, Y);
end;