rm_common.pas

进销存·完整的·有数据库的·非常完整·只得参考

unit RM_common;

interface

{$I RM.inc}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, Commctrl, Menus, Mask
{$IFDEF USE_TB2K}
  , TB2Item, TB2ExtItems, TB2Dock, TB2Toolbar, TB2ToolWindow, TB2Common
{$ELSE}
{$IFDEF USE_INTERNALTB97}
  , RM_TB97Ctls, RM_TB97Tlbr, RM_TB97, RM_TB97Tlwn
{$ELSE}
  , TB97Ctls, TB97Tlbr, TB97, TB97Tlwn
{$ENDIF}
{$ENDIF};

const
  AlignmentBorderSize = 2; // TRY = 0
  DockedBorderSize = 2; // FROM TB2Dock.pas
  ResizeBorderSize = AlignmentBorderSize + DockedBorderSize;

type
  tbResizeKind = (rkNone, rkTop, rkLeft, rkBottom, rkRight);

  TRMDockPosition = {$IFDEF USE_TB2K}TTBDockPosition{$ELSE}TDockPosition{$ENDIF};
  TRMToolWindowSizeHandle = {$IFDEF USE_TB2K}TTBSizeHandle{$ELSE}TToolWindowSizeHandle{$ENDIF};
  TRMDock = {$IFDEF USE_TB2k}TTBDock{$ELSE}TDock97{$ENDIF};
  TRMToolbarSep = {$IFDEF USE_TB2k}TTBSeparatorItem{$ELSE}TToolbarSep97{$ENDIF};
  TRMEdit = {$IFDEF USE_TB2K}TTBEditItem{$ELSE}TEdit97{$ENDIF};

{$IFDEF USE_TB2k}
  TRMToolbar = class(TTBToolbar)
  private
    function GetDockedto: TRMDock;
    procedure SetDockedto(Value: TRMDock);
  public
    property Dockedto: TRMDock read GetDockedto write SetDockedto;
  end;
{$ELSE}
  TRMToolbar = TToolbar97;
{$ENDIF}

{$IFDEF USE_TB2K}
  TTBCustomDockableWindowAccess = class(TTBCustomDockableWindow);
{$ELSE}
  TTBCustomDockableWindowAccess = class(TCustomToolWindow97);
{$ENDIF}


{$IFDEF USE_TB2K}
  TRMResizeableToolWindow = class(TTBToolWindow)
{$ELSE}
  TRMResizeableToolWindow = class(TToolWindow97)
{$ENDIF}
  private
{$IFNDEF USE_TB2K}
    function GetCurrentDock: TDock97;
{$ENDIF}
    function DockedSizingLoop(X, Y: Integer): Boolean;
    function GetResizeKind(X, Y: Integer): tbResizeKind;
    procedure DrawDraggingOutline(const DC: HDC; const NewRect,
      OldRect: PRect; const NewDocking, OldDocking: Boolean);
  protected
{$IFDEF Delphi4}
    procedure AdjustClientRect(var Rect: TRect); override;
{$ENDIF}
    procedure WM__LButtonDown(var Msg: TWMMouse); message WM_LBUTTONDOWN;
    procedure WM__NCLButtonDown(var Msg: TWMMouse); message WM_NCLBUTTONDOWN;
    procedure WM__SetCursor(var Message: TWMSetCursor); message WM_SETCURSOR;
{$IFNDEF USE_TB2K}
    procedure GetMinMaxSize(var AMinClientWidth, AMinClientHeight,
      AMaxClientWidth, AMaxClientHeight: Integer);
    property CurrentDock: TDock97 read GetCurrentDock;
{$ENDIF}
  end;

  TRMToolWin = TRMResizeableToolWindow;//{$IFDEF USE_TB2k}TRMResizeableToolWindow{$ELSE}TToolWindow97{$ENDIF};
  TRMCustomDockableWindow = {$IFDEF USE_TB2K}TTBCustomDockableWindow{$ELSE}TCustomToolWindow97{$ENDIF};

