oleform.pas

是一个delphi的流程制作软件

//--- Ole Form Conversions -----------------------------------------------------
//
// Common vcl form interface component used by OleRE.pas and OleContainer.pas
//
// Grahame Marsh
// Freeware for UNDU - you get it for free I make no promises
// [e-mail]
//------------------------------------------------------------------------------

{$INCLUDE OLE.INC}

unit OleForm;

interface

uses
  Windows, SysUtils, Classes, Forms, Controls, ActiveX, Menus;

type
  IVCLContainer = interface
    ['{A6E0F1E4-2D80-11D3-A27A-BFED1C57BC74}']
    procedure DestroyObject;
  end;

  IVCLFrameForm = interface(IOleInPlaceFrame)
    ['{CD02E1C0-52DA-11D0-9EA6-0020AF3D82DA}']
    procedure AddContainer (Instance: IVCLContainer);
    procedure RemoveContainer (Instance: IVCLContainer);
    procedure ClearBorderSpace;
    function Form: TCustomForm;
  end;

  TOleForm = class(TInterfacedObject, IOleForm, IOleWindow, IOleInPlaceUIWindow, IOleInPlaceFrame, IVCLFrameForm)
  private
    FForm: TCustomForm;
    FContainers: TList;
    FActiveObject: IOleInPlaceActiveObject;
    FSaveWidth: Integer;
    FSaveHeight: Integer;
    FHiddenControls: TList;
    FSpacers: array[0..3] of TControl;
// IOleForm
    procedure OnDestroy;
    procedure OnResize;
// IOleWindow
    function GetWindow(out wnd: HWnd): HResult; stdcall;
    function ContextSensitiveHelp(fEnterMode: BOOL): HResult; stdcall;
