terender.pas

delphi2007界面效果控件源码

// Finds the parent of input vmt instance that handles the message in BX
procedure GetDynaMethodX;
asm
//     -> EAX vmt of class
//     BX dynamic method index
//     <- EBX pointer to vmt of parent or self
//     ZF = 0 if found
//     trashes: EAX, ECX
        PUSH    EDI
        XCHG    EAX,EBX
        JMP     @@haveVMT
@@outerLoop:
        MOV     EBX,[EBX]
@@haveVMT:
        MOV     EDI,[EBX].vmtDynamicTable
        TEST    EDI,EDI
        JE      @@parent
        MOVZX   ECX,word ptr [EDI]
        PUSH    ECX
        ADD     EDI,2
        REPNE   SCASW
        JE      @@found
        POP     ECX
@@parent:
        MOV     EBX,[EBX].vmtParent
        TEST    EBX,EBX
        JNE     @@outerLoop
        JMP     @@exit
@@found:
        POP     EAX
        ADD     EAX,EAX
        SUB     EAX,ECX // this will always clear the Z-flag !
        //    ...return EBX as reference to class
@@exit:
        POP     EDI
end;

// returns the class pointer of self or ancestors that handles the Message
function DoesAncestorHandle(Instance : Pointer; var Message): TClass;
asm
        PUSH    EBX
        MOV     BX,[EDX] //Check if message valid
        OR      BX,BX
        JE      @@bypass
        CMP     BX,0C000H
        JAE     @@bypass
        PUSH    EAX //Prepare stack
        MOV     EAX,[EAX]
        CALL    GetDynaMethodX //try to obtain parents method
        POP     EAX
        JE      @@bypass //not found so return false
        MOV     EAX, EBX //found so return class
        JMP     @@exit
      @@bypass:
        POP    EBX
        MOV    EAX,0
        RET
      @@exit:
        POP  EBX
end;

function CompleteFlags(WinControl: TControl; Flags: DWord): DWord;
var
  Ms: TMessage;
  ClassNCPaint,
  ClassPrint: TClass;
begin
  if((Flags and RCF_PAINTCOPYNC) <> 0) or
    ((Flags and RCF_PAINTCOPY  ) <> 0) then
  begin
    if TWinControl(WinControl).Focused then
    begin
      if(Flags and RCF_PAINTCOPYNC) <> 0 then
        Flags := (Flags and not(RCF_PAINTCOPYNC)) or RCF_PRINT;
      if(Flags and RCF_PAINTCOPY  ) <> 0 then
        Flags := (Flags and not(RCF_PAINTCOPY  )) or RCF_PAINT;
    end;
  end;

  if(((Flags and RCF_RENDERNC) <> 0) and ((Flags and RCF_RENDERNCMASK) = RCF_RENDERNC)) or
    (((Flags and RCF_RENDER  ) <> 0) and ((Flags and RCF_RENDERMASK  ) = RCF_RENDER  )) then
  begin
    Ms.Msg := WM_PRINT;
    ClassPrint := DoesAncestorHandle(WinControl, Ms);

    if((Flags and RCF_RENDER) <> 0) and ((Flags and RCF_RENDERMASK) = RCF_RENDER) then
    begin
      if ClassPrint <> nil
      then Flags := Flags or RCF_PRINT
      else Flags := Flags or RCF_PAINT;
    end;

    if((Flags and RCF_RENDERNC) <> 0) and ((Flags and RCF_RENDERNCMASK) = RCF_RENDERNC) then
    begin
      Ms.Msg       := WM_NCPAINT;
      ClassNCPaint := DoesAncestorHandle(WinControl, Ms);

      if ClassNCPaint = nil
      then Flags := Flags or RCF_PRINTNC
      else
      begin
        if ClassNCPaint.ClassNameIs('TWinControl')
        then Flags := Flags or RCF_EMULNC
        else
        begin
          if(ClassPrint = nil) or not ClassPrint.InheritsFrom(ClassNCPaint)
          then Flags := Flags or RCF_PRINTNC or RCF_REFRESHNC
          else Flags := Flags or RCF_PRINTNC;
        end;
      end;
    end;
  end;
  Result := Flags;
end;

{$ifndef NoVCL}
procedure RegisterTEControl(const ControlClassName: String;
  NonClientRenderMode, ClientRenderMode: DWord;
  RefreshNonClient, RefreshClient: Boolean);
begin
  RegisterTEControlCallback(ControlClassName, NonClientRenderMode, ClientRenderMode,
    RefreshNonClient, RefreshClient, nil, nil);
end;

procedure RegisterTEControlCallback(const ControlClassName: String;
  NonClientRenderMode, ClientRenderMode: DWord;
  RefreshNonClient, RefreshClient: Boolean;
  NonClientCallback, ClientCallback: TTEPaintCallback);
var
  Flags: DWord;
  NonClientCallback2,
  ClientCallback2: TTEPaintCallback;