{$IFDEF USE_TB2k}
  TRMToolbarButton = class(TTBItem)
  private
    function GetDown: Boolean;
    procedure SetDown(Value: Boolean);
    function GetAllowAllUp: Boolean;
    procedure SetAllowAllUp(Value: Boolean);
  public
    property AllowAllUp: Boolean read GetAllowAllup write SetAllowAllup;
    property Down: Boolean read GetDown write SetDown;
  end;
{$ELSE}
  TRMToolbarButton = TToolbarButton97;
{$ENDIF}

  TRMSpinButtonState = (rmsbNotDown, rmsbTopDown, rmsbBottomDown);

  {TRMSpinButton}
  TRMSpinButton = class(TGraphicControl)
  private
    FDown: TRMSpinButtonState;
    FUpBitmap: TBitmap;
    FDownBitmap: TBitmap;
    FDragging: Boolean;
    FInvalidate: Boolean;
    FTopDownBtn: TBitmap;
    FBottomDownBtn: TBitmap;
    FRepeatTimer: TTimer;
    FNotDownBtn: TBitmap;
    FLastDown: TRMSpinButtonState;
    FFocusControl: TWinControl;
    FOnTopClick: TNotifyEvent;
    FOnBottomClick: TNotifyEvent;
    procedure TopClick;
    procedure BottomClick;
    procedure GlyphChanged(Sender: TObject);
    procedure SetDown(Value: TRMSpinButtonState);
    procedure DrawAllBitmap;
    procedure DrawBitmap(ABitmap: TBitmap; ADownState: TRMSpinButtonState);
    procedure TimerExpired(Sender: TObject);
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
  protected
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Down: TRMSpinButtonState read FDown write SetDown default rmsbNotDown;
  published
  end;

{TRMSpinEdit}

  TRMValueType = (rmvtInteger, rmvtFloat);

  TRMSpinEdit = class(TCustomEdit)
  private
    FAlignment: TAlignment;
    FMinValue: Extended;
    FMaxValue: Extended;
    FIncrement: Extended;
    FDecimal: Byte;
    FChanging: Boolean;
    FEditorEnabled: Boolean;
    FValueType: TRMValueType;
    FButton: TRMSpinButton;
    FBtnWindow: TWinControl;
    FArrowKeys: Boolean;
    FOnTopClick: TNotifyEvent;
    FOnBottomClick: TNotifyEvent;
    FUpDown: TCustomUpDown;
    procedure UpDownClick(Sender: TObject; Button: TUDBtnType);
    function GetMinHeight: Integer;
    procedure GetTextHeight(var SysHeight, Height: Integer);
    function GetValue: Extended;
    function CheckValue(NewValue: Extended): Extended;
    function GetAsInteger: Longint;
    function IsIncrementStored: Boolean;
    function IsValueStored: Boolean;
    procedure SetArrowKeys(Value: Boolean);
    procedure SetAsInteger(NewValue: Longint);
    procedure SetValue(NewValue: Extended);
    procedure SetValueType(NewType: TRMValueType);
    procedure SetDecimal(NewValue: Byte);
    function GetButtonWidth: Integer;
    procedure RecreateButton;
    procedure ResizeButton;
    procedure SetEditRect;
    procedure SetAlignment(Value: TAlignment);
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure CMEnter(var Message: TMessage); message CM_ENTER;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure WMPaste(var Message: TWMPaste); message WM_PASTE;
    procedure WMCut(var Message: TWMCut); message WM_CUT;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
{$IFDEF Delphi4}
    procedure CMBiDiModeChanged(var Message: TMessage); message CM_BIDIMODECHANGED;
{$ENDIF}
  protected
    procedure Change; override;
    function IsValidChar(Key: Char): Boolean; virtual;
    procedure UpClick(Sender: TObject); virtual;
    procedure DownClick(Sender: TObject); virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure KeyPress(var Key: Char); override;
    procedure CreateParams(var Params: TCreateParams); override;
    procedure CreateWnd; override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property AsInteger: Longint read GetAsInteger write SetAsInteger default 0;
    property Text;
  published
    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property ArrowKeys: Boolean read FArrowKeys write SetArrowKeys default True;
    property Decimal: Byte read FDecimal write SetDecimal default 2;
    property EditorEnabled: Boolean read FEditorEnabled write FEditorEnabled default True;
    property Increment: Extended read FIncrement write FIncrement stored IsIncrementStored;
    property MaxValue: Extended read FMaxValue write FMaxValue;
    property MinValue: Extended read FMinValue write FMinValue;
    property ValueType: TRMValueType read FValueType write SetValueType;
    property Value: Extended read GetValue write SetValue stored IsValueStored;
    property AutoSelect;
    property AutoSize;
    property BorderStyle;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property MaxLength;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnBottomClick: TNotifyEvent read FOnBottomClick write FOnBottomClick;
    property OnTopClick: TNotifyEvent read FOnTopClick write FOnTopClick;
    property OnChange;
    property OnClick;
    property OnDblClick;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure RMSaveToolbars(t: array of TRMToolbar);
