rm_common.pas

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

unit RM_common;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, Menus, TB97Tlwn, TB97Ctls;

type
	{ TRMCustomComboBox }
  TRMCustomComboBox = class(TCustomComboBox)
  private
    FUpDropdown: Boolean;
    FButtonWidth: Integer;
    msMouseInControl: Boolean;
    FListHandle: HWND;
    FListInstance: Pointer;
    FDefListProc: Pointer;
    FChildHandle: HWND;
    FSolidBorder: Boolean;
    FReadOnly: Boolean;
    FEditOffset: Integer;
    procedure ListWndProc(var Message: TMessage);
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure CMEnabledChanged(var Msg: TMessage); message CM_ENABLEDCHANGED;
    procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
    procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure PaintButtonGlyph(DC: HDC; x: Integer; y: Integer);
    procedure PaintButton(bnStyle: Integer);
    procedure PaintBorder(DC: HDC; const SolidBorder: Boolean);
    procedure PaintDisabled;
    function GetSolidBorder: Boolean;
    function GetListHeight: Integer;
    procedure SetReadOnly(Value: Boolean);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
    procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override;
    procedure WndProc(var Message: TMessage); override;
    procedure CreateWnd; override;
    property SolidBorder: Boolean read FSolidBorder;
    property ReadOnly: Boolean read FReadOnly write SetReadOnly default False;
    procedure DrawImage(DC: HDC; Index: Integer; R: TRect); dynamic;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

