terender.pas

delphi2007界面效果控件源码

unit teRender;

interface

{$INCLUDE teDefs.inc}
{$RANGECHECKS OFF}

uses
  Windows, Messages, SysUtils, Classes, Consts, Forms, Graphics, Controls;

{$ifndef TE_NOHLP}
const // Billenium Effects messages
  // Thir party components interface
  BE_ID           = $41A2;
  BE_BASE         = CM_BASE + $0C4A;
  CM_BEPAINT      = BE_BASE + 0; // Paint client area to Billenium Effects' DC
  CM_BENCPAINT    = BE_BASE + 1; // Paint non client area to Billenium Effects' DC
  CM_BEFULLRENDER = BE_BASE + 2; // Paint whole control to Billenium Effects' DC
  CM_BEWAIT       = BE_BASE + 3; // Don't execute effect yet
  CM_BERUN        = BE_BASE + 4; // Execute effect now!
  // Internal messages
  CM_BEFORMSHOWN  = BE_BASE + 5; // The form is visible for the user

  LWA_ALPHA = $00000002;

{$endif TE_NOHLP}

const
  teAuto           = $00000000;
  tePaint          = $00000001;
  tePrint          = $00000002;
  teEmulate        = $00000003;
  teCallback       = $00000004;
  tePaintCopy      = $00000005;

  teThemed         = $10000000;
  {$ifndef TE_NOHLP}
  teRefreshFocused = $20000000;
  {$endif TE_NOHLP}
  teOwnCanvas      = $40000000;
  teNoRender       = $80000000;

