terender.pas

delphi2007界面效果控件源码

            PrevPixel  := GetPixel(hdcBitmap, 1, 1);
            if GetGValue(PrevPixel) <> PrevGPixel then
              Inc(Count);
            PrevGPixel := GetGValue(PrevPixel);
          end;
          if Count > 32
          then Result := pf16bit
          else Result := pf15bit;
        finally
          SelectObject(hdcBitmap, OldBitmap);
        end;
      finally
        DeleteObject(Bitmap);
      end;
    finally
      DeleteDC(hdcBitmap);
    end;
  finally
    ReleaseDC(0, hdcDisplay);
  end;
end;

function DevicePixelFormat(Recalculate: Boolean): TPixelFormat;
begin
  if Recalculate then
  begin
    case DeviceBitsPerPixel(True) of
      1  : FDevicePixelFormat := pf1bit;
      4  : FDevicePixelFormat := pf4bit;
      8  : FDevicePixelFormat := pf8bit;
      15 : FDevicePixelFormat := pf15bit;
      16 : FDevicePixelFormat := Check16bpp;
      24 : FDevicePixelFormat := pf24bit;
      32 : FDevicePixelFormat := pf32bit;
      else FDevicePixelFormat := pf24bit;
    end;
  end;
  Result := FDevicePixelFormat;
end;

function IsWindowLayered(Window: HWND): Boolean;
const
  WS_EX_LAYERED = $00080000;
begin
  Result := (GetWindowLong(Window, GWL_EXSTYLE) and WS_EX_LAYERED) <> 0;
end;

// Dwm API
function InitDwmApi: Boolean;
begin
  if(hDWMAPI = 0) and (TEWinVersion >= teWinVista) then
    hDWMAPI := LoadLibrary('DWMAPI.DLL');
  Result := hDWMAPI > 0;
end;

function IsCompositionEnabled: Boolean;
var
  pfEnabled: BOOL;
begin
  pfEnabled := False;
  if not Assigned(_DwmIsCompositionEnabled) then
  begin
    if InitDwmApi then
      _DwmIsCompositionEnabled := GetProcAddress(hDWMAPI, 'DwmIsCompositionEnabled');
  end;
  if Assigned(_DwmIsCompositionEnabled) then
    _DwmIsCompositionEnabled(pfEnabled);
  Result := pfEnabled;
end;

procedure DisableDwmTransitions(Window: HWND);
var
  TransitionsForceDisabledValue: BOOL;
begin
  if IsCompositionEnabled then
  begin
    // Disable Windows own transitions
    TransitionsForceDisabledValue := True;
    DwmSetWindowAttribute(Window, DWMWA_TRANSITIONS_FORCEDISABLED,
      @TransitionsForceDisabledValue, SizeOf(BOOL));
  end;
end;

function DwmSetWindowAttribute(Hwnd: HWND; dwAttribute: DWORD;
  pvAttribute: Pointer; cbAttribute: DWORD): HResult;
begin
  Result := E_NOTIMPL;
  if not Assigned(_DwmSetWindowAttribute) then
  begin
    if InitDwmApi then
      _DwmSetWindowAttribute := GetProcAddress(hDWMAPI, 'DwmSetWindowAttribute');
  end;
  if Assigned(_DwmSetWindowAttribute) then
    Result := _DwmSetWindowAttribute(Hwnd, dwAttribute, pvAttribute, cbAttribute);
end;

function GetBytesPerScanline(Bitmap: TBitmap;
  PixelFormat: TPixelFormat;
  Alignment: Longint): Longint;
var
  PixelsPerScanline: Longint;
begin
  if PixelFormat in [pfDevice, pfCustom] then
  begin
    Result := 0;
    exit;
  end;
  PixelsPerScanline := Bitmap.Width;
  Dec(Alignment);
  Result := ((PixelsPerScanline * GetPixelFormatBPP(PixelFormat) + Alignment)
    and not Alignment) div 8;
end;

function GetPixelFormatBPP(PixelFormat: TPixelFormat): Integer;
const
  BitCounts: array [pf1Bit..pf32Bit] of Byte = (1,4,8,16,16,24,32);
begin
  if PixelFormat <> pfCustom
  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;