procedure RMRestoreToolbars(t: array of TRMToolbar);
procedure RMSaveToolWinPosition(f: TRMToolWin);
procedure RMRestoreToolWinPosition(f: TRMToolWin);

implementation

uses Registry, RM_Utils, RM_Const, RM_Const1, RM_Class;

const
  sSpinUpBtn = 'RM_SPINUP';
  sSpinDownBtn = 'RM_SPINDOWN';

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


procedure DrawDragRect(const DC: HDC; const NewRect, OldRect: PRect;
  const NewSize, OldSize: TSize; const Brush: HBRUSH; BrushLast: HBRUSH);
{ Draws a dragging outline, hiding the old one if neccessary. This is
  completely flicker free, unlike the old DrawFocusRect method. In case
  you're wondering, I got a lot of ideas from the MFC sources.

  Either NewRect or OldRect can be nil or empty. }
  function CreateNullRegion: HRGN;
  var
    R: TRect;
  begin
    SetRectEmpty(R);
    Result := CreateRectRgnIndirect(R);
  end;
var
  SaveIndex: Integer;
  rgnNew, rgnOutside, rgnInside, rgnLast, rgnUpdate: HRGN;
  R: TRect;
begin
  rgnLast := 0;
  rgnUpdate := 0;

  { First, determine the update region and select it }
  if NewRect = nil then begin
    SetRectEmpty(R);
    rgnOutside := CreateRectRgnIndirect(R);
  end
  else begin
    R := NewRect^;
    rgnOutside := CreateRectRgnIndirect(R);
    InflateRect(R, -NewSize.cx, -NewSize.cy);
    IntersectRect(R, R, NewRect^);
  end;
  rgnInside := CreateRectRgnIndirect(R);
  rgnNew := CreateNullRegion;
  CombineRgn(rgnNew, rgnOutside, rgnInside, RGN_XOR);

  if BrushLast = 0 then
    BrushLast := Brush;

  if OldRect <> nil then begin
    { Find difference between new region and old region }
    rgnLast := CreateNullRegion;
    with OldRect^ do
      SetRectRgn(rgnOutside, Left, Top, Right, Bottom);
    R := OldRect^;
    InflateRect(R, -OldSize.cx, -OldSize.cy);
    IntersectRect(R, R, OldRect^);
    SetRectRgn(rgnInside, R.Left, R.Top, R.Right, R.Bottom);
    CombineRgn(rgnLast, rgnOutside, rgnInside, RGN_XOR);

    { Only diff them if brushes are the same }
    if Brush = BrushLast then begin
      rgnUpdate := CreateNullRegion;
      CombineRgn(rgnUpdate, rgnLast, rgnNew, RGN_XOR);
    end;
  end;

  { Save the DC state so that the clipping region can be restored }
  SaveIndex := SaveDC(DC);
  try
    if (Brush <> BrushLast) and (OldRect <> nil) then begin
      { Brushes are different -- erase old region first }
      SelectClipRgn(DC, rgnLast);
      GetClipBox(DC, R);
      SelectObject(DC, BrushLast);
      PatBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, PATINVERT);
    end;

    { Draw into the update/new region }
    if rgnUpdate <> 0 then
      SelectClipRgn(DC, rgnUpdate)
    else
      SelectClipRgn(DC, rgnNew);
    GetClipBox(DC, R);
    SelectObject(DC, Brush);
    PatBlt(DC, R.Left, R.Top, R.Right - R.Left, R.Bottom - R.Top, PATINVERT);
  finally
    { Clean up DC }
    RestoreDC(DC, SaveIndex);
  end;

  { Free regions }
  if rgnNew <> 0 then DeleteObject(rgnNew);
  if rgnOutside <> 0 then DeleteObject(rgnOutside);
  if rgnInside <> 0 then DeleteObject(rgnInside);
  if rgnLast <> 0 then DeleteObject(rgnLast);
  if rgnUpdate <> 0 then DeleteObject(rgnUpdate);
