コンソールアプリケーションでグラスエフェクトを有効にする

Stack Overflowに

How can activate a glass effect (windows Vista/7) in a console application using Delphi - Stack Overflow

というアーティクルがありました。RRUZ(Rodrigo Ruz)さんによる回答はGetConsoleWindowで取得したコンソールウィンドウにDWMのDwmEnableBlurBehindWindowでblur(グラスエフェクト)をかける、というものです。しかしこのコンソールアプリケーションはそのままではWindows 2000/XPで動作しません。そこでDwmEnableBlurBehindWindowを動的にリンクするように手を加えてみました。DWM_BLURBEHIND構造体および定数DWM_BB_...の定義はDelphi 2007のDwmAPI.pasから借りてきました。

program Project1;

{$APPTYPE CONSOLE}

uses
  Windows,
  SysUtils;

type
  {$EXTERNALSYM PDWM_BLURBEHIND}
  PDWM_BLURBEHIND = ^DWM_BLURBEHIND;
  {$EXTERNALSYM DWM_BLURBEHIND}
  DWM_BLURBEHIND = record
    dwFlags: DWORD;
    fEnable: BOOL;
    hRgnBlur: HRGN;
    fTransitionOnMaximized: BOOL;
  end;

  TDwmEnableBlurBehindWindow = function (hWnd: HWND;
                                         pBlurBehind: PDWM_BLURBEHIND): HResult; stdcall;

const
  DWMAPI = 'DWMAPI.DLL';

  {$EXTERNALSYM DWM_BB_ENABLE}
  DWM_BB_ENABLE                 = $00000001;  // fEnable has been specified
  {$EXTERNALSYM DWM_BB_BLURREGION}
  DWM_BB_BLURREGION             = $00000002;  // hRgnBlur has been specified
  {$EXTERNALSYM DWM_BB_TRANSITIONONMAXIMIZED}
  DWM_BB_TRANSITIONONMAXIMIZED  = $00000004;  // fTransitionOnMaximized has been specified


function GetConsoleWindow: HWND; stdcall; external kernel32 name 'GetConsoleWindow';


var
  hDWMAPI: HMODULE;
  BB: DWM_BLURBEHIND;
  DwmEnableBlurBehindWindow: TDwmEnableBlurBehindWindow;
begin

  try
    hDWMAPI := 0;
    try
      if Win32MajorVersion >= 6 then
      begin
        hDWMAPI := LoadLibrary(DWMAPI);
        if hDWMAPI > 0 then
        begin
          @DwmEnableBlurBehindWindow := GetProcAddress(hDWMAPI,
                                                       'DwmEnableBlurBehindWindow');
          if Assigned(DwmEnableBlurBehindWindow) then
          begin
            BB.dwFlags := DWM_BB_ENABLE;
            BB.fEnable := True;
            BB.hRgnBlur := 0;
            BB.fTransitionOnMaximized := False;
            DwmEnableBlurBehindWindow(GetConsoleWindow,@BB);
          end;
        end;
      end;

      Writeln('Hit enter key');
      Readln;

    finally
      if hDWMAPI > 0 then
      begin
        FreeLibrary(hDWMAPI);
      end;
    end;

  except
    on E:Exception do
      Writeln(E.Classname, ': ', E.Message);
  end;

end.

Object Pascal

2010/11/04追記: DWMAPI.DLLがKnownDLLsではない環境(Windows 2000/XP)でバイナリ(DLL)プランティングの影響を受ける可能性があったので、LoadLibrary(PChar('DWMAPI.DLL'))を行う条件としてWin32MajorVersionが6以上(Windows Vista以降)という条件を追加しました。なおDelphi(2007以降)はDWMAPI.DLLを動的にLoadLibraryする条件としてWin32MajorVersionが6以上という検査を行うようになっており、通常の使用ではDWMAPI.DLL(の不存在)を利用したバイナリプランティングは成立しません。