terender.pas

Do your applications look a little boring? Would you like to get spectacular yet easy to use visual

  then Result := BitCounts[PixelFormat]
  else Result := BitCounts[DevicePixelFormat(False)];
end;

function GetBitmapGap(Bitmap: TBitmap; PixelFormat: TPixelFormat): Integer;
begin
  Result :=
    GetBytesPerScanline(Bitmap, PixelFormat, 32) -
    GetBytesPerScanline(Bitmap, PixelFormat, 8);
end;

function GetMaximizedMDIChild(WinControl: TWinControl): Boolean;
var
  i: Integer;
begin
  Result := False;

  if(WinControl is TCustomForm) and
    (TTECustomForm(WinControl).FormStyle = fsMDIChild) and
    (Application.MainForm <> nil) and
    (TTECustomForm(Application.MainForm).FormStyle = fsMDIForm) then
  begin
    if TTECustomForm(WinControl).WindowState = wsMaximized
    then Result := True
    else
    begin
      for i := 0 to TTECustomForm(Application.MainForm).MDIChildCount - 1 do
        if TTECustomForm(Application.MainForm).MDIChildren[I].WindowState = wsMaximized then
        begin
          Result := True;
          Exit;
        end;
    end;
  end;
end;

function GetMaximizedMDIClient(ClassName: PChar): Boolean;
var
  i: Integer;
begin
  Result := False;
  if StrIComp(ClassName, 'MDICLIENT') = 0 then
  begin
    for i := 0 to TTECustomForm(Application.MainForm).MDIChildCount - 1 do
      if TTECustomForm(Application.MainForm).MDIChildren[I].WindowState = wsMaximized then
      begin
        Result := True;
        Exit;
      end;
  end;
end;

{$ifndef D3C3}
function GetMDIFormWithMaximizedMDIChild(WinControl: TWinControl): Boolean;
begin
  Result :=
    (WinControl is TCustomForm)                       and
    (TTECustomForm(WinControl).FormStyle = fsMDIForm) and
    GetMaximizedMDIClient('MDICLIENT');
end;
{$endif D3C3}

function GetSnapShotImage(R: TRect; PixelFormat: TPixelFormat): TBitmap;
const
  CAPTUREBLT = 1073741824; //V33
var
  ScreenDC: HDC;
  RopCode: Cardinal;      //V33
begin
  Result := TBitmap.Create;
  try
    AdjustBmpForTransition(Result, {$ifndef CLX}0,{$endif CLX} R.Right - R.Left,
      R.Bottom - R.Top, PixelFormat);
    Result.Canvas.Lock;
    try
      ScreenDC := GetDC(0);
      try
        {$ifndef CLX}
        If GetWinVersion In [teWin2000,teWinXP,teWinFuture] Then //V33
          RopCode:=cmSrcCopy+CAPTUREBLT
        Else
          RopCode:=cmSrcCopy;
        BitBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height,
          ScreenDC, R.Left, R.Top, RopCode);
        {$else}
        Windows.BitBlt(QPainter_handle(Result.Canvas.Handle), 0, 0,
          Result.Width, Result.Height, ScreenDC, R.Left, R.Top, SRCCOPY);
        {$endif CLX}
      finally
        ReleaseDC(0, ScreenDC);
      end;
    finally
      Result.Canvas.Unlock;
    end;
  except
    Result.Free;
    raise;
  end;
end;

function GetSolidColorImage(Control: TControl; Width, Height: Integer;
  Color: TColor; Palette: HPALETTE; PixelFormat: TPixelFormat): TBitmap;
var
  ColorToUse: TColor;
begin
  Result := TBitmap.Create;
  try
    AdjustBmpForTransition(Result, {$ifndef CLX}Palette,{$endif CLX} Width,
      Height, PixelFormat);
    Result.Canvas.Lock;
    try
      if Color = clNone
      then ColorToUse := TTEControl(Control).Color
      else ColorToUse := Color;

      Result.Canvas.Brush.Color := ColorToUse;
      Result.Canvas.FillRect(Rect(0, 0, Width+1, Height+1));
    finally
      Result.Canvas.Unlock;
    end;
  except
    Result.Free;
    raise;
  end;
end;

{$ifndef D5UP}
function GetWindowRgn; external user32 name 'GetWindowRgn';
{$endif D5UP}

function IsScrollBarVisible(Control: TControl; Window: HWND;
  Kind: TScrollBarKind): Boolean;
var
  Style,
  MinPos,
  MaxPos,
  nBar: Longint;
  ControlScrollBar: TControlScrollBar;
begin
  ControlScrollBar := nil;
  if Kind = sbVertical
  then
  begin
    if(Control <> nil) and (Control is TScrollingWinControl) then
      ControlScrollBar := TScrollingWinControl(Control).VertScrollBar;
    Style := WS_VSCROLL;
    nBar  := SB_VERT;
  end
  else
  begin
    if(Control <> nil) and (Control is TScrollingWinControl) then
      ControlScrollBar := TScrollingWinControl(Control).HorzScrollBar;
    Style := WS_HSCROLL;
    nBar  := SB_HORZ;
  end;
  Result := ((Control = nil) or (ControlScrollBar = nil) or ControlScrollBar.Visible) and
            (GetWindowLong(Window, GWL_STYLE) and Style <> 0);
  if Result then
  begin
    GetScrollRange(Window, nBar, MinPos, MaxPos);
    Result := (MinPos <> 0) or (MaxPos <> 0);
  end;