function GetMDIFormWithMaximizedMDIChild(WinControl: TWinControl): Boolean;
begin
  Result :=
    (WinControl is TCustomForm)                       and
    (TTECustomForm(WinControl).FormStyle = fsMDIForm) and
    GetMaximizedMDIClient('MDICLIENT');
end;

function GetSnapShotImage(R: TRect; PixelFormat: TPixelFormat;
  GrabLayeredWindows: Boolean): TBitmap;
const
  CAPTUREBLT = $40000000;
var
  ScreenDC: HDC;
  RopCode: Cardinal;
begin
  Result := TBitmap.Create;
  try
    Result.Canvas.Lock;
    try
      AdjustBmpForTransition(Result, 0, R.Right - R.Left,
        R.Bottom - R.Top, PixelFormat);
      ScreenDC := GetDC(0);
      try
        if GrabLayeredWindows and (TEWinVersion >= teWin2000)
        then RopCode := cmSrcCopy or CAPTUREBLT
        else RopCode := cmSrcCopy;
        BitBlt(Result.Canvas.Handle, 0, 0, Result.Width, Result.Height,
          ScreenDC, R.Left, R.Top, RopCode);
      finally
        ReleaseDC(0, ScreenDC);
      end;
    finally
      Result.Canvas.Unlock;
    end;
  except
    Result.Free;
    raise;
  end;
end;

procedure GetSolidColorBmp(Bmp: TBitmap; Width, Height: Integer; Color: TColor;
  Palette: HPalette; PixelFormat: TPixelFormat);
begin
  Bmp.Canvas.Lock;
  try
    AdjustBmpForTransition(Bmp, Palette, Width, Height, PixelFormat);
    Bmp.Canvas.Brush.Color := Color;
    Bmp.Canvas.FillRect(Rect(0, 0, Width+1, Height+1));
  finally
    Bmp.Canvas.Unlock;
  end;
end;

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, AvoidWnd: HWND; R: TRect): Boolean;
var
  WndBak,
  Sibling: hWnd;
  R2,
  R3: TRect;
begin
  // Check if the rect is contained in the window (self-clipping)
  GetWindowRect(Window, R2);
  IntersectRect(R3, R, R2);
  Result := not EqualRect(R, R3);

  if(not Result) and (Window <> 0) then
  begin
    // Check if clipped by the screen
    {$ifdef D6UP}
    R2 := Screen.DesktopRect;
    {$else}
    R2 := Bounds(Screen.DesktopLeft, Screen.DesktopTop, Screen.DesktopWidth,
            Screen.DesktopHeight);
    {$endif D6UP}

    IntersectRect(R3, R, R2);
    Result := not EqualRect(R, R3);

    WndBak := Window;
    while(not Result) and (Window <> 0) do
    begin
      // Check if covered by siblings 'over' in the z-order
      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 then
        begin
          if(GetWindowLong(Window, GWL_STYLE) and WS_CHILD) <> 0
          then
          begin
            if Window <> AvoidWnd then
            begin
              // Check if clipped by this parent window
              GetWindowRect(Window, R2);
              IntersectRect(R3, R, R2);
              Result := not EqualRect(R, R3);
            end;
          end
          else
          begin
            // Check if covered by top level windows 'over' in the z-order
            Window := WndBak;
            while(Window <> 0) and not Result do
            begin
              Window := GetWindow(Window, GW_HWNDPREV);
              if(Window <> 0)           and
                IsWindowVisible(Window) and
                (Window <> AvoidWnd)    and
                (not IsIconic(Window))  then
              begin
                GetWindowRect(Window, R2);
                Result := IntersectRect(R3, R, R2);
              end;
            end;
          end;
        end;
      end;
    end;
  end;
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;
var
  i: integer;
  Palette,
  OldPalette: HPalette;
  WindowHandle: HWnd;
  DC: HDC;
begin
  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);
    try
      OldPalette := SelectPalette(DC, Palette, ForceBackground);
      RealizePalette(DC);
      SelectPalette(DC, OldPalette, True);
      ForceBackground := True;
    finally
      ReleaseDC(WindowHandle, DC);
    end;
  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;
end;