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!!

uDGVMUtils version 1.1 thanks to Chee Meng

Thanks to Chee Meng I've added a detection scheme for Virtual Box.
Please let me know of any scenario in which a function fails to return properly so that I can modify the code.

unit uDGVMUtils;

interface

(*******************************************************************************

  uDGVMUtils -- is an attempt to create one of the best virtual machine
    detector methods, feel free to contribute in any way you wish.

  Version 1.1, 2010-01-15

  Copyright© you are free to use it for comercial, private or both purposes

  Contributors:
    Dorin Duminica
    Chee Meng

*******************************************************************************)

type
  TVMWareVersion = (
    vvExpress = 1,
    vvESX,
    vvGSX,
    vvWorkstation,
    vvUnknown,
    vvNative);

const
  VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (
    'Express',
    'ESX',
    'GSX',
    'Workstation',
    'Unknown',
    'Native');

type
  TVirtualMachineType = (
    vmNative,
    vmVMWare,
    vmWine,
    vmVirtualPC,
    vmVirtualBox);

const
  VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (
    'Native',
    'VMWare',
    'Wine',
    'Virtual PC',
    'Virtual Box');

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;
function IsRunningVMWare: Boolean; overload;
function IsRunningWine(var AWineVersion: string): Boolean; overload;
function IsRunningWine: Boolean; overload;
function IsRunningVirtualPC: Boolean;
function IsRunningVBox: Boolean;
function IsRunningVM(var AVMVersion: string): Boolean; overload;
function IsRunningVM: Boolean; overload;

implementation

uses
  SysUtils,
  Windows;

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;
const
  CVMWARE_FLAG = $564D5868;
var
  LFlag: Cardinal;
  LVersion: Cardinal;
begin
  LFlag := 0;
  try
    asm
      push eax
      push ebx
      push ecx
      push edx

      mov eax, 'VMXh'
      mov ecx, 0Ah
      mov dx, 'VX'

      in eax, dx

      mov LFlag, ebx
      mov LVersion, ecx

      pop edx
      pop ecx
      pop ebx
      pop eax
    end;
  except
//  uncomment next two lines if you wish to see exception
//    on E: Exception do
//      ShowMessage(E.message);
  end; // trye
  if LFlag = CVMWARE_FLAG then begin
    Result := True;
    case LVersion of
      1: AVMWareVersion := vvExpress;
      2: AVMWareVersion := vvESX;
      3: AVMWareVersion := vvGSX;
      4: AVMWareVersion := vvWorkstation;
      else
        AVMWareVersion := vvUnknown;
    end
  end else begin
    Result := False;
    AVMWareVersion := vvNative;
  end; // if LFlag = CVMWARE_FLAG then begin
end;

function IsRunningVMWare: Boolean;
var
  LVMWareVersion: TVMWareVersion;
begin
  Result := IsRunningVMWare(LVMWareVersion);
end;

function IsRunningWine(var AWineVersion: string): Boolean;
type
  TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}
  TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}
var
  LHandle: THandle;
  LWineGetVersion: TWineGetVersion;
  LWineNTToUnixFileName: TWineNTToUnixFileName;
begin
  Result := False;
  AWineVersion := 'Unknown';
  LHandle := LoadLibrary('ntdll.dll');
  if LHandle > 32 then begin
    LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');
    LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');
    if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin
      Result := True;
      if Assigned(LWineGetVersion) then
        AWineVersion := StrPas(LWineGetVersion);
    end; // if Assigned(LWineGetVersion) or ...
    FreeLibrary(LHandle);
  end; // if LHandle > 32 then begin
end;

function IsRunningWine: Boolean;
var
  LWineVersion: string;
begin
  Result := IsRunningWine(LWineVersion);
end;

function IsRunningVirtualPC: Boolean;
asm
  push ebp;
  mov ebp, esp;

  mov ecx, offset @exception_handler;

  push ebx;
  push ecx;

  push dword ptr fs:[0];
  mov dword ptr fs:[0], esp;

  mov ebx, 0; // Flag
  mov eax, 1; // VPC function number

  // call VPC
  db $0F, $3F, $07, $0B

  mov eax, dword ptr ss:[esp];
  mov dword ptr fs:[0], eax;

  add esp, 8;

  test ebx, ebx;

  setz al;

  lea esp, dword ptr ss:[ebp-4];
  mov ebx, dword ptr ss:[esp];
  mov ebp, dword ptr ss:[esp+4];

  add esp, 8;

  jmp @ret1;

  @exception_handler:
  mov ecx, [esp+0Ch];
  mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running
  add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC
  xor eax, eax; // exception is handled

  @ret1:
end;

function IsRunningVBox: Boolean;

  function Test1: Boolean;
  var
    LHandle: Cardinal;
  begin
    Result := False;
    try
      LHandle := LoadLibrary('VBoxHook.dll');
      Result := (LHandle <> 0);
      if Result then
        FreeLibrary(LHandle);
    except
    end; // trye
  end; // function Test1: Boolean;

  function Test2: Boolean;
  var
    LHandle: Cardinal;
  begin
    Result := False;
    try
      LHandle := CreateFile(
        '\\\\.\\\VBoxMiniRdrDN',
        GENERIC_READ,
        FILE_SHARE_READ,
        NIL,
        OPEN_EXISTING,
        FILE_ATTRIBUTE_NORMAL,
        0);
      Result := (LHandle <> INVALID_HANDLE_VALUE);
      if Result then
        CloseHandle(LHandle);
    except
    end; // trye
  end; // function Test2: Boolean;

begin
  Result := Test1 or Test2;
end;

function IsRunningVM(var AVMVersion: string): Boolean;
begin
  AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
  Result := True;
  if IsRunningWine then
    AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
  else
    if IsRunningVMWare then
      AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]
    else
      if IsRunningVirtualPC then
        AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
      else
        if IsRunningVBox then
          AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualBox]
        else begin
          AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
          Result := False;
        end;
end;

function IsRunningVM: Boolean;
var
  LVMVersion: string;
begin
  Result := IsRunningVM(LVMVersion);
end;

end.

HAVE FUN

Is your app running in a virtual machine?

Here's an extremely simple unit that will check if your application is running under VMWare, Wine and or Virtual PC:

unit uDGVMUtils;

interface

type
  TVMWareVersion = (
    vvExpress = 1,
    vvESX,
    vvGSX,
    vvWorkstation,
    vvUnknown,
    vvNative);

const
  VMWARE_VERSION_STRINGS: array [TVMWareVersion] of string = (
    'Express',
    'ESX',
    'GSX',
    'Workstation',
    'Unknown',
    'Native');

type
  TVirtualMachineType = (
    vmNative,
    vmVMWare,
    vmWine,
    vmVirtualPC);

const
  VIRTUALMACHINE_STRINGS: array[TVirtualMachineType] of string = (
    'Native',
    'VMWare',
    'Wine',
    'Virtual PC');

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean; overload;
function IsRunningVMWare: Boolean; overload;
function IsRunningWine(var AWineVersion: string): Boolean; overload;
function IsRunningWine: Boolean; overload;
function IsRunningVirtualPC: Boolean;
function IsRunningVM(var AVMVersion: string): Boolean; overload;
function IsRunningVM: Boolean; overload;

implementation

uses
  SysUtils,
  Windows;

function IsRunningVMWare(var AVMWareVersion: TVMWareVersion): Boolean;
const
  CVMWARE_FLAG = $564D5868;
var
  LFlag: Cardinal;
  LVersion: Cardinal;
begin
  LFlag := 0;
  try
    asm
      push eax
      push ebx
      push ecx
      push edx

      mov eax, 'VMXh'
      mov ecx, 0Ah
      mov dx, 'VX'

      in eax, dx

      mov LFlag, ebx
      mov LVersion, ecx

      pop edx
      pop ecx
      pop ebx
      pop eax
    end;
  except
//  uncomment next two lines if you wish to see exception
//    on E: Exception do
//      ShowMessage(E.message);
  end; // trye
  if LFlag = CVMWARE_FLAG then begin
    Result := True;
    case LVersion of
      1: AVMWareVersion := vvExpress;
      2: AVMWareVersion := vvESX;
      3: AVMWareVersion := vvGSX;
      4: AVMWareVersion := vvWorkstation;
      else
        AVMWareVersion := vvUnknown;
    end
  end else begin
    Result := False;
    AVMWareVersion := vvNative;
  end; // if LFlag = CVMWARE_FLAG then begin
end;

function IsRunningVMWare: Boolean;
var
  LVMWareVersion: TVMWareVersion;