type
  {$ifndef TE_NOHLP}
  TDWordArray = array[0..65535] of DWord;
  PDWordArray = ^TDWordArray;
  TTEProcessorInfo = record
    MMX,
    SSE: Boolean;
  end;
  {$endif TE_NOHLP}

  TTEWinVersion = (teWinUnknown, teWin32s, teWin95, teWin98, teWin98SE, teWinME,
    teWinNT, teWin2000, teWinXP, teWin2003, teWinVista, teWinFuture);

  TTEPaintCallback = procedure(Control: TWinControl; DC: HDC);

  procedure AdjustBmpForTransition(Bmp: TBitmap; Palette: HPalette;
    Width, Height: Integer; PixelFormat: TPixelFormat);
  {$ifndef TE_NOHLP}
  function  ControlClientAreaHasRegion(Control: TWinControl): Boolean;
  function  ControlClientOffset(Control: TControl): TPoint;
  function  ControlClientOrigin(Control: TControl): TPoint;
  function  ControlScreenToClient(Control: TControl; Point: TPoint): TPoint;
  function  ControlClientToScreen(Control: TControl; Point: TPoint): TPoint;
  function  ControlClientRect(Control: TControl): TRect;
  function  ControlClientHeight(Control: TControl): Integer;
  function  ControlClientWidth(Control: TControl): Integer;
  {$endif TE_NOHLP}
  function  DeviceBitsPerPixel(
    Recalculate: Boolean = False): Integer;
  function  DevicePixelFormat(
    Recalculate: Boolean = False): TPixelFormat;
  function  IsWindowLayered(Window: HWND): Boolean;
  function  GetBytesPerScanline(Bitmap: TBitmap; PixelFormat: TPixelFormat;
    Alignment: Longint = 32): Longint;
  {$ifndef TE_NOHLP}
  function  GetPixelFormatBPP(PixelFormat: TPixelFormat): Integer;
  function  GetBitmapGap(Bitmap: TBitmap; PixelFormat: TPixelFormat): Integer;
  function  GetMaximizedMDIChild(WinControl: TWinControl): Boolean;
  {$endif TE_NOHLP}
  function  GetSnapShotImage(R: TRect; PixelFormat: TPixelFormat;
    GrabLayeredWindows: Boolean): TBitmap;
  {$ifndef TE_NOHLP}
  procedure GetSolidColorBmp(Bmp: TBitmap; Width, Height: Integer;
    Color: TColor; Palette: HPalette; PixelFormat: TPixelFormat);
  {$endif TE_NOHLP}
  {$ifndef TE_NOHLP}
  function  IsScrollBarVisible(Control: TControl; Window: HWND;
    Kind: TScrollBarKind): Boolean;
  function  IsWindowClipped(Window, AvoidWnd: HWND; R: TRect): Boolean;
  {$endif TE_NOHLP}
  function  PalettedDevice(
    Recalculate: Boolean = False): Boolean;
  function  RGBDevice(Recalculate: Boolean = False): Boolean;
  {$ifndef TE_NOHLP}
  // Dwm API
  function  IsCompositionEnabled: Boolean;
  procedure DisableDwmTransitions(Window: HWND);
  function  DwmSetWindowAttribute(Hwnd: HWND; dwAttribute: DWORD;
    pvAttribute: Pointer; cbAttribute: DWORD): HResult;
  function  RealizeControlPalette(Control: TControl;
    ForceBackground: Boolean): Boolean;
  procedure RefreshWindows(Window: HWND);
  {$endif TE_NOHLP}
  {$ifndef NoVCL}
  procedure RegisterTEControl(const ControlClassName: String;
    NonClientRenderMode, ClientRenderMode: DWord;
    RefreshNonClient, RefreshClient: Boolean);
  procedure RegisterTEControlCallback(const ControlClassName: String;
    NonClientRenderMode, ClientRenderMode: DWord;
    RefreshNonClient, RefreshClient: Boolean;
    NonClientCallback, ClientCallback: TTEPaintCallback);
  {$endif NoVCL}
  function  RenderControl(Control: TControl; StopWnd: Hwnd; R: TRect;
    ClientCoordinates, CheckRegion, Fast: Boolean;
    PixelFormat: TPixelFormat): TBitmap;
  {$ifndef TE_NOHLP}
  function RenderWindowToBmp(Bmp: TBitmap;
    Window, StopWnd: HWND;
    WinControl: TWinControl;
    R: TRect; ClientCoordinates, CheckVisibility, CheckRegion, Fast: Boolean;
    PixelFormat: TPixelFormat): TBitmap;
  procedure RenderWindowToDC(Window, StopWnd: HWND; WinControl: TWinControl;
    DC: HDC; R: TRect;
    ClientCoordinates, CheckVisibility, CheckRegion, Fast: Boolean);
  function ClassInheritsFrom(const ClassType: TClass;
    const ClassName: String): Boolean;
  function WindowHasRegion(Window: HWnd): Boolean;
  procedure HookAPICall(Dll, Name: string; OrgAPICall, NewAPICall: Pointer;
    var SaveAPICall: Pointer; IATPatching: Boolean);
  procedure UnhookAPICall(OrgAPICall, NewAPICall: Pointer;
    var SaveAPICall: Pointer; IATPatching: Boolean);
  {$endif TE_NOHLP}
  function  BilleniumEffectsVersion: String;

{$ifndef TE_NOHLP}
type
  TUpdateLayeredWindow        = function (Hwnd: THandle; hdcDst: HDC;
    pptDst: PPoint; psize: PSize; hdcSrc: HDC; pptSrc: PPoint; crKey: COLORREF;
    pblend: PBlendFunction; dwFlags: DWord): Boolean; stdcall;
  TGetLayeredWindowAttributes = function (Hwnd: THandle; out pcrKey: COLORREF;
    out pbAlpha: Byte; out pdwFlags: DWORD): Boolean; stdcall;
  TSetLayeredWindowAttributes = function (Hwnd: THandle; crKey: COLORREF;
    bAlpha: Byte; dwFlags: DWORD): Boolean; stdcall;

var
  UpdateLayeredWindow: TUpdateLayeredWindow = nil;
  GetLayeredWindowAttributes: TGetLayeredWindowAttributes = nil;
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes = nil;
//  TECurBmp: TBitmap = nil;
  TEProcessorInfo: TTEProcessorInfo;
  TEWinVersion: TTEWinVersion;
{$endif TE_NOHLP}
  TEXPRenderDisabled,
  TEAPIHooksDisabled,
  TEIsRunTimePackage: Boolean;

implementation

uses
  FlatSB,
  {$ifdef D7UP} Themes, {$endif D7UP}
  TypInfo, OleCtrls, ActiveX, RichEdit;

