rm_common.pas

来自「report machine 2.3 功能强大」· PAS 代码 · 共 2,143 行 · 第 1/4 页

    DrawLine;
  end;
end;

procedure TRMRuler.OnFirstIndMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDragging := False;
  RichEdit.Paragraph.FirstIndent := Max(0, RulerToIndent(FirstInd.Left + FDragOfs,
    False));
  OnLeftIndMouseUp(Sender, Button, Shift, X, Y);
end;

procedure TRMRuler.OnLeftIndMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDragging := False;
  if FLineVisible then DrawLine;
  DeleteObject(SelectObject(FLineDC, FLinePen));
  ReleaseDC(RichEdit.Handle, FLineDC);
  RichEdit.Paragraph.LeftIndent := Max(-RichEdit.Paragraph.FirstIndent,
    RulerToIndent(LeftInd.Left + FDragOfs, False) -
    RichEdit.Paragraph.FirstIndent);
  if Assigned(FOnIndChanged) then FOnIndChanged(RichEdit);
end;

procedure TRMRuler.OnRightIndMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  FDragging := False;
  if FLineVisible then DrawLine;
  DeleteObject(SelectObject(FLineDC, FLinePen));
  ReleaseDC(RichEdit.Handle, FLineDC);
  RichEdit.Paragraph.RightIndent := Max(0, RulerToIndent(RightInd.Left + FDragOfs,
    True));
  if Assigned(FOnIndChanged) then FOnIndChanged(RichEdit);
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMUpDown }

constructor TRMUpDown.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  Min := -100;
  FCanvas := TControlCanvas.Create;
  TControlCanvas(FCanvas).Control := Self;
end;

destructor TRMUpDown.Destroy;
begin
  FCanvas.Free;
  inherited Destroy;
end;

constructor TRMUpDown.CreateForControl(aControl: TControl);
begin
  Create(aControl.Owner);
  Parent := aControl.Parent;
  SetBuddy(aControl);
end;

procedure TRMUpDown.SetBuddy(aBuddy: TControl);
begin
  FBuddy := aBuddy;
  Left := FBuddy.left + FBuddy.Width - Width - 2;
  Top := FBuddy.Top + 2;
  Height := FBuddy.Height - 4;
end;

procedure TRMUpDown.WMPaint(var Message: TWMPaint);
begin
  inherited;
  Paint;
end;

procedure TRMUpDown.Paint;
var
  liCenter: Integer;
  liStartY: Integer;
  liCount: Integer;
begin
  FCanvas.Pen.Color := clBlack;
  liCenter := (Width div 2) - 1;
  liStartY := 2;
  for liCount := 0 to 2 do
  begin
    FCanvas.MoveTo(liCenter - liCount, liStartY + liCount);
    FCanvas.LineTo(liCenter + liCount + 1, liStartY + liCount);
  end;

  liStartY := Height - 3;
  for liCount := 0 to 2 do
  begin
    FCanvas.MoveTo(liCenter - liCount, liStartY - liCount);
    FCanvas.LineTo(liCenter + liCount + 1, liStartY - liCount);
  end;
end;

type
  TColorEntry = record
    Name: PChar;
    Color: TColor;
  end;

const
  DefaultColors: array[0..39] of TColorEntry = (
    (Name: 'Black'; Color: $000000),
    (Name: 'Brown'; Color: $003399),
    (Name: 'Olive Green'; Color: $003333),
    (Name: 'Dark Green'; Color: $003300),
    (Name: 'Dark Teal'; Color: $663300),
    (Name: 'Dark blue'; Color: $800000),
    (Name: 'Indigo'; Color: $993333),
    (Name: 'Gray-80%'; Color: $333333),

    (Name: 'Dark Red'; Color: $000080),
    (Name: 'Orange'; Color: $0066FF),
    (Name: 'Dark Yellow'; Color: $008080),
    (Name: 'Green'; Color: $008000),
    (Name: 'Teal'; Color: $808000),
    (Name: 'Blue'; Color: $FF0000),
    (Name: 'Blue-Gray'; Color: $996666),
    (Name: 'Gray-50%'; Color: $808080),

    (Name: 'Red'; Color: $0000FF),
    (Name: 'Light Orange'; Color: $0099FF),
    (Name: 'Lime'; Color: $00CC99),
    (Name: 'Sea Green'; Color: $669933),
    (Name: 'Aqua'; Color: $CCCC33),
    (Name: 'Light Blue'; Color: $FF6633),
    (Name: 'Violet'; Color: $800080),
    (Name: 'Grey-40%'; Color: $969696),

    (Name: 'Pink'; Color: $FF00FF),
    (Name: 'Gold'; Color: $00CCFF),
    (Name: 'Yellow'; Color: $00FFFF),
    (Name: 'Bright Green'; Color: $00FF00),
    (Name: 'Turquoise'; Color: $FFFF00),
    (Name: 'Sky Blue'; Color: $FFCC00),
    (Name: 'Plum'; Color: $663399),
    (Name: 'Gray-25%'; Color: $C0C0C0),

    (Name: 'Rose'; Color: $CC99FF),
    (Name: 'Tan'; Color: $99CCFF),
    (Name: 'Light Yellow'; Color: $99FFFF),
    (Name: 'Light Green'; Color: $CCFFCC),
    (Name: 'Light Turquoise'; Color: $FFFFCC),
    (Name: 'Pale Blue'; Color: $FFCC99),
    (Name: 'Lavender'; Color: $FF99CC),
    (Name: 'White'; Color: clWhite)
    );