// IOleInPlaceUIWindow
    function GetBorder(out BorderRect: TRect): HResult; stdcall;
    function RequestBorderSpace(const borderwidths: TRect): HResult; stdcall;
    function SetBorderSpace(pborderwidths: PRect): HResult; stdcall;
    function SetActiveObject(const ActiveObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult; stdcall;
// IOleInPlaceFrame
    function InsertMenus(hmenuShared: HMenu; var menuWidths: TOleMenuGroupWidths): HResult; stdcall;
    function SetMenu(hmenuShared: HMenu; holemenu: HMenu; hwndActiveObject: HWnd): HResult; stdcall;
    function RemoveMenus(hmenuShared: HMenu): HResult; stdcall;
    function SetStatusText(pszStatusText: POleStr): HResult; stdcall;
    function EnableModeless(fEnable: BOOL): HResult; stdcall;
    function TranslateAccelerator(var msg: TMsg; wID: Word): HResult; stdcall;
// IVCLFrameForm
    procedure AddContainer(Instance: IVCLContainer);
    procedure RemoveContainer(Instance: IVCLContainer);
    function Form: TCustomForm;
    procedure ClearBorderSpace;
// TOleForm
    function IsSpacer(Control: TControl): Boolean;
    function IsToolControl(Control: TControl): Boolean;
  public
    constructor Create(Form: TCustomForm);
    destructor Destroy; override;
  end;

function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
function IsFormMDIChild(Form: TCustomForm): Boolean;

implementation

function GetVCLFrameForm(Form: TCustomForm): IVCLFrameForm;
begin
  if Form.OleFormObject = nil then TOleForm.Create(Form);
  Result := Form.OleFormObject as IVCLFrameForm;
end;

function IsFormMDIChild(Form: TCustomForm): Boolean;
begin
  Result := (Form is TForm) and (TForm(Form).FormStyle = fsMDIChild)
end;

//=== TOleForm.IOleForm ==============================================

procedure TOleForm.OnDestroy;
var
  I: Integer;
begin
  for I := FContainers.Count - 1 downto 0 do
    IVCLContainer(FContainers[I]).DestroyObject;
end;

procedure TOleForm.OnResize;
var
  BorderRect: TRect;
begin
  if (FActiveObject <> nil) and (FForm.WindowState <> wsMinimized) and
    ((FForm.ClientWidth <> FSaveWidth) or
    (FForm.ClientHeight <> FSaveHeight)) then
  begin
    GetBorder(BorderRect);
    FActiveObject.ResizeBorder(BorderRect, Self, True);
    FSaveWidth := FForm.ClientWidth;
    FSaveHeight := FForm.ClientHeight;
  end;
end;

//=== TOleForm.IOleInPlaceFrame =====================================

function TOleForm.GetWindow(out wnd: HWnd): HResult;
begin
  wnd := FForm.Handle;
  Result := S_OK;
end;

function TOleForm.ContextSensitiveHelp(fEnterMode: BOOL): HResult;
begin
  Result := S_OK;
end;

function TOleForm.GetBorder(out BorderRect: TRect): HResult;
var
  I: Integer;
  Control: TControl;
begin
  Result := S_OK;
  BorderRect := FForm.ClientRect;
  for I := 0 to FForm.ControlCount - 1 do
  begin
    Control := FForm.Controls[I];
    if Control.Visible and not IsSpacer(Control) and
      not IsToolControl(Control) then
      case Control.Align of
        alLeft: Inc(BorderRect.Left, Control.Width);
        alRight: Dec(BorderRect.Right, Control.Width);
        alTop: Inc(BorderRect.Top, Control.Height);
        alBottom: Dec(BorderRect.Bottom, Control.Height);
      end;
  end;
end;

function TOleForm.RequestBorderSpace(const borderwidths: TRect): HResult;
var
  I: Integer;
begin
  Result := S_OK;
  if (FForm is TForm) and (TForm(FForm).FormStyle = fsMDIForm) then Exit;
  for I := 0 to FForm.ControlCount - 1 do
    with FForm.Controls[I] do
      if Visible and (Align = alClient) then Exit;
  Result := INPLACE_E_NOTOOLSPACE;
end;

function TOleForm.SetBorderSpace(pborderwidths: PRect): HResult;
type
  PRectArray = ^TRectArray;
  TRectArray = array[0..3] of Integer;
const
  Alignments: array[0..3] of TAlign = (alLeft, alTop, alRight, alBottom);
var
  I, J, Size: Integer;
  Control, Spacer: TControl;
begin
  Result := S_OK;
  if (pborderwidths = nil) then Exit;
  Result := RequestBorderSpace(pBorderWidths^);
  if Result <> S_OK then Exit;
  FForm.DisableAlign;
  for I := 0 to FForm.ControlCount - 1 do
  begin
    Control := FForm.Controls[I];
    if IsToolControl(Control) then
    begin
      Control.Visible := False;
      FHiddenControls.Add(Control);
    end;
  end;
  for I := 0 to 3 do
  begin
    Size := PRectArray(pBorderWidths)^[I];
    if Size > 0 then
    begin
      Spacer := FSpacers[I];
      if Spacer = nil then
      begin
        Spacer := TControl.Create(FForm);
        if I < 2 then J := 10000 else J := -10000;
        if Odd(I) then Spacer.Top := J else Spacer.Left := J;
        Spacer.Align := Alignments[I];
        Spacer.Parent := FForm;
        FSpacers[I] := Spacer;
      end;
      if Odd(I) then Spacer.Height := Size else Spacer.Width := Size;
    end;
  end;
  FForm.EnableAlign;
  Result := S_OK;
end;

function TOleForm.SetActiveObject(const ActiveObject: IOleInPlaceActiveObject; pszObjName: POleStr): HResult;
var
  Window, ParentWindow: HWnd;
begin
  Result := S_OK;
  FActiveObject := ActiveObject;
  if FActiveObject = nil then Exit;
  if FActiveObject.GetWindow(Window) = 0 then
    while True do
    begin
      ParentWindow := GetParent(Window);
      if ParentWindow = 0 then Break;
      if FindControl(ParentWindow) <> nil then
      begin
        SetWindowPos(Window, HWND_TOP, 0, 0, 0, 0,
          SWP_NOMOVE or SWP_NOSIZE or SWP_NOACTIVATE);
        Break;
      end;
      Window := ParentWindow;
    end;
  FSaveWidth := FForm.ClientWidth;
  FSaveHeight := FForm.ClientHeight;
end;

function TOleForm.InsertMenus(hmenuShared: HMenu;
  var menuWidths: TOleMenuGroupWidths): HResult;
var
  Menu: TMainMenu;
begin
  Menu := FForm.Menu;
  if Menu <> nil then
    Menu.PopulateOle2Menu(hmenuShared, [0, 2, 4], menuWidths.width);
  Result := S_OK;
end;

function TOleForm.SetMenu(hmenuShared: HMenu; holemenu: HMenu;
  hwndActiveObject: HWnd): HResult;
var
  Menu: TMainMenu;
begin
  Menu := FForm.Menu;
  Result := S_OK;
  if Menu <> nil then
  begin
    Menu.SetOle2MenuHandle(hmenuShared);
    Result := OleSetMenuDescriptor(holemenu, Menu.WindowHandle,
      hwndActiveObject, nil, nil);
  end;
end;

function TOleForm.RemoveMenus(hmenuShared: HMenu): HResult;
begin
  while GetMenuItemCount(hmenuShared) > 0 do
    RemoveMenu(hmenuShared, 0, MF_BYPOSITION);
  Result := S_OK;
end;

function TOleForm.SetStatusText(pszStatusText: POleStr): HResult;
begin
  FForm.Hint := pszStatusText;
//  Application.Hint := pszStatusText;  // goes away too soon
  Result := S_OK;
end;

function TOleForm.EnableModeless(fEnable: BOOL): HResult;
begin
  Result := S_OK;
end;

function TOleForm.TranslateAccelerator(var msg: TMsg; wID: Word): HResult;
var
  Menu: TMainMenu;
begin
  Menu := FForm.Menu;
  if (Menu <> nil) and Menu.DispatchCommand(wID) then
    Result := S_OK else
    Result := S_FALSE;
end;

//=== TOleForm ======================================================

constructor TOleForm.Create(Form: TCustomForm);
begin
  inherited Create;
  FForm := Form;
  FContainers := TList.Create;
  FHiddenControls := TList.Create;
  FForm.OleFormObject := Self;
end;

destructor TOleForm.Destroy;
begin
  if FForm <> nil then FForm.OleFormObject := nil;
  FHiddenControls.Free;
  FContainers.Free;
  inherited Destroy;
end;

procedure TOleForm.ClearBorderSpace;
var
  I: Integer;
begin
  FForm.DisableAlign;
  for I := 0 to 3 do
  begin
    FSpacers[I].Free;
    FSpacers[I] := nil;
  end;
  for I := 0 to FHiddenControls.Count - 1 do
    TControl(FHiddenControls[I]).Visible := True;
  FHiddenControls.Clear;
  FForm.EnableAlign;
end;

function TOleForm.IsSpacer(Control: TControl): Boolean;
var
  I: Integer;
begin
  for I := 0 to 3 do
    if Control = FSpacers[I] then
    begin
      Result := True;
      Exit;
    end;
  Result := False;
end;

function TOleForm.IsToolControl(Control: TControl): Boolean;
begin
  Result := Control.Visible and
    (Control.Align in [alTop, alBottom, alLeft, alRight]) and
    (Control.Perform(CM_ISTOOLCONTROL, 0, 0) <> 0);
end;

procedure TOleForm.AddContainer(Instance: IVCLContainer);
begin
  FContainers.Add(pointer(Instance))
end;

procedure TOleForm.RemoveContainer(Instance: IVCLContainer);
begin
  FContainers.Remove(pointer(Instance));
end;

function TOleForm.Form: TCustomForm;
begin
  Result := FForm;
end;

end.