dxribbonform.pas

胜天进销存源码,国产优秀的进销存

{*******************************************************************}
{                                                                   }
{       Developer Express Visual Component Library                  }
{       ExpressBars components                                      }
{                                                                   }
{       Copyright (c) 1998-2008 Developer Express Inc.              }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{   The entire contents of this file is protected by U.S. and       }
{   International Copyright Laws. Unauthorized reproduction,        }
{   reverse-engineering, and distribution of all or any portion of  }
{   the code contained in this file is strictly prohibited and may  }
{   result in severe civil and criminal penalties and will be       }
{   prosecuted to the maximum extent possible under the law.        }
{                                                                   }
{   RESTRICTIONS                                                    }
{                                                                   }
{   THIS SOURCE CODE AND ALL RESULTING INTERMEDIATE FILES           }
{   (DCU, OBJ, DLL, ETC.) ARE CONFIDENTIAL AND PROPRIETARY TRADE    }
{   SECRETS OF DEVELOPER EXPRESS INC. THE REGISTERED DEVELOPER IS   }
{   LICENSED TO DISTRIBUTE THE EXPRESSBARS AND ALL ACCOMPANYING VCL }
{   CONTROLS AS PART OF AN EXECUTABLE PROGRAM ONLY.                 }
{                                                                   }
{   THE SOURCE CODE CONTAINED WITHIN THIS FILE AND ALL RELATED      }
{   FILES OR ANY PORTION OF ITS CONTENTS SHALL AT NO TIME BE        }
{   COPIED, TRANSFERRED, SOLD, DISTRIBUTED, OR OTHERWISE MADE       }
{   AVAILABLE TO OTHER INDIVIDUALS WITHOUT EXPRESS WRITTEN CONSENT  }
{   AND PERMISSION FROM DEVELOPER EXPRESS INC.                      }
{                                                                   }
{   CONSULT THE END USER LICENSE AGREEMENT FOR INFORMATION ON       }
{   ADDITIONAL RESTRICTIONS.                                        }
{                                                                   }
{*******************************************************************}

unit dxRibbonForm;

{$I cxVer.inc}

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, ExtCtrls, ImgList, cxClasses, cxGraphics, cxControls,
  dxRibbonSkins, dxRibbonFormCaptionHelper, cxDWMApi;

