rm_ctrls.pas

这是一个功能强大

    procedure CreateParams(var Params: TCreateParams); override;
    procedure AdjustClientRect(var Rect: TRect); override;
    procedure AlignControls(AControl: TControl; var Rect: TRect); override;
  public
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
    procedure Close(Sender: TObject = nil);
    procedure Popup(ACaller: TControl);

    property Caller: TControl read FCaller;
  published
    property OnClose: TNotifyEvent read FOnClose write FOnClose;
    property OnPopup: TNotifyEvent read FOnPopup write FOnPopup;
  end;

{$IFDEF USE_TB2K}
  TRMArrowButton = class(TGraphicControl)
  private
    FGlyph: Pointer;
    FGroupIndex: Integer;
    FDown: Boolean;
    FArrowClick: Boolean;
    FPressBoth: Boolean;
    FArrowWidth: Integer;
    FAllowAllUp: Boolean;
    FFlat: Boolean;
    FMouseInControl: Boolean;
    FDropDownMenu: TPopupMenu;
    FOnDrop: TNotifyEvent;

    function GetGlyph: TBitmap;
    procedure SetGlyph(Value: TBitmap);
    function GetNumGlyphs: TNumGlyphs;
    procedure SetNumGlyphs(Value: TNumGlyphs);
    procedure SetDown(Value: Boolean);
    procedure SetFlat(Value: Boolean);
    procedure SetAllowAllUp(Value: Boolean);
    procedure SetGroupIndex(Value: Integer);
    procedure SetArrowWidth(Value: Integer);
    procedure UpdateTracking;
    procedure MouseEnter(AControl: TControl);
    procedure MouseLeave(AControl: TControl);
    procedure GlyphChanged(Sender: TObject);

    procedure WMLButtonDblClk(var Msg: TWMLButtonDown); message WM_LBUTTONDBLCLK;
  protected
    FState: TButtonState;

    procedure WndProc(var Msg: TMessage); override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property Glyph: TBitmap read GetGlyph write SetGlyph;
    property NumGlyphs: TNumGlyphs read GetNumGlyphs write SetNumGlyphs default 1;
    property Align;
    property Action;
    property Anchors;
    property Constraints;
    property AllowAllUp: Boolean read FAllowAllUp write SetAllowAllUp default False;
    property ArrowWidth: Integer read FArrowWidth write SetArrowWidth default 13;
    property GroupIndex: Integer read FGroupIndex write SetGroupIndex default 0;
    property Down: Boolean read FDown write SetDown default False;
    property DropDown: TPopupMenu read FDropDownMenu write FDropDownMenu;
    property Caption;
    property Enabled;
    property Flat: Boolean read FFlat write SetFlat default False;
    property Font;
    property ParentFont default True;
    property ParentShowHint;
    property PressBoth: Boolean read FPressBoth write FPressBoth default True;
    property ShowHint;
    property Visible;
    property OnDrop: TNotifyEvent read FOnDrop write FOnDrop;
    property OnClick;
    property OnDblClick;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;
{$ENDIF}

  { TRMPopupWindowButton }
  TRMPopupWindowButton = {$IFDEF USE_TB2K}class(TRMArrowButton){$ELSE}class(TRMToolbarButton){$ENDIF}
  private
    FActive: Boolean;
    FDropDownPanel: TRMPopupWindow;

    procedure SetActive(aValue: Boolean);
    procedure DropdownPanel_OnClose(Sender: TObject);
    procedure ShowDropDownPanel;
  protected
    function GetDropDownPanel: TRMPopupWindow; virtual;
    procedure SetDropdownPanel(Value: TRMPopupWindow);
  public
    constructor Create(AOwner: TComponent); override;
    procedure Click; override;

    property Active: Boolean read FActive write SetActive;
  published
    property DropDownPanel: TRMPopupWindow read GetDropDownPanel write SetDropdownPanel;
  end;

  { TRMColorPickerButton }

  TRMColorType = (rmptFont, rmptLine, rmptFill, rmptHighlight, rmptCustom);