end;

function IsWindowClipped(Window: HWND; AvoidWnd: HWND; R: TRect): Boolean;
{$ifndef CLX}
var
  Sibling: hWnd;
  R2, R3: TRect;
{$endif CLX}
begin
  {$ifdef CLX}
  Result := True;
  {$else}
  Result := False;
  if Window = 0 then Exit;
  While (Not Result)And(Window<>0) Do
  Begin
    Sibling:=GetWindow(Window,GW_HWNDPREV	);
    While Not(Result) And (Sibling<>0) Do
    Begin
      If IsWindowVisible(Sibling) And (Sibling<>AvoidWnd) Then
      Begin
        GetWindowRect(Sibling,R2);
        Result := IntersectRect(R3, R, R2);
      End;
      Sibling:=GetWindow(Sibling,GW_HWNDPREV);
    End;
    If Not Result Then
    Begin
      Window:=GetParent(Window);
      If (Window<>0) And ((GetWindowLong(Window,GWL_STYLE) And WS_CHILDWINDOW)=0) Then
        Window:=0;
      If Window=0 Then
        R2:=Rect(0,0,GetSystemMetrics(SM_CXSCREEN),GetSystemMetrics(SM_CYSCREEN))
      Else
        GetWindowRect(Window,R2);
      IntersectRect(R3, R, R2);
      Result:=Not EqualRect(R,R3);
    End;
  end;
  {$endif CLX}
end;

function PalettedDevice(Recalculate: Boolean): Boolean;
begin
  Result := DeviceBitsPerPixel(Recalculate) = 8;
end;

function RGBDevice(Recalculate: Boolean): Boolean;
begin
  Result := DeviceBitsPerPixel(Recalculate) > 8;
end;

function RealizeControlPalette(Control: TControl;
  ForceBackground: Boolean): Boolean;
{$ifndef CLX}
var
  i: integer;
  Palette,
  OldPalette: HPALETTE;
  WindowHandle: HWnd;
  DC: HDC;
{$endif CLX}
begin
  {$ifdef CLX}
  Result := True;
  {$else}
  Result := False;

  if(Control = nil) or (not PalettedDevice(False)) then Exit;

  Palette := TTEControl(Control).GetPalette;
  if Palette <> 0 then
  begin
    Result := True;
    if Control is TWinControl
    then WindowHandle := TWinControl(Control).Handle
    else WindowHandle := Control.Parent.Handle;
    DC := GetDC(WindowHandle);
    OldPalette := SelectPalette(DC, Palette, ForceBackground);
    RealizePalette(DC);
    SelectPalette(DC, OldPalette, True);
    ForceBackground := True;
    ReleaseDC(WindowHandle, DC);
  end;

  if Control is TWinControl then
  begin
    with TWinControl(Control) do
    begin
      for i:=ControlCount-1 downto 0 do
        if Controls[i].Visible and RealizeControlPalette(Controls[i],
          ForceBackground) then
        begin
          ForceBackground := True;
          Result := True;
        end;
    end;
  end;
  {$endif CLX}
end;

// 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_RENDERNC) <> 0) and
      (Flags and (RCF_PAINTNC or RCF_PRINTNC or RCF_EMULNC or RCF_CALLBACK or RCF_HOOKNC or RCF_PAINTCOPYNC) = 0)) or
    (((Flags and RCF_RENDER  ) <> 0) and
      (Flags and (RCF_PAINT   or RCF_PRINT   or RCF_EMUL   or RCF_CALLBACK or RCF_HOOK   or RCF_PAINTCOPY  ) = 0)) then
  begin
    Ms.Msg := WM_PRINT;
    ClassPrint := DoesAncestorHandle(WinControl, Ms);

    if((Flags and RCF_RENDER) <> 0) and
       (Flags and (RCF_PAINT or RCF_PRINT or RCF_EMUL or RCF_CALLBACK or RCF_HOOK or RCF_PAINTCOPY) = 0) 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_PAINTNC or RCF_PRINTNC or RCF_EMULNC or RCF_CALLBACK or RCF_HOOKNC or RCF_PAINTCOPYNC) = 0) 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;

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
//  if IsWinXPUp then
//    exit;

  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 and tePaintCopy <> 0 then
  begin
    Flags               := Flags or RCF_PAINTCOPYNC or RCF_REFRESHFOCUSEDNC;
    NonClientRenderMode := NonClientRenderMode and not tePaintCopy;
  end;
  if ClientRenderMode and tePaintCopy <> 0 then
  begin
    Flags            := Flags or RCF_PAINTCOPY or RCF_REFRESHFOCUSED;
    ClientRenderMode := ClientRenderMode and not tePaintCopy;
  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;