function rmBitmapFromResource(const aBitmapName: string): THandle;
begin
  Result := LoadBitmap(HInstance, PChar(aBitmapName));
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMDropDownPanel}

constructor TRMDropDownPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetBounds(-10000, -10000, Width, Height);
  ShowCaption := False;
  Resizable := False;
  FCreateControls := False;
end;

procedure TRMDropDownPanel.CloseUp;
begin
  TRMCustomPaletteButton(Owner).DroppedDown := False;
end;

procedure TRMDropDownPanel.EndSelection(Cancel: Boolean);
begin
  CloseUp;
end;

procedure TRMDropDownPanel.WMKillFocus(var Message: TWMKillFocus);
begin
  inherited;
  CloseUp;
end;

procedure TRMDropDownPanel.WMLButtonDown(var Message: TWMLButtonDown);
begin
  inherited;
  if not PtInRect(ClientRect, Point(Message.XPos, Message.YPos)) then
    EndSelection(True);
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMColorPanel}

constructor TRMColorPanel.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  ClientWidth := 20 + 18 * 8;
  ClientHeight := 18 * 5 + 24 * 2 + 6;

  FAutoCaption := RMLoadStr(STransparent);
  FMoreColorsCaption := RMLoadStr(SOther);
  FCurrentColor := clWindowText;
  FIsClear := False;
end;

destructor TRMColorPanel.Destroy;
begin
  inherited Destroy;
end;

procedure TRMColorPanel.CreateControls;
var
  tmp: TToolbarButton97;
  i, liLeft, liTop: Integer;
  bmp: TBitmap;
begin
  if FCreateControls then
  begin
    UpdateToolWindowState;
    Exit;
  end;

  FCreateControls := True;
  bmp := TBitmap.Create;
  try
    bmp.Width := 12; bmp.Height := 13;
    with bmp.Canvas do
    begin
      Brush.Color := clBtnFace;
      FillRect(Rect(0, 0, 12, 13));
    end;

    FAutoButton := TToolbarButton97.Create(Self);
    FAutoButton.SetBounds(10, 4, 144, 24);
    FAutoButton.Parent := Self;
    FAutoButton.Font.Name := '宋体';
    FAutoButton.Font.Size := 9;
    FAutoButton.OnClick := AutoButtonClickEvent;
    DrawAutoButtonGlyph(clWindowText);

    FMoreColorsButton := TToolbarButton97.Create(Self);
    FMoreColorsButton.SetBounds(10, Height - 32, 144, 24);
    FMoreColorsButton.Parent := Self;
    FMoreColorsButton.Caption := FMoreColorsCaption;
    FMoreColorsButton.ParentFont := True;
    FMoreColorsButton.Font.Assign(FAutoButton.Font);
    FMoreColorsButton.OnClick := MoreColorsButtonClickEvent;

    liLeft := 10; liTop := 28;
    for i := Low(DefaultColors) to High(DefaultColors) do
    begin
      with bmp.Canvas do
      begin
        Brush.Color := DefaultColors[i].Color;
        Pen.Color := clBtnShadow;
        Rectangle(0, 0, 12, 12);
      end;
      tmp := TToolbarButton97.Create(Self);
      with tmp do
      begin
        Parent := Self;
        SetBounds(liLeft, liTop, 18, 18);
        Hint := DefaultColors[i].Name;
        Glyph.Assign(bmp);
        ShowHint := True;
        Tag := DefaultColors[i].Color;
        GroupIndex := 1;
        AllowAllUp := True;
        OnClick := ColorButtonClickEvent;
      end;

      Inc(liLeft, tmp.Width);
      if (i + 1) mod 8 = 0 then
      begin
        Inc(liTop, tmp.Height);
        liLeft := 10;
      end;
    end;
  finally
    bmp.Free;
  end;
  UpdateToolWindowState;