end;

procedure TRMResizeableToolWindow.DrawDraggingOutline(const DC: HDC;
  const NewRect, OldRect: PRect; const NewDocking, OldDocking: Boolean);

  function CreateHalftoneBrush: HBRUSH;
  const
    GrayPattern: array[0..7] of Word =
    ($5555, $AAAA, $5555, $AAAA, $5555, $AAAA, $5555, $AAAA);
  var
    GrayBitmap: HBITMAP;
  begin
    GrayBitmap := CreateBitmap(8, 8, 1, 1, @GrayPattern);
    Result := CreatePatternBrush(GrayBitmap);
    DeleteObject(GrayBitmap);
  end;
var
  NewSize, OldSize: TSize;
  Brush: HBRUSH;
begin
  Brush := CreateHalftoneBrush;
  try
    with GetFloatingBorderSize do begin
      if NewDocking then NewSize.cx := 1 else NewSize.cx := X;
      NewSize.cy := NewSize.cx;
      if OldDocking then OldSize.cx := 1 else OldSize.cx := X;
      OldSize.cy := OldSize.cx;
    end;
    DrawDragRect(DC, NewRect, OldRect, NewSize, OldSize, Brush, Brush);
  finally
    DeleteObject(Brush);
  end;
end;


{$IFNDEF USE_TB2K}

procedure ProcessPaintMessages;
{ Dispatches all pending WM_PAINT messages. In effect, this is like an
  'UpdateWindow' on all visible windows }
var
  Msg: TMsg;
begin
  while PeekMessage(Msg, 0, WM_PAINT, WM_PAINT, PM_NOREMOVE) do begin
    case Integer(GetMessage(Msg, 0, WM_PAINT, WM_PAINT)) of
      -1: Break; { if GetMessage failed }
      0: begin
           { Repost WM_QUIT messages }
          PostQuitMessage(Msg.WParam);
          Break;
        end;
    end;
    DispatchMessage(Msg);
  end;
end;

procedure TRMResizeableToolWindow.GetMinMaxSize(var AMinClientWidth, AMinClientHeight,
  AMaxClientWidth, AMaxClientHeight: Integer);
begin
  AMinClientWidth := MinClientWidth;
  AMinClientHeight := MinClientHeight;
  AMaxClientWidth := 0;
  AMaxClientHeight := 0;
end;

function TRMResizeableToolWindow.GetCurrentDock: TDock97;
begin
  Result := DockedTo;
end;
{$ENDIF}

function TRMResizeableToolWindow.DockedSizingLoop(X, Y: Integer): Boolean;
var
  MultiResize, UseSmoothDrag, ResizeVertical, ResizeReverese: Boolean;
  OrigPos, Pos: Integer;
  APoint, LastPos: TPoint;
  SizeDiff, OrigSize, NewSize, MinSize, MaxSize: Integer;
  FToolbar: TRMCustomDockableWindow;
  DragRect, OldDragRect: TRect;
  ScreenDC: HDC;

  function ResizeKind2SizeHandle(Vertical, Reverse: Boolean): TRMToolWindowSizeHandle;
  begin
    if Vertical then
      if Reverse then Result := twshTop else Result := twshBottom
    else
      if Reverse then Result := twshLeft else Result := twshRight;
  end;

  procedure ComputeToolbarNewSize(var Rect: TRect);
  begin
    with Rect do
    begin
      if ResizeVertical then
      begin
        if ResizeReverese then Top := Bottom - NewSize;
        Bottom := Top + NewSize;
      end
      else
      begin
        if ResizeReverese then Left := Right - NewSize;
        Right := Left + NewSize;
      end;
    end;
  end;

  procedure DoResize;
  var
    I: Integer;
    ARect: TRect;
  begin
    CurrentDock.BeginUpdate;
    try
      if MultiResize then
        for I := 0 to CurrentDock.ToolbarCount - 1 do
        begin
          FToolbar := CurrentDock.Toolbars[I];
          if FToolbar.DockRow = DockRow then
          begin
            ARect := FToolbar.BoundsRect;
            ComputeToolbarNewSize(ARect);
            FToolbar.BoundsRect := ARect;
          end;
        end
      else
      begin
        ARect := Self.BoundsRect;
        ComputeToolbarNewSize(ARect);