Wednesday, January 26, 2011

Fun with DWM


Sooo... you like the "Peak preview" of Windows 7?! If so, then I bet you would want to play with it in your Delphi application, correct?! cool! here's how you do it in a few steps:

a) create a new VCL forms application;
b) add Dwmapi to uses clause;
c) copy and paste and paste from the following code;

unit Unit1;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Variants,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  Dwmapi,
  StdCtrls,
  ExtCtrls,
  Generics.Collections;

type
  TDGWindow = record
    StrCaption: string;
    StrClassName: string;
    Handle: HWND;
  end;

  TDGWindowList = class(TList);

type
  TfrmMain = class(TForm)
    Panel1: TPanel;
    lbWindows: TListBox;
    bnRefresh: TButton;
    bnPreview: TButton;
    procedure FormDestroy(Sender: TObject);
    procedure bnRefreshClick(Sender: TObject);
    procedure bnPreviewClick(Sender: TObject);
    procedure lbWindowsDblClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
  private
    FWindowList: TDGWindowList;
    FTumbnail: HTHUMBNAIL;
    FPreviewEnabled: Boolean;
  private
    procedure PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);
    procedure PreviewDisable;
  public
    { Public declarations }
  end;

var
  frmMain: TfrmMain;

implementation

{$R *.dfm}

function FindWindowExtd(partialTitle: string): HWND;
var
  hWndTemp: hWnd;
  iLenText: Integer;
  cTitletemp: array [0..254] of Char;
  sTitleTemp: string;
begin
  hWndTemp := FindWindow(nil, nil);
  while hWndTemp <> 0 do begin
    iLenText := GetWindowText(hWndTemp, cTitletemp, 255);
    sTitleTemp := cTitletemp;
    sTitleTemp := UpperCase(copy( sTitleTemp, 1, iLenText));
    partialTitle := UpperCase(partialTitle);
    if pos( partialTitle, sTitleTemp ) <> 0 then
      Break;
    hWndTemp := GetWindow(hWndTemp, GW_HWNDNEXT);
  end;
  result := hWndTemp;
end;

procedure TfrmMain.bnPreviewClick(Sender: TObject);
var
  Index: Integer;
  LRect: TRect;
begin
  Index := lbWindows.ItemIndex;
  if Index < 0 then
    Exit;
  LRect := Rect(5, 5,
    Self.Width -Panel1.Width -20,
    Self.Height -10);
  PreviewWindow(
    FWindowList[Index].Handle,
    Self.Handle,
    LRect);
end;

procedure TfrmMain.bnRefreshClick(Sender: TObject);
var
  LHDesktop: HWND;
  LHWindow: HWND;
  LHParent: HWND;
  LExStyle: DWORD;
  LBuffer: array[0..255] of char;
  LWindow: TDGWindow;
begin
  lbWindows.Items.BeginUpdate;
  lbWindows.Items.Clear;
  FWindowList.Clear;
  LHDesktop := GetDeskTopWindow;
  LHWindow := GetWindow(LHDesktop, GW_CHILD);
  while LHWindow <> 0 do begin
    LWindow.Handle := LHWindow;
    GetWindowText(LHWindow, LBuffer, Length(LBuffer));
    LHParent := GetWindowLong(LHWindow, GWL_HWNDPARENT);
    LExStyle := GetWindowLong(LHWindow, GWL_EXSTYLE);
    if IsWindowVisible(LHWindow) and (LBuffer <> EmptyStr) and
        ((LHParent = 0) or (LHParent = LHDesktop)) and
        ((LExStyle and WS_EX_TOOLWINDOW = 0) or (LExStyle and WS_EX_APPWINDOW <> 0))
        then begin
      lbWindows.Items.Add(LBuffer);
      LWindow.StrCaption := LBuffer;
      GetClassName(LHWindow, LBuffer, Length(LBuffer));
      LWindow.StrClassName := LBuffer;
      FWindowList.Add(LWindow);
    end; // if IsWindowVisible(LHWindow) and (LBuffer <> EmptyStr) and ...
    LHWindow := GetWindow(LHWindow, GW_HWNDNEXT);
  end; // while LHWindow <> 0 do begin
  lbWindows.Items.EndUpdate;
  if lbWindows.Items.Count > 0 then
    lbWindows.ItemIndex := 0;
end;

procedure TfrmMain.FormCreate(Sender: TObject);
begin
  FPreviewEnabled := False;
  FWindowList := TDGWindowList.Create;
end;

procedure TfrmMain.FormDestroy(Sender: TObject);
begin
  FWindowList.Clear;
  FreeAndNil(FWindowList);
  PreviewDisable;
end;

procedure TfrmMain.lbWindowsDblClick(Sender: TObject);
begin
  bnPreview.Click;
end;

procedure TfrmMain.PreviewDisable;
begin
  if FPreviewEnabled then
    FPreviewEnabled := NOT Succeeded(DwmUnregisterThumbnail(FTumbnail));
end;

procedure TfrmMain.PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);
var
  LResult: HRESULT;
  LThumpProp: DWM_THUMBNAIL_PROPERTIES;
begin
  if NOT DwmCompositionEnabled then begin
    MessageDlg('DWM composition is NOT enabled.', mtWarning, [mbOK], 0);
    Exit;
  end; // if NOT DwmCompositionEnabled then begin
  PreviewDisable;
  FPreviewEnabled := Succeeded(DwmRegisterThumbnail(ADest, ASource, @FTumbnail));
  if FPreviewEnabled then begin
    LThumpProp.dwFlags := DWM_TNP_SOURCECLIENTAREAONLY or DWM_TNP_VISIBLE or
      DWM_TNP_OPACITY or DWM_TNP_RECTDESTINATION;
    LThumpProp.fSourceClientAreaOnly := False;
    LThumpProp.fVisible := True;
    LThumpProp.opacity := 200;
    LThumpProp.rcDestination := ARect;
    LResult := DwmUpdateThumbnailProperties(FTumbnail, LThumpProp);
    FPreviewEnabled := (LResult = S_OK);
  end else
    MessageDlg('Cannot link to window  ' + IntToStr(ASource), mtError, [mbOK], 0);
end;

end.
or you simply download the demo application.
d) have fun!!

No comments:

Post a Comment

Blogroll(General programming and Delphi feeds)