end;

procedure TRMColorPanel.DrawAutoButtonGlyph(aColor: TColor);
var
  liSide, liLeft, liTop: Integer;
  bmp: TBitmap;
begin
  bmp := TBitmap.Create;
  try
    bmp := TBitmap.Create;
    bmp.Width := FAutoButton.Width - 2;
    bmp.Height := FAutoButton.Height - 2;
    bmp.TransparentColor := clWhite;

    bmp.Canvas.Brush.Style := bsSolid;
    bmp.Canvas.Brush.Color := clWhite;
    bmp.Canvas.FillRect(Rect(0, 0, bmp.Width, bmp.Height));

    bmp.Canvas.Brush.Style := bsSolid;
    bmp.Canvas.Brush.Color := clGray;
    bmp.Canvas.FrameRect(Rect(2, 2, bmp.Width - 3, bmp.Height - 2));
    if (FPaletteType = rmptFont) then
    begin
      liSide := bmp.Height - 5;
      bmp.Canvas.FrameRect(Rect(5, 4, liSide, liSide));
      Dec(liSide);
      bmp.Canvas.Brush.Color := aColor;
      bmp.Canvas.FillRect(Rect(6, 5, liSide, liSide));
    end;

    bmp.Canvas.Brush.Style := bsClear;
    liLeft := (bmp.Width - bmp.Canvas.TextWidth(FAutoCaption)) div 2;
    liTop := (bmp.Height - bmp.Canvas.TextHeight(FAutoCaption)) div 2;
    bmp.Canvas.Font.Assign(FAutoButton.Font);
    bmp.Canvas.TextOut(liLeft, liTop, FAutoCaption);
    FAutoButton.Glyph.Assign(bmp);
  finally
    bmp.Free;
  end;
end;

procedure TRMColorPanel.MoreColorsButtonClickEvent(Sender: TObject);
var
  ldlgColor: TColorDialog;
begin
  ldlgColor := TColorDialog.Create(Self);
  if ldlgColor.Execute then
  begin
    FCurrentColor := ColorToRGB(ldlgColor.Color);
	  if Assigned(FOnColorChange) then FOnColorChange(Self);
  end;
  ldlgColor.Free;
  CloseUp;
end;

procedure TRMColorPanel.ColorButtonClickEvent(Sender: TObject);
begin
  FIsClear := False;
  FCurrentColor := TColor(TToolbarButton97(Sender).Tag);
  if Assigned(FOnColorChange) then FOnColorChange(Self);
  CloseUp;
end;

procedure TRMColorPanel.AutoButtonClickEvent(Sender: TObject);
begin
  FIsClear := FPaletteType <> rmptFont;
  if FPaletteType = rmptFont then
    FCurrentColor := clWindowText
  else
    FCurrentColor := clWindow;
  if Assigned(FOnColorChange) then FOnColorChange(Self);
  CloseUp;
end;

procedure TRMColorPanel.SetCurrentColor(aColor: TColor);
begin
  if FCurrentColor = aColor then Exit;
  FCurrentColor := aColor;
end;

procedure TRMColorPanel.UpdateToolWindowState;
var
  i: Integer;
  lButton: TToolbarButton97;
begin
  if FPaletteType = rmptFont then
    FAutoButton.Down := FCurrentColor = clWindowText
  else
    FAutoButton.Down := FIsClear;

  DrawAutoButtonGlyph(clWindowText);
  for i := 0 to ControlCount - 1 do
  begin
    lButton := TToolbarButton97(Controls[i]);
    lButton.Down := lButton.Tag = FCurrentColor;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMCustomPaletteButton}

constructor TRMCustomPaletteButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPopupMenu := TPopupMenu.Create(Self);
  DropdownAlways := True;
  DropdownCombo := True;
  Width := 34;
  DropDownMenu  := FPopupMenu;

  OnDropdown := OnDropDownEvent;
end;

destructor TRMCustomPaletteButton.Destroy;
begin
  FPopupPanel.Free;
	FPopupMenu.Free;
  inherited Destroy;