begin
  NonClientCallback2 := nil;
  ClientCallback2    := nil;

  Flags := $00000000;

  {$ifdef D7UP}
  if not ThemeServices.ThemesEnabled then
    NonClientRenderMode := NonClientRenderMode and not teThemed;
  {$endif D7UP}

  if NonClientRenderMode and teThemed <> 0 then
  begin
    Flags               := Flags or RCF_THEMEDNC;
    NonClientRenderMode := NonClientRenderMode and not teThemed;
  end;
  if NonClientRenderMode and teOwnCanvas <> 0 then
  begin
    Flags               := Flags or RCF_OWNCANVASNC;
    NonClientRenderMode := NonClientRenderMode and not teOwnCanvas;
  end;
  if ClientRenderMode and teOwnCanvas <> 0 then
  begin
    Flags            := Flags or RCF_OWNCANVAS;
    ClientRenderMode := ClientRenderMode and not teOwnCanvas;
  end;
  if NonClientRenderMode and teRefreshFocused <> 0 then
  begin
    Flags               := Flags or RCF_REFRESHFOCUSEDNC;
    NonClientRenderMode := NonClientRenderMode and not teRefreshFocused;
  end;
  if ClientRenderMode and teRefreshFocused <> 0 then
  begin
    Flags            := Flags or RCF_REFRESHFOCUSED;
    ClientRenderMode := ClientRenderMode and not teRefreshFocused;
  end;

  if NonClientRenderMode <> teNoRender then
  begin
    Flags := Flags or RCF_RENDERNC;
    case NonClientRenderMode of
      tePaint    : Flags := Flags or RCF_PAINTNC;
      tePrint    : Flags := Flags or RCF_PRINTNC;
      teEmulate  : Flags := Flags or RCF_EMULNC;
      tePaintCopy: Flags := Flags or RCF_PAINTCOPYNC or RCF_REFRESHFOCUSEDNC;
      teCallback :
                 begin
                   NonClientCallback2 := NonClientCallback;
                   Flags := Flags or RCF_CALLBACKNC;
                 end;
    end;
  end;
  if RefreshNonClient then
    Flags := Flags or RCF_REFRESHNC;

  if ClientRenderMode <> teNoRender then
  begin
    Flags := Flags or RCF_RENDER;
    case ClientRenderMode of
      tePaint    : Flags := Flags or RCF_PAINT;
      tePrint    : Flags := Flags or RCF_PRINT;
      teEmulate  : Flags := Flags or RCF_EMUL;
      tePaintCopy: Flags := Flags or RCF_PAINTCOPY or RCF_REFRESHFOCUSED;
      teCallback :
                 begin
                   ClientCallback2 := ClientCallback;
                   Flags := Flags or RCF_CALLBACK;
                 end;
    end;
  end;

  if RefreshClient then
    Flags := Flags or RCF_REFRESH;
  TERegControls.SaveRegControl(ControlClassName, Flags, NonClientCallback2,
    ClientCallback2);
end;
{$endif NoVCL}

procedure GetTERegControl(const Window: HWND;
  const WinControl: TWinControl; var TERegControl: TTERegControl);

  function GetFlagsFromWindow(const Window: HWND): DWord;
  begin
    Result := 0;
    if SendMessage(Window, CM_BEFULLRENDER, 0, BE_ID) = BE_ID
    then Result := RCF_RENDER or RCF_RENDERNC or RCF_BEFULLRENDER
    else
    begin
      case SendMessage(Window, CM_BENCPAINT, 0, BE_ID) of
        BE_ID-1: Result := RCF_RENDERNC or RCF_BENCPREPAINT;
        BE_ID  : Result := RCF_RENDERNC or RCF_BENCPAINT;
        BE_ID+1: Result := RCF_RENDERNC or RCF_BENCPOSTPAINT;
      end;
      case SendMessage(Window, CM_BEPAINT, 0, BE_ID) of
        BE_ID-1: Result := Result or RCF_RENDER or RCF_BEPREPAINT;
        BE_ID  : Result := Result or RCF_RENDER or RCF_BEPAINT;
        BE_ID+1: Result := Result or RCF_RENDER or RCF_BEPOSTPAINT;
      end;
    end;
  end;

var
  Flags: DWord;
begin
  TERegControl.Clear;
  if WinControl = nil
  then
  begin
    TERegControl.Flags := GetFlagsFromWindow(Window);
    if(TERegControl.Flags and RCF_RENDERNCMASK) = 0 then
      TERegControl.Flags := RCF_RENDERNC or RCF_PRINTNC;
    if(TERegControl.Flags and RCF_RENDERMASK) = 0 then
      TERegControl.Flags := TERegControl.Flags or (RCF_RENDER or RCF_PAINT);
  end
  else
  begin
    {$ifndef NoVCL}
    TERegControls.FindRegControl(WinControl,
      TControlClass(WinControl.ClassType), TERegControl);
    {$endif NoVCL}
    Flags := GetFlagsFromWindow(Window);
    if(Flags and RCF_BEFULLRENDER) <> 0
    then TERegControl.Flags := Flags
    else
    begin
      if(Flags and RCF_RENDERNCMASK) <> 0 then
      begin
        if(Flags and (RCF_BENCPREPAINT or RCF_BENCPOSTPAINT)) <> 0
        then TERegControl.Flags := TERegControl.Flags or (Flags and RCF_RENDERNCMASK)
        else TERegControl.Flags :=
               (TERegControl.Flags and (not RCF_RENDERNCMASK)) or
               (Flags and RCF_RENDERNCMASK);
      end;
      if(Flags and RCF_RENDERMASK) <> 0 then
      begin
        if(Flags and (RCF_BEPREPAINT or RCF_BEPOSTPAINT)) <> 0
        then TERegControl.Flags := TERegControl.Flags or (Flags and RCF_RENDERMASK)
        else TERegControl.Flags :=
               (TERegControl.Flags and (not RCF_RENDERMASK)) or
               (Flags and RCF_RENDERMASK);
      end;
      TERegControl.Flags := CompleteFlags(WinControl, TERegControl.Flags);
    end;
  end;