{$IFDEF USE_INTERNAL_JVCL}

{$IFDEF USE_TB2K}
  TRMColorSpeedButton = class(TSpeedButton)
{$ELSE}
  TRMColorSpeedButton = class(TRMToolbarButton)
{$ENDIF}
  private
    FCurColor: TColor;
  protected
    procedure Paint; override;
  published
    property CurColor: TColor read FCurColor write FCurColor;
  end;

  { TRMColorPickerButton }
  TRMColorPickerButton = class(TRMPopupWindowButton)
  private
    FPopup: TRMPopupWindow;

    FColorButtons: array[0..MaxColorButtonNumber - 1] of TRMColorSpeedButton;
    FAutoButton: TRMColorSpeedButton;
    FOtherButton: {$IFDEF USE_TB2K}TSpeedButton{$ELSE}TRMToolbarButton{$ENDIF};
    FColorDialog: TColorDialog;
    FColorType: TRMColorType;
    FCurrentColor: TColor;
    FAutoColor: TColor;
    FAutoCaption: string;

    FHoriMargin: integer;
    FTopMargin: integer;
    FBottomMargin: integer;
    FDragBarHeight: integer;
    FDragBarSpace: integer;
    FButtonHeight: integer;
    FColorSpace: integer;
    FColorSize: integer;
    FColorSpaceTop: integer;
    FColorSpaceBottom: integer;

    FOnColorChange: TNotifyEvent;

    procedure ColorButtonClick(Sender: TObject);
    procedure DrawButtonGlyph(aColor: TColor);

    procedure SetSelectedColor(const Value: TColor);
    procedure SetColorType(const Value: TRMColorType);
    function GetCustomColors: TStrings;
    procedure SetCustomColors(const Value: TStrings);
  protected
    function GetDropDownPanel: TRMPopupWindow; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property TopMargin: integer read FTopMargin write FTopMargin;
    property BottomMargin: integer read FBottomMargin write FBottomMargin;
    property HoriMargin: integer read FHoriMargin write FHoriMargin;
    property DragBarHeight: integer read FDragBarHeight write FDragBarHeight;
    property DragBarSpace: integer read FDragBarSpace write FDragBarSpace;
    property ColorSpace: integer read FColorSpace write FColorSpace;
    property ColorSpaceTop: integer read FColorSpaceTop write FColorSpaceTop;
    property ColorSpaceBottom: integer read FColorSpaceBottom write FColorSpaceBottom;
    property ColorSize: integer read FColorSize write FColorSize;
    property ButtonHeight: integer read FButtonHeight write FButtonHeight;

    property AutoCaption: string read FAutoCaption write FAutoCaption;
    property CurrentColor: TColor read FCurrentColor write SetSelectedColor;
    property ColorType: TRMColorType read FColorType write SetColorType;
    property CustomColors: TStrings read GetCustomColors write SetCustomColors;

    property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
  end;
{$ELSE}

  TRMColorPickerButton = class(TJvOfficeColorButton)
  private
    FColorType: TRMColorType;
    procedure SetColorType(const Value: TRMColorType);
    function GetCurrentColor: TColor;
    procedure SetCurrentColor(const Value: TColor);
  public
    constructor Create(AOwner: TComponent); override;
    property ColorType: TRMColorType read FColorType write SetColorType;
    property CurrentColor :TColor read GetCurrentColor write SetCurrentColor;
  end;
{$ENDIF USE_INTERNAL_JVCL}

  TRMRulerOrientationType = (roHorizontal, roVertical);

  {@TRMDesignerRuler }
  TRMDesignerRuler = class(TPaintBox) //TGraphicControl)
  private
    FDrawRect: TRect;
    FGuide1X: Integer;
    FGuide1Y: Integer;
    FGuide2X: Integer;
    FGuide2Y: Integer;
    FGuideHeight: Integer;
    FGuideWidth: Integer;
    FHalfTicks: Boolean;
    FMargin: Integer;
    FOrientation: TRMRulerOrientationType;
    FPixelIncrement: Double;
    FScrollOffset: Integer;
    FThickness: Integer;
    FTicksPerUnit: Integer;
    FTickFactor: Single;
    FUnits: TRMUnitType;
    FScale: Double;

    procedure DrawGuide(aGuideX, aGuideY: Integer);
    procedure InitGuides;
    procedure PaintRuler;
    procedure SetOrientation(aOrientation: TRMRulerOrientationType);
    procedure SetUnits(aUnit: TRMUnitType);
    procedure SetScrollOffset(Value: Integer);
    function UpdateGuidePosition(aNewPosition: Integer; var aGuideX, aGuideY: Integer): Boolean;
    procedure ChangeUnits(aUnit: TRMUnitType);
  protected
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure Paint; override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    procedure Scroll(Value: Integer);
    procedure SetGuides(aPosition1, aPosition2: Integer);
    property Orientation: TRMRulerOrientationType read FOrientation write SetOrientation;
    property Units: TRMUnitType read FUnits write SetUnits;
    property ScrollOffset: Integer read FScrollOffset write SetScrollOffset;
    property PixelIncrement: Double read FPixelIncrement;
    property Scale: Double read FScale write FScale;
  end;

  TRMScrollBarKind = (rmsbHorizontal, rmsbVertical);
  TRMScrollEvent = procedure(Sender: TObject; Kind: TRMScrollBarKind) of object;
  TRMScrollBox = class;

  { TRMScrollBar }
  TRMScrollBar = class(TPersistent)
  private
    FScrollBox: TRMScrollBox;
    FKind: TRMScrollBarKind;
    FScrollInfo: TScrollInfo;
    FWidth: Integer;

    FSmallChange: Integer;
    FLargeChange: Integer;
    FRange: Integer;
    FPosition: Integer;
    FPageSize: Integer;
    FThumbValue: Integer;

    constructor Create(aScrollBox: TRMScrollBox; aKind: TRMScrollBarKind);
    procedure UpdateScrollBar;
    function GetBarFlag: Integer;
    procedure ScrollMessage(var aMessage: TWMScroll);

    function GetTrackPos: Integer;
    procedure SetPageSize(Value: Integer);
    procedure SetPosition(Value: Integer);
    procedure SetRange(Value: Integer);
  protected
  public
    property TrackPos: Integer read GetTrackPos;
  published
    property SmallChange: Integer read FSmallChange write FSmallChange;
    property LargeChange: Integer read FLargeChange write FLargeChange;
    property Position: Integer read FPosition write SetPosition;
    property Range: Integer read FRange write SetRange;
    property PageSize: Integer read FPageSize write SetPageSize;
    property ThumbValue: Integer read FThumbValue write FThumbValue;
    property Width: Integer read FWidth;
  end;

  { TRMScrollBox }
  TRMScrollBox = class(TCustomControl)
  private
    FHorzScrollBar: TRMScrollBar;
    FVertScrollBar: TRMScrollBar;
    FOnChange: TRMScrollEvent;

    procedure WMEraseBackground(var Message: TMessage); message WM_ERASEBKGND;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GETDLGCODE;
    procedure WMHScroll(var Message: TWMHScroll); message WM_HSCROLL;
    procedure WMVScroll(var Message: TWMVScroll); message WM_VSCROLL;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Paint; override;

    property OnKeyDown;
    property HorzScrollBar: TRMScrollBar read FHorzScrollBar;
    property VertScrollBar: TRMScrollBar read FVertScrollBar;
  published
    property OnChange: TRMScrollEvent read FOnChange write FOnChange;
  end;