begin
  Result := IsRunningVMWare(LVMWareVersion);
end;

function IsRunningWine(var AWineVersion: string): Boolean;
type
  TWineGetVersion = function: PAnsiChar;{$IFDEF Win32}stdcall;{$ENDIF}
  TWineNTToUnixFileName = procedure (P1: Pointer; P2: Pointer);{$IFDEF Win32}stdcall;{$ENDIF}
var
  LHandle: THandle;
  LWineGetVersion: TWineGetVersion;
  LWineNTToUnixFileName: TWineNTToUnixFileName;
begin
  Result := False;
  AWineVersion := 'Unknown';
  LHandle := LoadLibrary('ntdll.dll');
  if LHandle > 32 then begin
    LWineGetVersion := GetProcAddress(LHandle, 'wine_get_version');
    LWineNTToUnixFileName := GetProcAddress(LHandle, 'wine_nt_to_unix_file_name');
    if Assigned(LWineGetVersion) or Assigned(LWineNTToUnixFileName) then begin
      Result := True;
      if Assigned(LWineGetVersion) then
        AWineVersion := StrPas(LWineGetVersion);
    end; // if Assigned(LWineGetVersion) or ...
    FreeLibrary(LHandle);
  end; // if LHandle > 32 then begin
end;

function IsRunningWine: Boolean;
var
  LWineVersion: string;
begin
  Result := IsRunningWine(LWineVersion);
end;

function IsRunningVirtualPC: Boolean;
asm
  push ebp;
  mov ebp, esp;

  mov ecx, offset @exception_handler;

  push ebx;
  push ecx;

  push dword ptr fs:[0];
  mov dword ptr fs:[0], esp;

  mov ebx, 0; // Flag
  mov eax, 1; // VPC function number

  // call VPC
  db $0F, $3F, $07, $0B

  mov eax, dword ptr ss:[esp];
  mov dword ptr fs:[0], eax;

  add esp, 8;

  test ebx, ebx;

  setz al;

  lea esp, dword ptr ss:[ebp-4];
  mov ebx, dword ptr ss:[esp];
  mov ebp, dword ptr ss:[esp+4];

  add esp, 8;

  jmp @ret1;

  @exception_handler:
  mov ecx, [esp+0Ch];
  mov dword ptr [ecx+0A4h], -1; // EBX = -1 ->; not running, ebx = 0 -> running
  add dword ptr [ecx+0B8h], 4; // ->; skip past the call to VPC
  xor eax, eax; // exception is handled

  @ret1:
end;

function IsRunningVM(var AVMVersion: string): Boolean;
begin
  AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];
  Result := True;
  if IsRunningWine then
    AVMVersion := VIRTUALMACHINE_STRINGS[vmWine]
  else
    if IsRunningVMWare then
      AVMVersion := VIRTUALMACHINE_STRINGS[vmVMWare]
    else
      if IsRunningVirtualPC then
        AVMVersion := VIRTUALMACHINE_STRINGS[vmVirtualPC]
      else begin
        AVMVersion := VIRTUALMACHINE_STRINGS[vmNative];        
        Result := False;
      end;
end;

function IsRunningVM: Boolean;
var
  LVMVersion: string;
begin
  Result := IsRunningVM(LVMVersion);
end;

end.

usage:
add uDGVMUtils to uses clause and:
// check if running in a virtual machine
var
LVMVersion: string;
begin
ShowMessageFmt('%s, VM name: %s', [BoolToStr(IsRunningVM(LVMVersion), True), LVMVersion]);
end;

// check if running in wine
var
LWine: Boolean;
LWineVersion: string;
begin
ShowMessageFmt('Wine: %s, Wine ver.: %s', [BoolToStr(IsRunningWine(LWineVersion), True), LWineVersion]);
end;

you get the picture, have fun!!

Client activity information in PostgreSQL

In most of my projects I use PostgreSQL as database, I'm sure that if you see what you get for free, most of you will turn to it, anyhu' this post is about getting information from database, such as:
- databases to which has connections to it;
- current queries ran on X database and the timestamp when the query was started;
- ID's of processes;
- user name of connected clients;
- port on which each client is connected;
- client IP address;
- based upon above information we can get more special info regarding active connections;

In order to see all of the above, run this query on the database:

SELECT * FROM PG_STAT_ACTIVITY;