type

  { TdxCustomRibbonForm }

  TdxCustomRibbonForm = class(TForm)
  private
    FAdjustLayoutForNonClientDrawing: Boolean;
    FAutoScroll: Boolean;
    FCaption: TCaption;
    FCornerRegions: array[0..3] of HRGN;
    FData: TdxRibbonFormData;
    FDisableAero: Boolean;
    FExtendFrameAtTopHeight: Integer;
    FFakeClientHandle: HWND;
    FZoomedBoundsOffsets: TRect;
    FIsActive: Boolean;
    FSizingBorders: TSize;
    FSizingLoop: Boolean;
    FDelayedActivate: Boolean;
    FNeedCallActivate: Boolean;
    FUseSkin: Boolean;
    FUseSkinColor: Boolean;
    FVisibleChanging: Boolean;
    FDefClientProc: TFarProc;
    FNewClientInstance: TFarProc;
    FOldClientProc: TFarProc;
    FRibbonNonClientHelper: TdxRibbonFormCaptionHelper;
    procedure CalculateCornerRegions;
    procedure CalculateZoomedOffsets;
    procedure CheckExtendFrame(AZoomed: Boolean);
    procedure CheckResizingNCHitTest(var AHitTest: Integer; const P: TPoint);
    procedure CorrectZoomedBounds(var R: TRect);
    procedure CreateCornerRegions;
    procedure DestroyCornerRegions;
    procedure ExcludeRibbonPaintArea(DC: HDC);
    procedure ForceUpdateWindowSizeForVista;
    function GetCurrentBordersWidth: TRect;
    function GetUseSkin: Boolean;
    procedure InvalidateFrame(AWnd: HWND; AUpdate: Boolean = False);
    function IsNeedCorrectForAutoHideTaskBar: Boolean;
    function IsNormalWindowState: Boolean;
    procedure NewClientWndProc(var Message: TMessage);
    procedure SetAutoScroll(const Value: Boolean);
    procedure SetDisableAero(const Value: Boolean);
    procedure SetRibbonNonClientHelper(const Value: TdxRibbonFormCaptionHelper);
    procedure SetUseSkinColor(const Value: Boolean);
    procedure UpdateSystemMenu;
    //messages
    procedure CMActivate(var Message: TCMActivate); message CM_ACTIVATE;
    procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
    procedure CMShowingChanged(var Message: TMessage); message CM_SHOWINGCHANGED;
    procedure CMVisibleChanged(var Message: TMessage); message CM_VISIBLECHANGED;
    procedure WMCaptureChanged(var Message: TMessage); message WM_CAPTURECHANGED;
    procedure WMEraseBkgnd(var Message: TWMEraseBkgnd); message WM_ERASEBKGND;
    procedure WMInitMenu(var Message: TWMInitMenu); message WM_INITMENU;
    procedure WMNCActivate(var Message: TWMNCActivate); message WM_NCACTIVATE;
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;
    procedure WMNCHitTest(var Message: TWMNCHitTest); message WM_NCHITTEST;
    procedure WMNCPaint(var Message: TMessage); message WM_NCPAINT;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure WMShowWindow(var Message: TMessage); message WM_SHOWWINDOW;
    procedure WMSize(var Message: TWMSize); message WM_SIZE;
    procedure WMSysCommand(var Message: TWMSysCommand); message WM_SYSCOMMAND;
    procedure WMCancelMode(var Message: TWMCancelMode); message WM_CANCELMODE;
    procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
    procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
    procedure WMNCRButtonUp(var Message: TWMNCRButtonUp); message WM_NCRBUTTONUP;
    procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
    procedure WMRButtonUp(var Message: TWMRButtonUp); message WM_RBUTTONUP;
    procedure WMWindowPosChanged(var Message: TWMWindowPosChanged); message WM_WINDOWPOSCHANGED;
    //vista support
    procedure WMDWMCompositionChanged(var Message: TMessage); message WM_DWMCOMPOSITIONCHANGED;
    //caption
    procedure WMGetText(var Message: TWMGetText); message WM_GETTEXT;
    procedure WMGetTextLength(var Message: TWMGetTextLength); message WM_GETTEXTLENGTH;
    procedure WMSetText(var Message: TWMSetText); message WM_SETTEXT;
  protected
    procedure AdjustClientRect(var Rect: TRect); override;
    procedure AdjustLayout; virtual;
    procedure AdjustSize; override;
    procedure CallDWMWindowProc(var Message);
    function CanAdjustLayout: Boolean; virtual;
    procedure CaptionChanged;
    procedure CreateWnd; override;
    procedure DestroyWindowHandle; override;
    procedure DoCreate; override;
    procedure DrawNonClientArea(ADrawCaption: Boolean; AUpdateRegion: HRGN = 1);
    procedure ExtendFrameIntoClientAreaAtTop(AHeight: Integer);
    function GetFormBorderIcons: TBorderIcons; virtual;
    function HandleWithHelper(ADown: Boolean; AButton: TMouseButton): Boolean; virtual;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    procedure ModifySystemMenu(ASysMenu: THandle); virtual;
    procedure ShiftControlsVertically(ADelta: Integer); virtual;
    procedure UpdateNonClientArea;
    procedure UpdateWindowStates;
    procedure WndProc(var Message: TMessage); override;

    property DisableAero: Boolean read FDisableAero write SetDisableAero default False;
    property UseSkin: Boolean read GetUseSkin;
  public
    constructor Create(AOwner: TComponent); override;
    constructor CreateNew(AOwner: TComponent; Dummy: Integer = 0); override;
    destructor Destroy; override;
    procedure Invalidate; override;
    function IsUseAeroNCPaint: Boolean;

    property RibbonNonClientHelper: TdxRibbonFormCaptionHelper
      read FRibbonNonClientHelper write SetRibbonNonClientHelper;
    property IsActive: Boolean read FIsActive;
  published
    property AdjustLayoutForNonClientDrawing: Boolean
      read FAdjustLayoutForNonClientDrawing write FAdjustLayoutForNonClientDrawing default True;
    property AutoScroll: Boolean read FAutoScroll write SetAutoScroll default False;
    property KeyPreview default True;
    property UseSkinColor: Boolean read FUseSkinColor write SetUseSkinColor default True;
  end;

  { TdxRibbonForm }

  TdxRibbonForm = class(TdxCustomRibbonForm);

