tb97.pas

企业智能(ERP)管理系统

procedure IniLoadToolbarPositions (const Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF}; const Filename: String);
procedure IniSaveToolbarPositions (const Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF}; const Filename: String);

procedure CustomLoadToolbarPositions (const Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
  const ReadIntProc: TPositionReadIntProc;
  const ReadStringProc: TPositionReadStringProc; const ExtraData: Pointer);
procedure CustomSaveToolbarPositions (const Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
  const WriteIntProc: TPositionWriteIntProc;
  const WriteStringProc: TPositionWriteStringProc; const ExtraData: Pointer);

function GetDockTypeOf (const Control: TDock97): TDockType;
function GetToolWindowParentForm (const ToolWindow: TCustomToolWindow97):
  {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
function ValidToolWindowParentForm (const ToolWindow: TCustomToolWindow97):
  {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};

procedure GetFloatingNCArea (var TopLeft, BottomRight: TPoint;
  const Resizable: Boolean);
procedure AddFloatingNCAreaToSize (var S: TPoint; const Resizable: Boolean);
procedure GetDockedNCArea (var TopLeft, BottomRight: TPoint;
  const LeftRight: Boolean; const DragHandleStyle: TDragHandleStyle);
procedure AddDockedNCAreaToSize (var S: TPoint; const LeftRight: Boolean;
  const DragHandleStyle: TDragHandleStyle);

implementation

uses
  Registry, IniFiles, SysUtils, Consts,
  TB97Cmn, TB97Cnst;

const
  DockedBorderSize = 2;
  DockedBorderSize2 = DockedBorderSize*2;
  DragHandleSizes: array[TDragHandleStyle] of Integer = (9, 0, 6);

  DefaultBarWidthHeight = 8;

  ForceDockAtTopRow = 0;
  ForceDockAtLeftPos = -8;

  PositionLeftOrRight = [dpLeft, dpRight];

  { Constants for TCustomToolWindow97 registry values/data.
    Don't localize any of these names! }
  rvRev = 'Rev';
  rdCurrentRev = 2;
  rvVisible = 'Visible';
  rvDockedTo = 'DockedTo';
  rdDockedToFloating = '+';
  rvDockRow = 'DockRow';
  rvDockPos = 'DockPos';
  rvFloatLeft = 'FloatLeft';
  rvFloatTop = 'FloatTop';

var
  FloatingToolWindows: TList = nil;


{ Misc. functions }

function GetSmallCaptionHeight: Integer;
{ Returns height of the caption of a small window }
begin
  if NewStyleControls then
    Result := GetSystemMetrics(SM_CYSMCAPTION)
  else
    { Win 3.x doesn't support small captions, so, like Office 97, use the size
      of normal captions minus one }
    Result := GetSystemMetrics(SM_CYCAPTION) - 1;
end;

function GetFloatingBorderSize (const Resizable: Boolean): TPoint;
{ Returns size of a thick border. Note that, depending on the Windows version,
  this may not be the same as the actual window metrics since it draws its
  own border }
const
  XMetrics: array[Boolean] of Integer = (SM_CXDLGFRAME, SM_CXFRAME);
  YMetrics: array[Boolean] of Integer = (SM_CYDLGFRAME, SM_CYFRAME);
begin
  Result.X := GetSystemMetrics(XMetrics[Resizable]);
  Result.Y := GetSystemMetrics(YMetrics[Resizable]);
end;

procedure GetFloatingNCArea (var TopLeft, BottomRight: TPoint;
  const Resizable: Boolean);
begin
  with GetFloatingBorderSize(Resizable) do begin
    TopLeft.X := X;
    TopLeft.Y := GetSmallCaptionHeight + Y;
    BottomRight.X := X;
    BottomRight.Y := Y;
  end;
end;

procedure AddFloatingNCAreaToSize (var S: TPoint; const Resizable: Boolean);
var
  TopLeft, BottomRight: TPoint;
begin
  GetFloatingNCArea (TopLeft, BottomRight, Resizable);
  Inc (S.X, TopLeft.X + BottomRight.X);
  Inc (S.Y, TopLeft.Y + BottomRight.Y);
end;

procedure GetDockedNCArea (var TopLeft, BottomRight: TPoint;
  const LeftRight: Boolean; const DragHandleStyle: TDragHandleStyle);
var
  Z: Integer;
begin
  Z := DockedBorderSize;  { code optimization... }
  TopLeft.X := Z;
  TopLeft.Y := Z;
  BottomRight.X := Z;
  BottomRight.Y := Z;
  if not LeftRight then
    Inc (TopLeft.X, DragHandleSizes[DragHandleStyle])
  else
    Inc (TopLeft.Y, DragHandleSizes[DragHandleStyle]);
end;

procedure AddDockedNCAreaToSize (var S: TPoint; const LeftRight: Boolean;
  const DragHandleStyle: TDragHandleStyle);
var
  TopLeft, BottomRight: TPoint;
begin
  GetDockedNCArea (TopLeft, BottomRight, LeftRight, DragHandleStyle);
  Inc (S.X, TopLeft.X + BottomRight.X);
  Inc (S.Y, TopLeft.Y + BottomRight.Y);
end;

function GetPrimaryDesktopArea: TRect;
{ Returns a rectangle containing the "work area" of the primary display
  monitor, which is the area not taken up by the taskbar. }
begin
  if not SystemParametersInfo(SPI_GETWORKAREA, 0, @Result, 0) then
    { SPI_GETWORKAREA is only supported by Win95 and NT 4.0. So it fails under
      Win 3.x. In that case, return a rectangle of the entire screen }
    Result := Rect(0, 0, GetSystemMetrics(SM_CXSCREEN),
      GetSystemMetrics(SM_CYSCREEN));
end;

function UsingMultipleMonitors: Boolean;
{ Returns True if the system has more than one display monitor configured. }
var
  NumMonitors: Integer;
begin
  NumMonitors := GetSystemMetrics(80 {SM_CMONITORS});
  Result := (NumMonitors <> 0) and (NumMonitors <> 1);
  { ^ NumMonitors will be zero if not running Win98, NT 5, or later }
end;

type
  HMONITOR = type Integer;
  PMonitorInfoA = ^TMonitorInfoA;
  TMonitorInfoA = record
    cbSize: DWORD;
    rcMonitor: TRect;
    rcWork: TRect;
    dwFlags: DWORD;
  end;
const
  MONITOR_DEFAULTTONEAREST = $2;
type
  TMultiMonApis = record
    funcMonitorFromRect: function(lprcScreenCoords: PRect; dwFlags: DWORD): HMONITOR; stdcall;
    funcMonitorFromPoint: function(ptScreenCoords: TPoint; dwFlags: DWORD): HMONITOR; stdcall;
    funcGetMonitorInfoA: function(hMonitor: HMONITOR; lpMonitorInfo: PMonitorInfoA): BOOL; stdcall;
  end;

{ Under D4 I could be using the MultiMon unit for the multiple monitor
  function imports, but its stubs for MonitorFromRect and MonitorFromPoint
  are seriously bugged... So I chose to avoid the MultiMon unit entirely. }

function InitMultiMonApis (var Apis: TMultiMonApis): Boolean;
var
  User32Handle: THandle;
begin
  User32Handle := GetModuleHandle(user32);
  Apis.funcMonitorFromRect := GetProcAddress(User32Handle, 'MonitorFromRect');
  Apis.funcMonitorFromPoint := GetProcAddress(User32Handle, 'MonitorFromPoint');
  Apis.funcGetMonitorInfoA := GetProcAddress(User32Handle, 'GetMonitorInfoA');
  Result := Assigned(Apis.funcMonitorFromRect) and
    Assigned(Apis.funcMonitorFromPoint) and Assigned(Apis.funcGetMonitorInfoA);
end;

function GetDesktopAreaOfMonitorContainingRect (const R: TRect): TRect;
{ Returns the work area of the monitor which the rectangle R intersects with
  the most, or the monitor nearest R if no monitors intersect. }
var
  Apis: TMultiMonApis;
  M: HMONITOR;
  MonitorInfo: TMonitorInfoA;
begin
  if UsingMultipleMonitors and InitMultiMonApis(Apis) then begin
    M := Apis.funcMonitorFromRect(@R, MONITOR_DEFAULTTONEAREST);
    MonitorInfo.cbSize := SizeOf(MonitorInfo);
    if Apis.funcGetMonitorInfoA(M, @MonitorInfo) then begin
      Result := MonitorInfo.rcWork;
      Exit;
    end;
  end;
  Result := GetPrimaryDesktopArea;
end;

function GetDesktopAreaOfMonitorContainingPoint (const P: TPoint): TRect;
{ Returns the work area of the monitor containing the point P, or the monitor
  nearest P if P isn't in any monitor's work area. }
var
  Apis: TMultiMonApis;
  M: HMONITOR;
  MonitorInfo: TMonitorInfoA;
begin
  if UsingMultipleMonitors and InitMultiMonApis(Apis) then begin
    M := Apis.funcMonitorFromPoint(P, MONITOR_DEFAULTTONEAREST);
    MonitorInfo.cbSize := SizeOf(MonitorInfo);
    if Apis.funcGetMonitorInfoA(M, @MonitorInfo) then begin
      Result := MonitorInfo.rcWork;
      Exit;
    end;
  end;
  Result := GetPrimaryDesktopArea;
end;

function GetMDIParent (const Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF}):
  {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
{ Returns the parent of the specified MDI child form. But, if Form isn't a
  MDI child, it simply returns Form. }
var
  I, J: Integer;
begin
  Result := Form;
  if Form = nil then Exit;
  if {$IFDEF TB97D3} (Form is TForm) and {$ENDIF}
     (TForm(Form).FormStyle = fsMDIChild) then
    for I := 0 to Screen.FormCount-1 do
      with Screen.Forms[I] do begin
        if FormStyle <> fsMDIForm then Continue;
        for J := 0 to MDIChildCount-1 do
          if MDIChildren[J] = Form then begin
            Result := Screen.Forms[I];
            Exit;
          end;
      end;
end;

function GetDockTypeOf (const Control: TDock97): TDockType;
begin
  if Control = nil then
    Result := dtNotDocked
  else begin
    if not(Control.Position in PositionLeftOrRight) then
      Result := dtTopBottom
    else
      Result := dtLeftRight;
  end;
end;

function GetToolWindowParentForm (const ToolWindow: TCustomToolWindow97):
  {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
var
  Ctl: TWinControl;
begin
  Result := nil;
  Ctl := ToolWindow;
  while Assigned(Ctl.Parent) do begin
    if Ctl.Parent is {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF} then
      Result := {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF}(Ctl.Parent);
    Ctl := Ctl.Parent;
  end;
  { ^ for compatibility with ActiveX controls, that code is used instead of
    GetParentForm because it returns nil unless the form is the *topmost*
    parent }
  if Result is TFloatingWindowParent then
    Result := TFloatingWindowParent(Result).ParentForm;
end;

function ValidToolWindowParentForm (const ToolWindow: TCustomToolWindow97):
  {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
begin
  Result := GetToolWindowParentForm(ToolWindow);
  if Result = nil then
    raise EInvalidOperation.{$IFDEF TB97D3}CreateFmt{$ELSE}CreateResFmt{$ENDIF}
      (SParentRequired, [ToolWindow.Name]);
end;

procedure ToolbarHookProc (Code: THookProcCode; Wnd: HWND; WParam: WPARAM; LParam: LPARAM);
var
  I: Integer;
  ToolWindow: TCustomToolWindow97;
  Form: {$IFDEF TB97D3} TCustomForm {$ELSE} TForm {$ENDIF};
begin
  case Code of
    hpSendActivateApp: begin
        if Assigned(FloatingToolWindows) then
          for I := 0 to FloatingToolWindows.Count-1 do
            with TCustomToolWindow97(FloatingToolWindows.List[I]) do
              { Hide or restore toolbars when application is deactivated or activated.
                UpdateVisibility also sets caption state active/inactive }
              UpdateVisibility;
      end;
    hpSendWindowPosChanged: begin
        if Assigned(FloatingToolWindows) then
          for I := 0 to FloatingToolWindows.Count-1 do begin
            ToolWindow := TCustomToolWindow97(FloatingToolWindows.List[I]);
            with ToolWindow do begin
              if HandleAllocated then begin
                with PWindowPos(LParam)^ do
                  { Call UpdateVisibility if parent form's visibility has
                    changed, or if it has been minimized or restored }
                  if ((flags and (SWP_SHOWWINDOW or SWP_HIDEWINDOW) <> 0) or
                      (flags and SWP_FRAMECHANGED <> 0)) then begin
                    Form := GetToolWindowParentForm(ToolWindow);
                    if Assigned(Form) and Form.HandleAllocated and ((Wnd = Form.Handle) or IsChild(Wnd, Form.Handle)) then
                      UpdateVisibility;
                  end;
              end;
            end;
          end;
      end;
    hpPreDestroy: begin
        if Assigned(FloatingToolWindows) then
          for I := 0 to FloatingToolWindows.Count-1 do begin
            with TCustomToolWindow97(FloatingToolWindows.List[I]) do
              { It must remove the form window's ownership of the tool window
                *before* the form gets destroyed, otherwise Windows will destroy
                the tool window's handle. }
              if HandleAllocated and (HWND(GetWindowLong(Handle, GWL_HWNDPARENT)) = Wnd) then
                SetWindowLong (Handle, GWL_HWNDPARENT, Parent.Handle);
                { ^ Restore GWL_HWNDPARENT back to the TFloatingWindowParent }
          end;
      end;
  end;
end;

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;

type
  PFindWindowData = ^TFindWindowData;
  TFindWindowData = record
    TaskActiveWindow, TaskFirstWindow, TaskFirstTopMost: HWND;
  end;

function DoFindWindow (Wnd: HWND; Param: Longint): Bool; stdcall;
begin
  with PFindWindowData(Param)^ do
    if (Wnd <> TaskActiveWindow) and (Wnd <> Application.Handle) and
       IsWindowVisible(Wnd) and IsWindowEnabled(Wnd) then begin
      if GetWindowLong(Wnd, GWL_EXSTYLE) and WS_EX_TOPMOST = 0 then begin
        if TaskFirstWindow = 0 then TaskFirstWindow := Wnd;
      end
      else begin