function RMNewLine: TRMSeparatorMenuItem;
function RMNewItem(const ACaption: string; AShortCut: TShortCut;
  AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
  const AName: string; ATag: integer = 0): TRMMenuItem;

implementation

uses RM_Utils, RM_Const, RM_Const1, RM_Class;

const
  sSpinUpBtn = 'RM_MYSPINUP';
  sSpinDownBtn = 'RM_MYSPINDOWN';
  cDropdownComboWidth = 11;

const
  InitRepeatPause = 400; { pause before repeat timer (ms) }
  RepeatPause = 100;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMDockableToolbar }

constructor TRMDockableToolbar.Create(AOwner: TComponent);
begin
  inherited;
  EdgeBorders := [];
  Flat := True;
  AutoSize := True;
  DragKind := dkDock;
  DragMode := dmAutomatic;
end;

destructor TRMDockableToolbar.Destroy;
begin
  inherited;
end;

procedure TRMDockableToolbar.BeginUpdate;
begin
  DisableAlign;
end;

procedure TRMDockableToolbar.EndUpdate;
begin
  EnableAlign;
end;

procedure TRMDockableToolbar.DoDock(NewDockSite: TWinControl; var ARect: TRect);
begin
  inherited;
end;

function TRMDockableToolbar.DoUnDock(NewTarget: TWinControl;
  Client: TControl): Boolean;