const
  RCF_RENDERNC         = $00000001; // Do render the non-client area
  RCF_REFRESHNC        = $00000002; // Always refresh the non-client area
  RCF_REFRESHFOCUSEDNC = $00000004; // Refresh the non-client area only if the control is focused
  RCF_PRINTNC          = $00000008; // Render non-client area using WM_PRINT message
  RCF_PAINTNC          = $00000010; // Render non-client area using WM_PAINT message
  RCF_EMULNC           = $00000020; // Render non-client with custom code
  RCF_CALLBACKNC       = $00000040; // Render non-client area using a callback method
  RCF_THEMEDNC         = $00000080; // Render non-client area XP themes
  RCF_PAINTCOPYNC      = $00000100; // Render non-client area setting the csPaintCopy control state
  RCF_BENCPREPAINT     = $00000200; // Use BE_NCPAINT, then render non-client area
  RCF_BENCPAINT        = $00000400; // Render non-client area only using BE_NCPAINT
  RCF_BENCPOSTPAINT    = $00000800; // Render non-client area, then use BE_NCPAINT
  RCF_OWNCANVASNC      = $00001000; // Render non-client area in a separate bitmap

  RCF_BEFULLRENDER     = $00080000; // Renders whole window at once using CM_BEFULLRENDER

  RCF_RENDER           = $00100000; // Do render the client area
  RCF_REFRESH          = $00200000; // Always refresh the client area
  RCF_REFRESHFOCUSED   = $00400000; // Refresh the client area only if the control is focused
  RCF_PRINT            = $00800000; // Render client area using WM_PRINT message
  RCF_PAINT            = $01000000; // Render client area using WM_PAINT message
  RCF_EMUL             = $02000000; // Render client with custom code
  RCF_CALLBACK         = $04000000; // Render client area using a callback method
  RCF_PAINTCOPY        = $08000000; // Render client area setting the csPaintCopy control state
  RCF_BEPREPAINT       = $10000000; // Use BE_PAINT, then render client area
  RCF_BEPAINT          = $20000000; // Render client area only using BE_PAINT
  RCF_BEPOSTPAINT      = $40000000; // Render client area, then use BE_PAINT
  RCF_OWNCANVAS        = $80000000; // Render client area in a separate bitmap

  RCF_RENDERMASK       = $FFF00000;
  RCF_RENDERNCMASK     = $00001FFF;

  // Dwm API
  DWMWA_TRANSITIONS_FORCEDISABLED = 3;

type
  TTEControl    = class(TControl);
  TTEWinControl = class(TWinControl);
  TTECustomForm = class(TCustomForm);

  TTERegControl = class(TObject)
  public
    Flags: DWord;
    NonClientCallback,
    ClientCallback: TTEPaintCallback;

    constructor Create(FlagsValue: DWord;
      NonClientCallbackValue, ClientCallbackValue: TTEPaintCallback);
    procedure Assign(Source: TTERegControl);
    procedure Clear;
  end;

  {$ifndef NoVCL}
  TTERegControls = class(TStringList)
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure FindRegControl(Control: TWinControl; ControlClass: TControlClass;
      var Data: TTERegControl);
    procedure SaveRegControl(ControlClassName: String; Flags: DWord;
      NonClientCallback, ClientCallback: TTEPaintCallback);
  end;
  {$endif NoVCL}

var
  // Dwm API
  hDWMAPI: THandle = 0;
  _DwmIsCompositionEnabled: function(out pfEnabled: BOOL): HResult; stdcall = nil;
  _DwmSetWindowAttribute: function (Hwnd: HWND; dwAttribute: DWORD;
    pvAttribute: Pointer; cbAttribute: DWORD): HResult; stdcall = nil;

  FDevicePixelFormat: TPixelFormat;
  FDeviceBitsPerPixel: Integer;
  {$ifndef NoVCL}
  TERegControls: TTERegControls;
  {$endif NoVCL}

  // Hooks
  HookDCCount: Integer = 0;
  HookDC: HDC   = 0;
  HookWnd: HWND = 0;
  SaveGetDC      : function(hWnd: HWND): HDC; stdcall = nil;
  SaveGetDCEx    : function(hWnd: HWND; hrgnClip: HRGN; flags: DWORD): HDC; stdcall = nil;
  SaveGetWindowDC: function(hWnd: HWND): HDC; stdcall = nil;
  SaveReleaseDC  : function(hWnd: HWND; hDC: HDC): Integer; stdcall = nil;
  SaveBeginPaint : function(hWnd: HWND; var lpPaint: TPaintStruct): HDC; stdcall = nil;
  SaveEndPaint   : function(hWnd: HWND; const lpPaint: TPaintStruct): BOOL; stdcall = nil;