procedure SetWindowTextWithoutRedraw(AWnd: HWND; const AText: string);

implementation

uses
{$IFDEF DELPHI6}
  Types,
{$ENDIF}
  dxBar, cxGeometry, Math, dxOffice11, dxUxTheme, MultiMon, ShellAPI, dxRibbon,
  dxStatusBar;

const
{$IFNDEF DELPHI7}
  WM_NCMOUSELEAVE     = $02A2;
{$ENDIF}
  WM_NCUAHDRAWCAPTION = $00AE;
  WM_NCUAHDRAWFRAME   = $00AF;
  WM_SYNCPAINT        = $0088;

  dxGlassMaximizedNonClientHeight = 4;

procedure SetWindowTextWithoutRedraw(AWnd: HWND; const AText: string);
var
  AFlags: Cardinal;
begin
  AFlags := GetWindowLong(AWnd, GWL_STYLE);
  SetWindowLong(AWnd, GWL_STYLE, AFlags and not WS_VISIBLE);
  DefWindowProc(AWnd, WM_SETTEXT, 0, LongInt(PChar(AText)));
  SetWindowLong(AWnd, GWL_STYLE, AFlags);
end;

{ TdxCustomRibbonForm }

constructor TdxCustomRibbonForm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner); //CBUILDER workaround
end;

constructor TdxCustomRibbonForm.CreateNew(AOwner: TComponent; Dummy: Integer = 0);
begin
  inherited CreateNew(AOwner, Dummy);
  FAutoScroll := False;
  FUseSkinColor := True;
  FAdjustLayoutForNonClientDrawing := True;
  AutoScroll := False;
  KeyPreview := True;
  CreateCornerRegions;
end;

destructor TdxCustomRibbonForm.Destroy;
begin
  DestroyCornerRegions;
  inherited Destroy;
end;

procedure TdxCustomRibbonForm.Invalidate;
begin
  if HandleAllocated and not IsIconic(Handle) then
    CheckExtendFrame(IsZoomed(Handle));
  inherited Invalidate;
  if ClientHandle <> 0 then
    InvalidateRect(ClientHandle, nil, True);
end;

procedure TdxCustomRibbonForm.CreateWnd;
var
  ClientCreateStruct: TClientCreateStruct;
begin
  FExtendFrameAtTopHeight := -1;
  inherited CreateWnd;
  if not (csDesigning in ComponentState) and (FormStyle = fsMDIForm) then
  begin
    with ClientCreateStruct do
    begin
      idFirstChild := $FF00; //check
      hWindowMenu := 0;
    end;
    FFakeClientHandle := Windows.CreateWindowEx(WS_EX_CLIENTEDGE, 'MDICLIENT',
      nil, WS_CHILD or WS_VISIBLE or WS_GROUP or WS_TABSTOP or
      WS_CLIPCHILDREN or WS_CLIPSIBLINGS or
      MDIS_ALLCHILDSTYLES, 0, 0, ClientWidth, ClientHeight, Handle, 0,
      HInstance, @ClientCreateStruct);
    SetWindowPos(FFakeClientHandle, 0, -20, -20, 10, 10, SWP_NOACTIVATE or SWP_NOZORDER);
    FOldClientProc := Pointer(GetWindowLong(ClientHandle, GWL_WNDPROC));
    FDefClientProc := Pointer(GetWindowLong(FFakeClientHandle, GWL_WNDPROC));
    FNewClientInstance := {$IFDEF DELPHI6}Classes.{$ENDIF}MakeObjectInstance(NewClientWndProc);
    SetWindowLong(ClientHandle, GWL_WNDPROC, Longint(FNewClientInstance));
    if ClientHandle <> 0 then
    begin
      SetWindowLong(ClientHandle, GWL_EXSTYLE,
        GetWindowLong(ClientHandle, GWL_EXSTYLE) and not WS_EX_CLIENTEDGE);
      InvalidateFrame(ClientHandle);
    end;
  end;
  UpdateSystemMenu;