end;

procedure TRMCustomPaletteButton.SetDroppedDown(const Value: Boolean);

  procedure ShowDropDownPanel;
  var
    Pt: TPoint;
    ParentTop: Integer;
  begin
    Pt := Parent.ClientToScreen(Point(Left - 1, Top + Height));
    if (Pt.y + FPopupPanel.Height) > Screen.Height then Pt.y := Screen.Height - FPopupPanel.Height;
    ParentTop := Parent.ClientToScreen(Point(Left, Top)).y;
    if Pt.y < ParentTop then Pt.y := ParentTop - FPopupPanel.Height;
    if (Pt.x + FPopupPanel.Width) > Screen.Width then Pt.x := Screen.Width - FPopupPanel.Width;
    if Pt.x < 0 then Pt.x := 0;
    FPopupPanel.CreateControls;
    SetWindowPos(FPopupPanel.Handle, HWND_TOPMOST, Pt.X, Pt.Y, FPopupPanel.Width, FPopupPanel.Height, SWP_SHOWWINDOW);
  end;

begin
  if FDroppedDown <> Value then
  begin
    FDroppedDown := Value;
    if FDroppedDown then
    begin
      if FPopupPanel <> nil then
        ShowDropDownPanel;
    end
    else
    begin
      ShowWindow(FPopupPanel.Handle, SW_HIDE);
    end;
  end;
end;

procedure TRMCustomPaletteButton.OnDropDownEvent(Sender: TObject; var ShowMenu, RemoveClicks: Boolean);
begin
  ShowMenu := True;
  DroppedDown := True;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMColorPickerButton}

constructor TRMColorPickerButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPopupPanel := TRMColorPanel.Create(Self);
  TRMColorPanel(FPopupPanel).OnColorChange := PaletteColorChangeEvent;
end;

procedure TRMColorPickerButton.PaletteColorChangeEvent(Sender: TObject);
begin
  DrawButtonGlyph(CurrentColor);
  if Assigned(FOnColorChange) then FOnColorChange(Self);
end;

procedure TRMColorPickerButton.SetColorType(aColorType: TRMColorPaletteType);
begin
  FColorType := aColorType;
  case aColorType of
    rmptFont:
      begin
        Glyph.Handle := rmBitmapFromResource('RM_FONTCOLOR');
        GlyphMask.Handle := rmBitmapFromResource('RM_FONTCOLORMASK');
      end;
    rmptHighlight:
      begin
        Glyph.Handle := rmBitmapFromResource('RM_HIGHLIGHTCOLOR');
        GlyphMask.Handle := rmBitmapFromResource('RM_HIGHLIGHTCOLORMASK');
      end;
    rmptFill:
      begin
        Glyph.Handle := rmBitmapFromResource('RM_FILLCOLOR');
        GlyphMask.Handle := rmBitmapFromResource('RM_FILLCOLORMASK');
      end;
    rmptLine:
      begin
        Glyph.Handle := rmBitmapFromResource('RM_LINECOLOR');
        GlyphMask.Handle := rmBitmapFromResource('RM_LINECOLORMASK');
      end;
  end;

  if PopupPanel <> nil then
    TRMColorPanel(PopupPanel).PaletteType := aColorType;
  DrawButtonGlyph(CurrentColor);
end;

procedure TRMColorPickerButton.DrawButtonGlyph(aColor: TColor);
begin
  Glyph.Canvas.Brush.Style := bsSolid;
  if IsClear then
    Glyph.Canvas.Brush.Color := clBtnFace
  else
    Glyph.Canvas.Brush.Color := aColor;

  Glyph.Canvas.FillRect(Rect(0, 12, 16, 16));
  Invalidate;
end;

function TRMColorPickerButton.GetCurrentColor: TColor;
begin
  Result := TRMColorPanel(PopupPanel).CurrentColor;
end;

procedure TRMColorPickerButton.SetCurrentColor(aValue: TColor);
begin
	if aValue <> TRMColorPanel(PopupPanel).CurrentColor then
  begin
	  TRMColorPanel(PopupPanel).CurrentColor := aValue;
  	DrawButtonGlyph(aValue);
  end;
end;

function TRMColorPickerButton.GetIsClear: Boolean;
begin
  Result := TRMColorPanel(PopupPanel).IsClear;
end;

procedure TRMColorPickerButton.setIsClear(aValue: Boolean);
begin
  TRMColorPanel(PopupPanel).IsClear := aValue;
end;

end.