end;

procedure InternalRefreshWindows(Window: HWND; TERegControl: TTERegControl);
var
  ChildWnd: HWND;
  Control: TWinControl;
  RefreshNonClient,
  RefreshClient: Boolean;
begin
  if not IsWindowVisible(Window)
    then Exit;

  Control := FindControl(Window);

  if Control <> nil then
  begin
    GetTERegControl(0, Control, TERegControl);

    RefreshNonClient := (TERegControl.Flags and RCF_REFRESHNC) <> 0;
    RefreshClient    := (TERegControl.Flags and RCF_REFRESH  ) <> 0;

    if Control.Focused then
    begin
      RefreshNonClient :=
        RefreshNonClient or
        ((TERegControl.Flags and RCF_REFRESHFOCUSEDNC) <> 0);
      RefreshClient    :=
        RefreshClient    or
        ((TERegControl.Flags and RCF_REFRESHFOCUSED  ) <> 0);
    end;

    if RefreshNonClient then
      SendMessage(Window, WM_NCPAINT, 0, 0);

    if RefreshClient then
      if(Control <> nil) and (Control.ControlCount > 0)
      then RedrawWindow(Window, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_NOCHILDREN)
      else RedrawWindow(Window, nil, 0, RDW_ERASE or RDW_INVALIDATE or RDW_ALLCHILDREN);
  end;

  ChildWnd := GetWindow(Window, GW_CHILD);
  while ChildWnd <> 0 do
  begin
    InternalRefreshWindows(ChildWnd, TERegControl);
    ChildWnd := GetWindow(ChildWnd, GW_HWNDNEXT);
  end;
end;

procedure RefreshWindows(Window: HWND);
var
  TERegControl: TTERegControl;
begin
  TERegControl := TTERegControl.Create(0, nil, nil);
  try
    InternalRefreshWindows(Window, TERegControl);
  finally
    TERegControl.Free;
  end;
end;

procedure GetData(WinControl: TWinControl;
  Window: HWnd; var ClassType: TClass;
  var IsMaximizedMDIClient, IsMaximizedMDIChild, IsRenderWindow: Boolean);
var
  ClassName: array[0..63] of Char;
begin
  if WinControl <> nil
  then
  begin
    ClassType := WinControl.ClassType;
    StrPCopy(ClassName, WinControl.ClassName);

    if GetMDIFormWithMaximizedMDIChild(WinControl) then
    begin // Edge changing
      SetWindowLong(Application.MainForm.ClientHandle, GWL_EXSTYLE,
        GetWindowLong(Application.MainForm.ClientHandle,
          GWL_EXSTYLE) and not WS_EX_CLIENTEDGE);
      SetWindowPos(Application.MainForm.ClientHandle, 0, 0, 0, 0, 0,
        SWP_FRAMECHANGED or SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE or
        SWP_NOZORDER);
    end;

    IsMaximizedMDIClient := False;
    IsMaximizedMDIChild  := GetMaximizedMDIChild(WinControl);
  end
  else
  begin
    GetClassName(Window, ClassName, Sizeof(ClassName));
    ClassType := GetClass(ClassName);
    IsMaximizedMDIClient := GetMaximizedMDIClient(ClassName);
    IsMaximizedMDIChild  := False;
  end;
  IsRenderWindow := StrIComp(ClassName, 'TTERenderWindow') = 0;
end;

procedure GetSize(Window: HWnd; IsMaximizedMDIChild: Boolean;
  var Width, Height: Integer);
var
  WndRect: TRect;
begin
  if IsMaximizedMDIChild
  then GetClientRect(GetParent(Window), WndRect)
  else GetWindowRect(Window, WndRect);
  Width  := WndRect.Right  - WndRect.Left;
  Height := WndRect.Bottom - WndRect.Top;
end;

procedure CheckClipRegion(Window: HWnd; DC: HDC;
  CheckRegion, IsMaximizedMDIChild: Boolean; Width, Height: Integer; R: TRect);
var
  WndRect: TRect;
  WndRgn,
  ClipRgn: HRGN;
  P: TPoint;
begin
  WndRect := Rect(0, 0, Width, Height);
  WndRgn  := CreateRectRgn(WndRect.Left, WndRect.Top, WndRect.Right,