end;

procedure TdxCustomRibbonForm.DestroyWindowHandle;
begin
  inherited DestroyWindowHandle;
  if csDestroying in ComponentState then
    RibbonNonClientHelper := nil;
end;

procedure TdxCustomRibbonForm.DoCreate;
begin
  inherited DoCreate;
  if FUseSkin then
    AdjustLayout;
end;

procedure TdxCustomRibbonForm.AdjustClientRect(var Rect: TRect);
begin
  inherited;
  if IsUseAeroNCPaint and IsZoomed(Handle) then
    Inc(Rect.Top, dxGlassMaximizedNonClientHeight);
end;

procedure TdxCustomRibbonForm.AdjustLayout;
var
  ALoadedHeight, AHeight, ADelta: Integer;
begin
  if not CanAdjustLayout then Exit;
  RibbonNonClientHelper.GetDesignInfo(ALoadedHeight, AHeight);
  ADelta := AHeight - ALoadedHeight;
  if WindowState <> wsMaximized then
    ClientHeight := ClientHeight + ADelta - (GetSystemMetrics(SM_CYCAPTION) + GetDefaultWindowBordersWidth(Handle).Top);
  ShiftControlsVertically(ADelta);
end;

procedure TdxCustomRibbonForm.AdjustSize;
{$IFDEF DELPHI11}
var
  AFlags: Cardinal;
{$ENDIF}
begin
{$IFDEF DELPHI11}
  if not (csLoading in ComponentState) and HandleAllocated then
  begin
    AFlags := SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOZORDER;
    if IsZoomed(Handle) then
      AFlags := AFlags or SWP_NOSIZE;
    SetWindowPos(Handle, 0, 0, 0, Width, Height, AFlags);
    RequestAlign;
  end;
{$ELSE}
  inherited AdjustSize;
{$ENDIF}
end;

procedure TdxCustomRibbonForm.CallDWMWindowProc(var Message);
begin
  DwmDefWindowProc(Handle, TMessage(Message).Msg, TMessage(Message).WParam,
    TMessage(Message).LParam, Integer(@TMessage(Message).Result));
end;

function TdxCustomRibbonForm.CanAdjustLayout: Boolean;
begin
  Result := AdjustLayoutForNonClientDrawing and
    ([csDesigning, csDestroying, csReading, csLoading] * ComponentState = []);
end;

procedure TdxCustomRibbonForm.CaptionChanged;
begin
  UpdateWindowStates;
  RibbonNonClientHelper.CaptionChanged;
end;

procedure TdxCustomRibbonForm.NewClientWndProc(var Message: TMessage);

  procedure Default;
  begin
    with Message do
      Result := CallWindowProc(FDefClientProc, ClientHandle, Msg, wParam, lParam);
  end;

  procedure OldDefault;
  begin
    with Message do
      Result := CallWindowProc(FOldClientProc, ClientHandle, Msg, wParam, lParam);
  end;

  function MaximizedChildren: Boolean;
  var
    I: Integer;
  begin
    for I := 0 to MDIChildCount - 1 do
      if MDIChildren[I].WindowState = wsMaximized then
      begin
        Result := True;
        Exit;
      end;
    Result := False;
  end;

var
  DC: HDC;
  PS: TPaintStruct;
  R: TRect;
//  F: TForm;
  AColor: TColor;
begin
  if not UseSkin then
  begin
    with Message do
      case Msg of
        WM_NCHITTEST, WM_PAINT, WM_ERASEBKGND:
          OldDefault;
        WM_NCCALCSIZE:;
        WM_NCPAINT:;
        else
          Default;
      end;
    Exit;
  end;
  with Message do