{ TRMComboBox }
  TRMComboBox = class(TRMCustomComboBox)
  published
    property Color;
    property DragMode;
    property DragCursor;
    property DropDownCount;
    property Enabled;
    property Font;
    property ItemHeight;
    property Items;
    property MaxLength;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Sorted;
    property TabOrder;
    property TabStop;
    property Text;
    property ReadOnly;
    property Visible;
    property ItemIndex;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDrawItem;
    property OnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
{$IFDEF Delphi4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
    property OnEndDock;
    property OnStartDock;
{$ENDIF}
  end;

  { TRMFontPreview }
  TRMFontPreview = class(TWinControl)
  private
    FPanel: TPanel;
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  end;

{ TRMFontComboBox }
  TFontDevice = (rmfdScreen, rmfdPrinter, rmfdBoth);
  TFontListOption = (rmfoAnsiOnly, rmfoTrueTypeOnly, rmfoFixedPitchOnly,
    rmfoNoOEMFonts, rmfoOEMFontsOnly, rmfoScalableOnly, rmfoNoSymbolFonts);
  TFontListOptions = set of TFontListOption;

  TRMFontComboBox = class(TRMCustomComboBox)
  private
    FTrueTypeBMP: TBitmap;
    FDeviceBMP: TBitmap;
    FOnChange: TNotifyEvent;
    FDevice: TFontDevice;
    FUpdate: Boolean;
    FUseFonts: Boolean;
    FOptions: TFontListOptions;
    FRMFontViewForm: TRMFontPreview;
    procedure SetFontName(const NewFontName: TFontName);
    function GetFontName: TFontName;
    function GetTrueTypeOnly: Boolean;
    procedure SetDevice(Value: TFontDevice);
    procedure SetOptions(Value: TFontListOptions);
    procedure SetTrueTypeOnly(Value: Boolean);
    procedure SetUseFonts(Value: Boolean);
    procedure Reset;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
    procedure WMFontChange(var Message: TMessage); message WM_FONTCHANGE;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
    procedure CMFontChange(var Message: TMessage); message CM_FONTCHANGE;
  protected
    procedure Init;
    procedure PopulateList; virtual;
    procedure Change; override;
    procedure Click; override;
    procedure DoChange; dynamic;
    procedure CreateWnd; override;
    procedure DrawItem(Index: Integer; Rect: TRect; State: TOwnerDrawState); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Text;
  published
    property Device: TFontDevice read FDevice write SetDevice default rmfdScreen;
    property FontName: TFontName read GetFontName write SetFontName;
    property Options: TFontListOptions read FOptions write SetOptions default [];
    property TrueTypeOnly: Boolean read GetTrueTypeOnly write SetTrueTypeOnly
      stored False; { obsolete, use Options instead }
    property UseFonts: Boolean read FUseFonts write SetUseFonts default False;
    property Color;
    property Ctl3D;
    property DragMode;
    property DragCursor;
    property Enabled;
    property Font;
{$IFDEF Delphi4}
    property Anchors;
    property BiDiMode;
    property Constraints;
    property DragKind;
    property ParentBiDiMode;
{$ENDIF}
{$IFNDEF VER90}
    property ImeMode;
    property ImeName;
{$ENDIF}
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Style;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnDropDown;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnStartDrag;
{$IFDEF Delphi5}
    property OnContextPopup;
{$ENDIF}
{$IFDEF Delphi4}
    property OnEndDock;
    property OnStartDock;
{$ENDIF}
  end;

  {TRMColorSelector}
{  TRMColorSelector = class(TPanel)
  private
    FColor: TColor;
    FOtherBtn: TSpeedButton;
    FOnColorSelected: TNotifyEvent;

    procedure ButtonClick(Sender: TObject);
    procedure SetColor(Value: TColor);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    property Color: TColor read FColor write SetColor;
    property OnColorSelected: TNotifyEvent read FOnColorSelected write
      FOnColorSelected;
  end;
}
  { TRMTrackIcon }
  TRMTrackIcon = class(TGraphicControl)
  private
    TrackBmp: TBitmap;
    FBitmapName: string;
    procedure SetBitmapName(const Value: string);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property BitmapName: string read FBitmapName write SetBitmapName;
  end;

  { TRMRuler }
  TRMRuler = class(TPanel)
  private
    FRichEdit: TCustomRichEdit;
    ScreenPixelsPerInch: integer;
    FDragOfs: Integer;
    FLineDC: HDC;
    FLinePen: HPen;
    FDragging: Boolean;
    FLineVisible: Boolean;
    FLineOfs: Integer;

    FirstInd: TRMTrackIcon;
    LeftInd: TRMTrackIcon;
    RightInd: TRMTrackIcon;
    FOnIndChanged: TNotifyEvent;
    procedure DrawLine;
    procedure CalcLineOffset(Control: TControl);
    function IndentToRuler(Indent: Integer; IsRight: Boolean): Integer;
    function RulerToIndent(RulerPos: Integer; IsRight: Boolean): Integer;
    procedure OnRulerItemMouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OnRulerItemMouseMove(Sender: TObject; Shift: TShiftState;
      X, Y: Integer);
    procedure OnFirstIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OnLeftIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure OnRightIndMouseUp(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  protected
    procedure Paint; override;
  public
    constructor Create(AOwner: TComponent); override;
    procedure UpdateInd;
    property RichEdit: TCustomRichEdit read FRichEdit write FRichEdit;
    property OnIndChanged: TNotifyEvent read FOnIndChanged write FOnIndChanged;
  end;

  { TRMUpDown }
  TRMUpDown = class(TUpDown)
  private
    FCanvas: TControlCanvas;
    FBuddy: TControl;

    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure SetBuddy(aBuddy: TControl);
  protected
    procedure Paint;
  public
    constructor Create(aOwner: TComponent); override;
    constructor CreateForControl(aControl: TControl); virtual;
    destructor Destroy; override;

    property Buddy: TControl read FBuddy write SetBuddy;
  end;

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

  { TRMDropDownPanel }
  TRMDropDownPanel = class(TToolWindow97)
  private
    FCreateControls: Boolean;
    procedure EndSelection(Cancel: Boolean);
    procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
  protected
    procedure CreateControls; virtual; abstract;
    procedure CloseUp;
  public
    constructor Create(AOwner: TComponent); override;
  end;

  { TRMColorPanel }
  TRMColorPanel = class(TRMDropDownPanel)
  private
    FCurrentColor: TColor;
    FAutoCaption: string;
    FMoreColorsCaption: string;
    FAutoButton: TToolbarButton97;
    FMoreColorsButton: TToolbarButton97;
    FPaletteType: TRMColorPaletteType;
    FIsClear: Boolean;
    FOnColorChange: TNotifyEvent;

    procedure SetCurrentColor(aColor: TColor);
    procedure DrawAutoButtonGlyph(aColor: TColor);
    procedure UpdateToolWindowState;
    procedure MoreColorsButtonClickEvent(Sender: TObject);
    procedure ColorButtonClickEvent(Sender: TObject);
    procedure AutoButtonClickEvent(Sender: TObject);
  protected
    procedure CreateControls; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property PaletteType: TRMColorPaletteType read FPaletteType write FPaletteType;
    property AutoCaption: string read FAutoCaption write FAutoCaption;
    property MoreColorsCaption: string read FMoreColorsCaption write FMoreColorsCaption;
    property CurrentColor: TColor read FCurrentColor write SetCurrentColor;
    property IsClear: Boolean read FIsClear write FIsClear;
    property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
  end;

  { TRMCustomPaletteButton }
  TRMCustomPaletteButton = class(TToolbarButton97)
  private
		FPopupMenu: TPopupMenu;
    FPopupPanel: TRMDropDownPanel;
    FDroppedDown: Boolean;
    procedure SetDroppedDown(const Value: Boolean);
    procedure OnDropDownEvent(Sender: TObject; var ShowMenu, RemoveClicks: Boolean);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property DroppedDown: Boolean read FDroppedDown write SetDroppedDown;
    property PopupPanel: TRMDropDownPanel read FPopupPanel;
  published
  end;

  { TRMColorPickerButton }
  TRMColorPickerButton = class(TRMCustomPaletteButton)
  private
    FColorType: TRMColorPaletteType;
    FOnColorChange: TNotifyEvent;
    procedure SetColorType(aColorType: TRMColorPaletteType);
    procedure DrawButtonGlyph(aColor: TColor);
    function GetCurrentColor: TColor;
    procedure SetCurrentColor(aValue: TColor);
    function GetIsClear: Boolean;
    procedure setIsClear(aValue: Boolean);
    procedure PaletteColorChangeEvent(Sender: TObject);
  protected
  public
    constructor Create(AOwner: TComponent); override;
    property ColorType: TRMColorPaletteType read FColorType write SetColorType;
    property CurrentColor: TColor read GetCurrentColor write SetCurrentColor;
    property IsClear: Boolean read GetIsClear write SetIsClear;
    property OnColorChange: TNotifyEvent read FOnColorChange write FOnColorChange;
  end;

implementation

{$R RM_common.RES}

uses RM_Utils, RM_Const, Printers, Math;

const
  RulerAdj = 4 / 3;

function GetFontMetrics(Font: TFont): TTextMetric;
var
  DC: HDC;
  SaveFont: HFont;
begin
  DC := GetDC(0);
  SaveFont := SelectObject(DC, Font.Handle);
  GetTextMetrics(DC, Result);
  SelectObject(DC, SaveFont);
  ReleaseDC(0, DC);
end;

function GetFontHeight(Font: TFont): Integer;
begin
  Result := GetFontMetrics(Font).tmHeight;
end;

{------------------------------------------------------------------------------}
{------------------------------------------------------------------------------}
{TRMCustomComboBox}

{$IFDEF Delphi6}
{$WARN SYMBOL_DEPRECATED OFF}
{$ENDIF}
constructor TRMCustomComboBox.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FListInstance := MakeObjectInstance(ListWndProc);
  FDefListProc := nil;
  FButtonWidth := 11;
  ItemHeight := GetFontHeight(Font);
  Width := 100;
  FEditOffset := 0;
end;

destructor TRMCustomComboBox.Destroy;
begin
  inherited Destroy;
  FreeObjectInstance(FListInstance);
end;

{$IFDEF Delphi6}
{$WARN SYMBOL_DEPRECATED ON}
{$ENDIF}
procedure TRMCustomComboBox.SetReadOnly(Value: Boolean);
begin
  if FReadOnly <> Value then
  begin
    FReadOnly := Value;
    if HandleAllocated then
      SendMessage(EditHandle, EM_SETREADONLY, Ord(Value), 0);
  end;
end;

procedure TRMCustomComboBox.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params do
    Style := (Style and not CBS_DROPDOWNLIST) or CBS_OWNERDRAWFIXED or CBS_DROPDOWN;
end;

procedure TRMCustomComboBox.CreateWnd;
var
  exStyle: Integer;
begin
  inherited;
  SendMessage(EditHandle, EM_SETREADONLY, Ord(FReadOnly), 0);
  // Desiding, which of the handles is DropDown list handle...
  if FChildHandle <> EditHandle then
    FListHandle := FChildHandle;
  //.. and superclassing it
  FDefListProc := Pointer(GetWindowLong(FListHandle, GWL_WNDPROC));
  SetWindowLong(FListHandle, GWL_WNDPROC, Longint(FListInstance));
  // here we setting up the border's edge
  exStyle := GetWindowLong(FListHandle, GWL_EXSTYLE);
  SetWindowLong(FListHandle, GWL_EXSTYLE, exStyle or WS_EX_CLIENTEDGE);
  exStyle := GetWindowLong(FListHandle, GWL_STYLE);
  SetWindowLong(FListHandle, GWL_STYLE, exStyle and not WS_BORDER);
end;


procedure TRMCustomComboBox.ListWndProc(var Message: TMessage);
var
  p: TPoint;

  procedure CallDefaultProc;
  begin
    with Message do
      Result := CallWindowProc(FDefListProc, FListHandle, Msg, WParam, LParam);
  end;

  procedure PaintListFrame;
  var
    DC: HDC;
    R: TRect;
  begin
    GetWindowRect(FListHandle, R);
    OffsetRect(R, -R.Left, -R.Top);
    DC := GetWindowDC(FListHandle);
    DrawEdge(DC, R, EDGE_RAISED, BF_RECT);
    ReleaseDC(FListHandle, DC);
  end;

begin
  case Message.Msg of
    WM_NCPAINT:
      begin
        CallDefaultProc;
        PaintListFrame;
      end;
    LB_SETTOPINDEX:
      begin
        if ItemIndex > DropDownCount then
          CallDefaultProc;
      end;
    WM_WINDOWPOSCHANGING:
      with TWMWindowPosMsg(Message).WindowPos^ do
      begin
        // calculating the size of the drop down list
        cx := Width - 1;
        cy := GetListHeight;
        p.x := cx;
        p.y := cy + GetFontHeight(Font) + 6;
        p := ClientToScreen(p);
        FUpDropdown := False;
        if p.y > Screen.Height then //if DropDownList showing below
        begin
          y := y - 2;
          FUpDropdown := True;
        end;
      end;
  else
    CallDefaultProc;
  end;
end;

procedure TRMCustomComboBox.WndProc(var Message: TMessage);
begin
  case Message.Msg of
    WM_SETTEXT:
      Invalidate;
    WM_PARENTNOTIFY:
      if LoWord(Message.wParam) = WM_CREATE then begin
        if FDefListProc <> nil then
        begin