begin
  Result := inherited DoUnDock(NewTarget, Client);
end;

procedure TRMDockableToolbar.AddControl(aControl: TControl);
begin
  aControl.Left := GetRightMostControlPos + 1;
  aControl.Parent := Self;
end;

function TRMDockableToolbar.GetRightMostControlPos: Integer;

  function _GetRightMostControl: TControl;
  var
    liIndex: Integer;
    lControl: TControl;
  begin

    Result := nil;

    for liIndex := 0 to ControlCount - 1 do
    begin
      lControl := Controls[liIndex];

      if (Result = nil) or ((lControl.Visible) and (lControl.Left > Result.Left)) then
        Result := lControl;

    end;
  end;

var
  lControl: TControl;
begin
  lControl := _GetRightMostControl;
  if (lControl <> nil) then
    Result := lControl.Left + lControl.Width
  else
    Result := 0;
end;

procedure TRMDockableToolbar.AlignControls(AControl: TControl; var ARect: TRect);
begin
  inherited;

  Width := GetRightMostControlPos;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMToolbarSeparator }

constructor TRMToolbarSeparator.Create(AOwner: TComponent);
begin
  inherited;

  Style := tbsSeparator;
  Grouped := False;
  Width := 8;
end;

function RMNewLine: TRMSeparatorMenuItem;
begin
  Result := TRMSeparatorMenuItem.Create(Application);
end;

function RMNewItem(const ACaption: string; AShortCut: TShortCut;
  AChecked, AEnabled: Boolean; AOnClick: TNotifyEvent; hCtx: THelpContext;
  const AName: string; ATag: integer = 0): TRMMenuItem;
begin
  Result := TRMMenuItem.Create(Application);
  with Result do
  begin
    Caption := ACaption;
    ShortCut := AShortCut;
    OnClick := AOnClick;
    HelpContext := hCtx;
    Checked := AChecked;
    Enabled := AEnabled;
    //    Name := AName;
    Tag := ATag;
  end;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMEdit}

procedure TRMEdit.SetAddTo(Value: TRMToolBar);
begin
{$IFDEF USE_TB2k}
  Value.Items.Add(self);
{$ELSE}
  if Parent <> Value then
    Parent := Value;
{$ENDIF}
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{ TRMMenuBar }

{$IFNDEF USE_TB2K}

procedure TRMMenuBar.BeginUpdate;
begin
 //
end;

procedure TRMMenuBar.EndUpdate;
begin
 //
end;
{$ENDIF}

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMToolbarSep}

procedure TRMToolbarSep.SetAddTo(Value: TRMToolBar);
begin