The reason I was interested in this kind of information is that from time to time the database structure changes, therefore I need to run queries on previous database structures in order to fulfill latest needs, sooo... in order to upgrade the database I require that NO one else besides my "upgrade" application is connected to the database, therefore I run the following query in order to see to how many connections I have to X database, if the number of connections is greater than 1(if I'm connected to the database, I will be counted as well) then the application will wait until the number of connections to X database reaches 1 and then run the update queries, the query that I'm using is:

SELECT DATNAME AS "Database", COUNT(*) AS "ConnectionCount" FROM PG_STAT_ACTIVITY GROUP BY "Database";

and this will result in showing:

Database	ConnectionCount
X db	2
Y db	70
etc.

Well that's about all that I wanted to point out for now, do you have any special queries you run on a PostgreSQL database and want to share? comment bellow and I will put above this final thought like:
Name:
SQL QUERY

Happy new year!!

I wish you all a happy new year!!
Saale Nao Mubbarak
Gelukkige nuwe jaar
Gezuar Vitin e Ri
Snorhavor Nor Tari
Kul 'am wa antum bikhair
Sheta Brikhta
Yeni Iliniz Mubarek!
Noki saal mubarrak bibi
Shuvo Nabo Barsho
Bloavezh Mat
×åñòèòà Íîâà Ãîäèíà
Soursdey Chhnam Tmei
FELIÇ ANY NOU
Nuo bazzor bekkunore
Xin Nian Kuai Le
Pace e Salute
Sretna Nova godina!
Blwyddyn Newydd Dda
Šťastný Nový rok
Godt Nytår
Ufaaveri Aa Aharakah Edhen
GELUKKIG NIEUWJAAR!
Kiortame pivdluaritlo
Felican Novan Jaron
Head uut aastat!
MELKAM ADDIS AMET YIHUNELIWO!
RUHUS HADUSH AMET
Onnellista Uutta Vuotta
Bonne Annee
Bliadhna mhath ur
Bo Nadal e Feliz Aninovo
Prosit Neujahr
GILOTSAVT AKHAL TSELS!
Kenourios Chronos
Nutan Varshbhinandan
Hauoli Makahiki Hou
L'Shannah Tovah
Naye Varsha Ki Shubhkamanyen
Sun Leen Fai Lok
Boldog Új Évet Kivánok
Selamat Tahun Baru
Sal -e- no mobarak
Sanah Jadidah
Bliain nua fe mhaise dhuit
Felice anno nuovo
Akimashite Omedetto Gozaimasu
Asegwas Amegaz
Hosa Varushadha Shubhashayagalu
SOMWAKA OMOYIA OMUYA
Snem Thymmai Basuk Iaphi
Sua Sdei tfnam tmei
Saehae Bock Mani ba deu sei yo!
NEWROZ PIROZBE
Laimīgo Jauno Gadu!
Laimingu Naujuju Metu
Sabai dee pee mai
Srekjna Nova Godina
Tratry ny taona
Selamat Tahun Baru
Nveen Varshachy Shubhechcha
Puthuvatsara Aashamsakal
Kum Thar Chibai
Is-Sena t-Tajba
Nawa Barsha ko Shuvakamana
Godt Nyttår
Nua Barshara Subhechha
Nupela yia i go long yu
Masaganang Bayung Banua
Nawai Kall Mo Mubarak Shah
Sal -e- no mobarak
Manigong Bagong Taon!
Szczesliwego Nowego Roku
Feliz Ano Novo
Nave sal di mubarak
AN NOU FERICIT
S Novim Godom
Manuia le Tausaga Fou
Sretna nova godina
Nayou Saal Mubbarak Hoje
Subha Aluth Awrudhak Vewa
Nawan Saal Shala Mubarak Theevay
Stastny Novy rok
sreèno novo leto
Iyo Sanad Cusub Oo Fiican!
Feliz Ano ~Nuevo
Heri Za Mwaka Mpyaº
GOTT NYTT ÅR!
Warsa Enggal
Eniya Puthandu Nalvazhthukkal
Losar Tashi Delek
Noothana samvatsara shubhakankshalu
Sawadee Pee Mai
Yeni Yiliniz Kutlu Olsun
Shchastlyvoho Novoho Roku
Naya Saal Mubbarak Ho
Yangi Yil Bilan
Chuc Mung Tan Nien
Blwyddyn Newydd Dda!