{ Global routines }

function CreateIdentityPalette: HPalette;
var
  DC: HDC;
  SysPalSize: Integer;
  Pal: TMaxLogPalette;
begin
  DC := GetDC(0);
  try
    SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
    Pal.palVersion := $300;
    Pal.palNumEntries := SysPalSize;
    GetSystemPaletteEntries(DC, 0, SysPalSize, Pal.palPalEntry);
    Result := CreatePalette(PLogPalette(@Pal)^);
  finally
    ReleaseDC(0, DC);
  end;
end;

{$ifdef Trial}
{$include trial\taux5.inc}
{$endif Trial}

procedure AdjustBmpForTransition(Bmp: TBitmap; Palette: HPalette;
  Width, Height: Integer; PixelFormat: TPixelFormat);
begin
  Bmp.PixelFormat := PixelFormat;
  case PixelFormat of
    pf1bit : Bmp.Monochrome := True;
    pf8bit : begin
               if Palette = 0
               then Bmp.Palette := CreateIdentityPalette
               else Bmp.Palette := Palette;
             end;
  end;
  Bmp.Width  := Width;
  Bmp.Height := Height;
end;

// Returns the offset of the client area within the control
function ControlClientOffset(Control: TControl): TPoint;
var
  R: TRect;
begin
  if Control is TWinControl
  then
  begin
    Result := ControlClientOrigin(Control);
    GetWindowRect(TWinControl(Control).Handle, R);
    Dec(Result.X, R.Left);
    Dec(Result.Y, R.Top);
  end
  else
  begin
    Result.X := 0;
    Result.Y := 0;
  end;
end;

// Returns the client area origin in screen coordinates
function ControlClientOrigin(Control: TControl): TPoint;
begin
  Result := Control.ClientOrigin;
end;

// Maps the given point in screen coordinates to Control coordinates
function ControlScreenToClient(Control: TControl; Point: TPoint): TPoint;
begin
  Result := Control.ScreenToClient(Point);
end;

// Maps the given point in Control coordinates to screen coordinates
function ControlClientToScreen(Control: TControl; Point: TPoint): TPoint;
begin
  Result := Control.ClientToScreen(Point);
end;

// Returns the control client area
function ControlClientRect(Control: TControl): TRect;
begin
  Result := Control.ClientRect;
end;

function ControlClientHeight(Control: TControl): Integer;
begin
  with ControlClientRect(Control) do
    Result := Bottom - Top;
end;

function ControlClientWidth(Control: TControl): Integer;
begin
  with ControlClientRect(Control) do
    Result := Right - Left;
end;

function DeviceBitsPerPixel(Recalculate: Boolean): Integer;
var
  DC: HDC;
begin
  if Recalculate then
  begin
    DC := GetDC(0);
    try
      FDeviceBitsPerPixel := 
        GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
    finally
      ReleaseDC(0, DC);
    end;
  end;
  Result := FDeviceBitsPerPixel;
end;

function Check16bpp: TPixelFormat;
var
  hdcDisplay,
  hdcBitmap: HDC;
  Bitmap,
  OldBitmap: HBitmap;
  Green: Byte;
  Count: Integer;
  PrevGPixel: DWord;
  PrevPixel,
  NewPixel: TColorRef;
begin
  hdcDisplay := GetDC(0);
  try
    hdcBitmap  := CreateCompatibleDC(hdcDisplay);
    try
      Bitmap := CreateCompatibleBitmap(hdcDisplay, 10, 10);
      try
        OldBitmap := SelectObject(hdcBitmap, Bitmap);
        try
          PrevGPixel := 255;
          Count := 0;
          for Green := 0 to 255 do
          begin
            NewPixel := RGB(0, Green, 0);
            SetPixel(hdcBitmap, 1, 1, NewPixel);