rm_dsgctrls.pas

这是一个功能强大

unit RM_DsgCtrls;

interface

{$I RM.inc}
{$R RM_Designer.res}
{$R rm_lng2.res}
{$R rm_lng3.res}

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, Buttons, ComCtrls, CommCtrl, Menus, RM_Ctrls, RM_Common
{$IFDEF COMPILER4_UP}, ImgList{$ENDIF}
{$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}
{$IFDEF Raize}
  , RzCommon, RzTabs, RzPanel
{$ENDIF}
{$IFDEF FlatStyle}
  , TFlatPanelUnit, TFlatTabControlUnit
{$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};

  //dejoy added end

{$IFDEF Raize}
  TRMPanel = class(TRzPanel)
  private
    function GetBevelInner: TPanelBevel;
    function GetBevelOuter: TPanelBevel;
    procedure SetBevelInner(const Value: TPanelBevel);
    procedure SetBevelOuter(const Value: TPanelBevel);
  public
    property BevelInner: TPanelBevel read GetBevelInner write SetBevelInner;
    property BevelOuter: TPanelBevel read GetBevelOuter write SetBevelOuter;
  end;

  TRMPageControl = TRzPageControl;
  TRMTabControl = class(TRzTabControl)
{$ELSE}
{$IFDEF FlatStyle}
  TRMPanel = TFlatPanel;
  TRMPageControl = TPageControl;
  TRMTabControl = class(TFlatTabControl)
  private
    FMultiLine: boolean;
    procedure SetMultiLine(Value: Boolean);
    function GetOnChange: TNotifyEvent;
    procedure SetOnChange(const Value: TNotifyEvent);
    function GetTabIndex: Integer;
    procedure SetTabIndex(const Value: Integer); virtual;
  public
    HotTrack: Boolean;
    property MultiLine: Boolean read FMultiLine write SetMultiLine default False;
    property OnChange: TNotifyEvent read GetOnChange write SetOnChange;
    property TabIndex: Integer read GetTabIndex write SetTabIndex default -1;
{$ELSE}
{$IFDEF JVCLCTLS}
  TRMPanel = TPanel;
  TRMPageControl = TPageControl;
  TRMTabControl = class(TTabControl)
{$ELSE}
  TRMPanel = TPanel;
  TRMPageControl = TPageControl;
  TRMTabControl = class(TTabControl)
{$ENDIF}
{$ENDIF}
{$ENDIF}
  private
    function GetTabsCaption(Index: Integer): string;
    procedure SetTabsCaption(Index: Integer; Value: string);
  public
    constructor Create(AOwner: TComponent); override;
    function AddTab(const S: string): Integer;
    property TabsCaption[Index: Integer]: string read GetTabsCaption write SetTabsCaption;
  end;

{$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 COMPILER4_UP}
    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};

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

  { TRMFontComboBox }
  TRMFontComboBox = class(TRMComboBox97 {TComboBox})
  private
    FFontHeight: Integer;
    FTrueTypeBMP: TBitmap;
    FDeviceBMP: TBitmap;
    FOnChange: TNotifyEvent;
    FDevice: TFontDevice;
    FUpdate: Boolean;
    FOptions: TFontListOptions;
    procedure SetFontName(const NewFontName: TFontName);
    function GetFontName: TFontName;
    function GetTrueTypeOnly: Boolean;
    procedure SetDevice(Value: TFontDevice);
    procedure SetOptions(Value: TFontListOptions);
    procedure SetTrueTypeOnly(Value: Boolean);
    procedure Reset;
    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 MeasureItem(Index: Integer; var Height: Integer); 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;
    property OnChange;
  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;

  { TRMFrameStyleButton }
  TRMFrameStyleButton = class(TRMPopupWindowButton)
  private
    FPopup: TRMPopupWindow;
    FCurrentStyle: Integer;
    FOnStyleChange: TNotifyEvent;

    procedure SetCurrentStyle(Value: Integer);
    procedure Item_OnClick(Sender: TObject);
  protected
    function GetDropDownPanel: TRMPopupWindow; override;
  public
    constructor Create(aOwner: TComponent); override;
    destructor Destroy; override;

    property CurrentStyle: Integer read FCurrentStyle write SetCurrentStyle;
    property OnStyleChange: TNotifyEvent read FOnStyleChange write FOnStyleChange;
  published
  end;

  { TRMNewScrollBox }
  TRMNewScrollBox = class(TScrollBox)
  private
    FOnkeyDown: TKeyEvent;
    procedure CNKeydown(var Message: TMessage); message CN_KEYDOWN;
  protected
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
  public
    constructor Create(AOwner: TComponent); override;
  published
    property OnkeyDown: TKeyEvent read FOnkeyDown write FOnkeyDown;
  end;

procedure RMSaveToolbars(aParentKey: string; t: array of TRMToolbar);
procedure RMRestoreToolbars(aParentKey: string; t: array of TRMToolbar);
procedure RMSaveToolWinPosition(aParentKey: string; f: TRMToolWin);
procedure RMRestoreToolWinPosition(aParentKey: string; f: TRMToolWin);
function RMMinimizeName(const Filename: TFileName; Canvas: TCanvas; MaxLen: Integer): string;

function RMForceDirectories(Dir: string): Boolean;
function RMDirectoryExists(const aName: string): Boolean;
function RMSelectDirectory(const Caption: string; const Root: WideString; var Directory: string): Boolean;

implementation

uses
  Registry, RM_Class, RM_Utils, RM_Const, RM_Const1, Math, ShlObj, ActiveX;

{------------------------------------------------------------------------------}

function RMMinimizeName(const Filename: TFileName; Canvas: TCanvas; MaxLen: Integer): string;
var
  Drive: TFileName;
  Dir: TFileName;
  lName: TFileName;

  procedure CutFirstDirectory(var S: TFileName);
  var
    Root: Boolean;
    P: Integer;
  begin
    if S = '\' then
      S := ''
    else
    begin
      if S[1] = '\' then
      begin
        Root := True;
        Delete(S, 1, 1);
      end
      else
        Root := False;
      if S[1] = '.' then
        Delete(S, 1, 4);
      P := AnsiPos('\', S);
      if P <> 0 then
      begin
        Delete(S, 1, P);
        S := '...\' + S;
      end
      else
        S := '';
      if Root then
        S := '\' + S;
    end;
  end;

begin
  Result := FileName;
  Dir := ExtractFilePath(Result);
  lName := ExtractFileName(Result);

  if (Length(Dir) >= 2) and (Dir[2] = ':') then
  begin
    Drive := Copy(Dir, 1, 2);
    Delete(Dir, 1, 2);
  end
  else
    Drive := '';
  while ((Dir <> '') or (Drive <> '')) and (Canvas.TextWidth(Result) > MaxLen) do
  begin
    if Dir = '\...\' then
    begin
      Drive := '';
      Dir := '...\';
    end
    else if Dir = '' then
      Drive := ''
    else
      CutFirstDirectory(Dir);
    Result := Drive + Dir + lName;
  end;
end;

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