// Способ первый
uses
  {...,} jpeg;

procedure DrawCursor(Bmp: TBitmap);
var
  r: TRect;
  CI: TCursorInfo;
  Icon: TIcon;
  II: TIconInfo;
begin
  r := Bmp.Canvas.ClipRect;
  Icon := TIcon.Create;
  try
    CI.cbSize := SizeOf(CI);
    if GetCursorInfo(CI) then
      if CI.Flags = CURSOR_SHOWING then
      begin
        Icon.Handle := CopyIcon(CI.hCursor);
        if GetIconInfo(Icon.Handle, II) then
        begin
          Bmp.Canvas.Draw(ci.ptScreenPos.x - Integer(II.xHotspot) - r.Left,
                          ci.ptScreenPos.y - Integer(II.yHotspot) - r.Top, Icon);
        end;
      end;
  finally
    Icon.Free;
  end;
end;

procedure SaveScreenToFile(FileName: string);
var
  Bmp: TBitmap;
  Jpg: TJpegImage;
begin
  Bmp := TBitmap.Create;
  Jpg := TJpegImage.Create;
  try
    Bmp.Width := GetSystemMetrics(SM_CXSCREEN);
    Bmp.Height := GetSystemMetrics(SM_CYSCREEN);
    BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, GetDc(0), 0, 0, SRCCOPY);
    DrawCursor(Bmp);
    Jpg.Assign(Bmp);
    Jpg.CompressionQuality := 60;
    Jpg.Compress;
    Jpg.SaveToFile(FileName);
  finally
    Bmp.free;
    Jpg.free;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  SaveScreenToFile('c:\shot.jpg');
end;

// Способ второй
// Get the handle to the current mouse-cursor and its position
function GetCursorInfo2: TCursorInfo;
var
  hWindow: HWND;
  pt: TPoint;
  pIconInfo: TIconInfo;
  dwThreadID, dwCurrentThreadID: DWORD;
begin
  Result.hCursor := 0;
  ZeroMemory(@Result, SizeOf(Result));
  // Find out which window owns the cursor
  if GetCursorPos(pt) then
  begin
     Result.ptScreenPos := pt;
     hWindow := WindowFromPoint(pt);
     if IsWindow(hWindow) then
     begin
       // Get the thread ID for the cursor owner.
       dwThreadID := GetWindowThreadProcessId(hWindow, nil);

       // Get the thread ID for the current thread
       dwCurrentThreadID := GetCurrentThreadId;

       // If the cursor owner is not us then we must attach to
       // the other thread in so that we can use GetCursor to
       // return the correct hCursor
       if dwCurrentThreadID <> dwThreadID then
       begin
         if AttachThreadInput(dwCurrentThreadID, dwThreadID, True) then
         begin
           // Get the handle to the cursor
           Result.hCursor := GetCursor;
           AttachThreadInput(dwCurrentThreadID, dwThreadID, False);
         end;
       end
       else
         Result.hCursor := GetCursor;
     end;
  end;
end;

// Capture the screen
function CaptureScreen: TBitmap;
var
  DC: HDC;
  ABitmap: TBitmap;
  MyCursor: TIcon;
  CursorInfo: TCursorInfo;
  IconInfo: TIconInfo;
begin
  // Capture the Desktop screen
  DC := GetDC(GetDesktopWindow);
  ABitmap := TBitmap.Create;

  try
    ABitmap.Width  := GetDeviceCaps(DC, HORZRES);
    ABitmap.Height := GetDeviceCaps(DC, VERTRES);

    // BitBlt on our bitmap
    BitBlt(ABitmap.Canvas.Handle, 0, 0, ABitmap.Width, ABitmap.Height,
           DC, 0, 0, SRCCOPY);
    // Create temp. Icon
    MyCursor := TIcon.Create;
    try
      // Retrieve Cursor info
      CursorInfo := GetCursorInfo2;
      if CursorInfo.hCursor <> 0 then
      begin
        MyCursor.Handle := CursorInfo.hCursor;
        // Get Hotspot information
        GetIconInfo(CursorInfo.hCursor, IconInfo);
        // Draw the Cursor on our bitmap
        ABitmap.Canvas.Draw(CursorInfo.ptScreenPos.X - IconInfo.xHotspot,
                            CursorInfo.ptScreenPos.Y - IconInfo.yHotspot, MyCursor);
      end;
    finally
      // Clean up
      MyCursor.ReleaseHandle;
      MyCursor.Free;
    end;
  finally
    ReleaseDC(GetDesktopWindow, DC);
  end;

  Result := ABitmap;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  CaptureScreen.SaveToFile('c:\shot.bmp');
end;

// Способ третий
function MakeScreenshot(Bmp: TBitmap; ActiveWindowOnly: Boolean;
  CaptureCursor: Boolean = True): Boolean;
var
  DC: HDC;
  ACursor: HICON;
  Pt: TPoint;
  CurInfo: tagCURSORINFO;
  IcoInfo: _ICONINFO;
  Wnd: THandle;
  ARect: TRect;
begin
  Result := False;
  if ActiveWindowOnly then
    Wnd := GetForegroundWindow
  else
    Wnd := GetDesktopWindow;
  if Wnd = 0 then
    Exit;

  GetWindowRect(Wnd, ARect);
  Bmp.Width := ARect.Right - ARect.Left;
  Bmp.Height := ARect.Bottom - ARect.Top;
  // Для корректного получения скриншота активного окна
  // (ActiveWindowOnly = True)
  Bmp.PixelFormat := pf24bit;

  DC := GetWindowDC(Wnd);
  try
    BitBlt(Bmp.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, DC, 0, 0, SRCCOPY);
    // -- курсор
    if CaptureCursor then
    begin
      CurInfo.cbSize := SizeOf(CurInfo);
      GetCursorInfo(CurInfo);

      ACursor := CurInfo.hCursor;
      Pt := CurInfo.ptScreenPos;

      GetIconInfo(ACursor, IcoInfo);

      DrawIcon(Bmp.Canvas.Handle, Pt.X - Integer(IcoInfo.xHotspot),
               Pt.Y - Integer(IcoInfo.yHotspot), ACursor);
    end;
  finally
    ReleaseDC(Wnd, DC);
  end;
  Result := True;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Bmp: TBitmap;
begin
  Bmp := TBitmap.Create;
  try
    MakeScreenshot(Bmp, True, True);
    Bmp.SaveToFile('c:\shot.bmp');
  finally
    Bmp.Free;
  end;
end;

// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  hwndShell: HWND;
begin
  hwndShell := FindWindow('Progman', nil);
  // или
  // hwndShell := FindWindow('Progman', 'Program Manager');
end;

// Способ второй
function ShellWindow: HWND;
type
  TGetShellWindow = function(): HWND; stdcall;
var
  hUser32: THandle;
  GetShellWindow: TGetShellWindow;
begin
  Result := 0;
  hUser32 := GetModuleHandle('user32.dll');
  if hUser32 > 0 then
  begin
    @GetShellWindow := GetProcAddress(hUser32, 'GetShellWindow');
    if Assigned(GetShellWindow) then
      Result := GetShellWindow;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  hwndShell: HWND;
begin
  hwndShell := ShellWindow;
end;

// Способ первый
// Вариант для Windows 2000/XP
uses
  {...,} ActiveX, ShlObj;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  Taskbar: ITaskbarList;
  ShellWnd, WorkerID: HWND;
  aName: array[0..255] of Char;
begin
  GetClassName(GetForegroundWindow, aName, 256);
  if aName = 'WorkerW' then
  begin
    ShellWnd := GetWindowThreadProcessId(FindWindow('Progman', nil));
    WorkerID := GetWindowThreadProcessId(GetForegroundWindow);
    if WorkerID = ShellWnd then
    begin
      CoCreateInstance(CLSID_TaskBarList, nil, CLSCTX_ALL, IID_ITaskBarList, Taskbar);
      Taskbar.HrInit;
      // Taskbar.AddTab(Handle);
      Taskbar.ActivateTab(Handle);
      // Taskbar.DeleteTab(Handle);
      SetForegroundWindow(Handle);
      ShowWindow(Handle, SW_SHOWNORMAL);
      Taskbar := nil;
    end;
  end;
end;
// Этот вариант подойдет и для Windows Vista и старше, но выглядеть
// будет не совсем так, как хотелось бы...
// Окно будет разворачивать из панели задач, так что лучше
// использовать другой вариант.

// Вариант для Windows Vista и старше
uses
  {...,} ShlObj, ComObj;

type
  TForm1 = class(TForm)
    {...}
    procedure CreateWnd; override;
    {...}
  end;

implementation

procedure TForm1.CreateWnd;
var
  Taskbar: ITaskbarList;
begin
  inherited;
  Taskbar := CreateComObject(CLSID_TaskbarList) as ITaskbarList;
  Taskbar.HrInit;
  Taskbar.DeleteTab(Handle);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var
  hw: HWND;
  ShellWnd, WorkerID: HWND;
  aName: array [0..255] of Char;
begin
  inherited;
  GetClassName(GetForegroundWindow, aName, 256);
  if aName = 'WorkerW' then
  begin
    ShellWnd := GetWindowThreadProcessId(FindWindow('Progman', nil));
    WorkerID := GetWindowThreadProcessId(GetForegroundWindow);
    if WorkerID = ShellWnd then
    begin
      hw := GetNextWindow(GetForegroundWindow, GW_HWNDPREV);
      SetWindowPos(Handle, hw, 0, 0, 0, 0, SWP_NOMOVE or SWP_NOSIZE);
    end;
  end;
end;

// Способ второй
// Выставить окну стиль WS_EX_TOOLWINDOW or WS_EX_TOPMOST,
// например в дизайнере:
// BorderStyle = bsToolWindow
// FormStyle = fsStayOnTop
// Работает как в Windows 2000/XP, иак и в Windows Vista и старше
type
  TForm1 = class(TForm)
    {...}
    procedure CreateWnd; override;
    {...}
  end;

procedure TForm1.CreateWnd;
begin
  inherited;
  BorderStyle := bsToolWindow;
  FormStyle := fsStayOnTop;
end;

function IsAeroEnabledCheck: Boolean;
type
  TDwmIsCompositionEnabledFunc = function(IsEnabled: PBool): HRESULT; stdcall;
var
  DllHandle: THandle;
  Flag: BOOL;
  DwmIsCompositionEnabledFunc: TDwmIsCompositionEnabledFunc;
begin
  Result := False;
  DllHandle := LoadLibrary('dwmapi.dll');
  if DllHandle <> 0 then
  try
    @DwmIsCompositionEnabledFunc := GetProcAddress(DllHandle, 'DwmIsCompositionEnabled');
    if Assigned(@DwmIsCompositionEnabledFunc) then
      if Succeeded(DwmIsCompositionEnabledFunc(@Flag)) then
        Result := Flag;
  finally
    FreeLibrary(DllHandle);
  end;
end;

// Или немного иначе
function IsAeroEnabled: Boolean;
type
  TDwmIsCompositionEnabledFunc = function(out pfEnabled: BOOL): HRESULT; stdcall;
var
  IsEnabled: BOOL;
  ModuleHandle: HMODULE;
  DwmIsCompositionEnabledFunc: TDwmIsCompositionEnabledFunc;
begin
  Result := False;
  if Win32MajorVersion >= 6 then // Vista or Windows 7+
  begin
    ModuleHandle := LoadLibrary('dwmapi.dll');
    if ModuleHandle <> 0 then
    try
      @DwmIsCompositionEnabledFunc := GetProcAddress(ModuleHandle, 'DwmIsCompositionEnabled');
      if Assigned(DwmIsCompositionEnabledFunc) then
        if DwmIsCompositionEnabledFunc(IsEnabled) = S_OK then
          Result := IsEnabled;
    finally
      FreeLibrary(ModuleHandle);
    end;
  end;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  if IsWindowUnicode(Handle) then
    ShowMessage('This window is a Unicode window')
  else
    ShowMessage('This window is not a Unicode window');
end;

// Способ первый
uses
  ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  sc: Variant;
  sr: OleVariant;
begin
  sc := CreateOLEObject('ScriptControl');
  try
    sc.Language := 'VBScript';
    sr := sc.Eval('getobject("winmgmts:\\.\root\default:Systemrestore")');
    // Параметры CreateRestorePoint:
    // [1] Description: String - описание точки восстановления
    // [2] RestorePointType: UInt32 (Cardinal) - тип точки восстановления
    //     • APPLICATION_INSTALL = 0
    //       An application has been installed.
    //     • APPLICATION_UNINSTALL = 1
    //       An application has been uninstalled.
    //     • DEVICE_DRIVER_INSTALL = 10
    //       A device driver has been installed.
    //     • MODIFY_SETTINGS = 12
    //       An application has had features added or removed.
    //     • CANCELLED_OPERATION = 13
    //        An application needs to delete the restore point it created.
    //        For example, an application would use this flag when a user cancels an installation.
    // EventType: UInt32 (Cardinal) - тип события
    //     • BEGIN_NESTED_SYSTEM_CHANGE = 102
    //       A system change has begun. A subsequent nested call does not create a new restore point.
    //       Subsequent calls must use END_NESTED_SYSTEM_CHANGE, not END_SYSTEM_CHANGE.
    //     • BEGIN_SYSTEM_CHANGE = 100
    //       A system change has begun.
    //       A subsequent call must use END_SYSTEM_CHANGE, not END_NESTED_SYSTEM_CHANGE.
    //     • END_NESTED_SYSTEM_CHANGE = 103
    //       A system change has ended.
    //     • END_SYSTEM_CHANGE = 101
    //       A system change has ended.
    // Return value: If the method succeeds, the return value is S_OK.
    if sr.CreateRestorePoint('Automatic Restore Point', 0, 100) = 0 then
      ShowMessage('New Restore Point successfully created.')
    else
      ShowMessage('Restore Point creation Failed!');
  finally
    sc := Unassigned;
  end;
end;

// Способ второй
// Translation from SRRestorePtAPI.h
const
  // Type of Event
  BEGIN_SYSTEM_CHANGE = 100;
  END_SYSTEM_CHANGE  = 101;
  // Type of Restore Points
  APPLICATION_INSTALL =  0;
  CANCELLED_OPERATION = 13;
  MAX_DESC = 64;
  MIN_EVENT = 100;

// Restore point information
type
  {$IFNDEF UNICODE}
  PRESTOREPTINFOA = ^_RESTOREPTINFOA;
  _RESTOREPTINFOA = packed record
  {$ELSE}
  PRESTOREPTINFOW = ^_RESTOREPTINFOW;
  _RESTOREPTINFOW = packed record
  {$ENDIF}
    dwEventType: DWORD;      // Type of Event - Begin or End
    dwRestorePtType: DWORD;  // Type of Restore Point - App install/uninstall
    llSequenceNumber: Int64; // Sequence Number - 0 for begin
    {$IFNDEF UNICODE}
    szDescription: array [0..MAX_DESC] of AnsiChar; // Description - Name of Application / Operation
    {$ELSE}
    szDescription: array [0..MAX_DESC] of WideChar; // Description - Name of Application / Operation
    {$ENDIF}
  end;
  {$IFNDEF UNICODE}
  RESTOREPOINTINFO = _RESTOREPTINFOA;
  PRESTOREPOINTINFOA = ^_RESTOREPTINFOA;
  {$ELSE}
  RESTOREPOINTINFO = _RESTOREPTINFOW;
  PRESTOREPOINTINFOW = ^_RESTOREPTINFOW;
  {$ENDIF}

  // Status returned by System Restore
  PSMGRSTATUS = ^_SMGRSTATUS;
  _SMGRSTATUS = packed record
    nStatus: DWORD;          // Status returned by State Manager Process
    llSequenceNumber: Int64; // Sequence Number for the restore point
  end;
  STATEMGRSTATUS = _SMGRSTATUS;
  PSTATEMGRSTATUS = ^_SMGRSTATUS;

  {$IFNDEF UNICODE}
  function SRSetRestorePointA(pRestorePtSpec: PRESTOREPOINTINFOA; pSMgrStatus: PSTATEMGRSTATUS): Bool;
    stdcall; external 'SrClient.dll' Name 'SRSetRestorePointA';
  {$ELSE}
  function SRSetRestorePointW(pRestorePtSpec: PRESTOREPOINTINFOW; pSMgrStatus: PSTATEMGRSTATUS): Bool;
    stdcall; external 'SrClient.dll' Name 'SRSetRestorePointW';
  {$ENDIF}

procedure TForm1.Button1Click(Sender: TObject);
const
  CR = #13#10;
var
  RestorePtSpec: RESTOREPOINTINFO;
  SMgrStatus: STATEMGRSTATUS;
begin
  // Initialize the RESTOREPOINTINFO structure
  RestorePtSpec.dwEventType := BEGIN_SYSTEM_CHANGE;
  RestorePtSpec.dwRestorePtType := APPLICATION_INSTALL;
  RestorePtSpec.llSequenceNumber := 0;
  RestorePtSpec.szDescription := 'SAMPLE RESTORE POINT';

  {$IFNDEF UNICODE}
  if SRSetRestorePointA( @RestorePtSpec, @SMgrStatus ) then
  {$ELSE}
  if SRSetRestorePointW( @RestorePtSpec, @SMgrStatus ) then
  {$ENDIF}
  begin
    ShowMessage('Restore point set. Restore point data:' + CR +
                'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR +
                'Status: ' + Format('%u', [SMgrStatus.nStatus]));

    // Restore Point Spec to cancel the previous restore point.
    RestorePtSpec.dwEventType := END_SYSTEM_CHANGE;
    RestorePtSpec.dwRestorePtType  := CANCELLED_OPERATION;
    RestorePtSpec.llSequenceNumber := SMgrStatus.llSequenceNumber;

    // This is the sequence number returned by the previous call.
    // Canceling the previous restore point
    {$IFNDEF UNICODE}
    if SRSetRestorePointA(@RestorePtSpec, @SMgrStatus) then
    {$ELSE}
    if SRSetRestorePointW(@RestorePtSpec, @SMgrStatus) then
    {$ENDIF}
      ShowMessage('Restore point canceled. Restore point data:' + CR +
                  'Sequence Number: ' + Format('%d', [SMgrStatus.llSequenceNumber]) + CR +
                  'Status: ' + Format('%u', [SMgrStatus.nStatus]))
    else
      ShowMessage('Couldn''t cancel restore point.');
    end
  else
    ShowMessage('Couldn''t set restore point.');
  end;
end.

// Если приложение запущено в режиме совместимости, то вызов GetVersionEx
// вернет фиктивную версию Windows, что, вероятно, не подойдет для системных
// программ типа твикеров ОС. Как быть в этом случае?

// Способ первый
// У каждого Windows-процесса есть структура описывающая его, называется она PEB.
// Она заполняется при старте процесса и содержит в себе адрес загрузки, список
// загруженных модулей, параметры командной строки, и, в том числе, версию Windows.
var
  // Реальная версия ОС, а не та что выдается системой
  // при запуске в режиме совместимости
  Win32MajorVersionReal: Integer;
  Win32MinorVersionReal: Integer;

type
  PPEB=^PEB;
  PEB = record
    InheritedAddressSpace: Boolean;
    ReadImageFileExecOptions: Boolean;
    BeingDebugged: Boolean;
    Spare: Boolean;
    Mutant: Cardinal;
    ImageBaseAddress: Pointer;
    LoaderData: Pointer;
    ProcessParameters: Pointer; // PRTL_USER_PROCESS_PARAMETERS;
    SubSystemData: Pointer;
    ProcessHeap: Pointer;
    FastPebLock: Pointer;
    FastPebLockRoutine: Pointer;
    FastPebUnlockRoutine: Pointer;
    EnvironmentUpdateCount: Cardinal;
    KernelCallbackTable: PPointer;
    EventLogSection: Pointer;
    EventLog: Pointer;
    FreeList: Pointer; // PPEB_FREE_BLOCK;
    TlsExpansionCounter: Cardinal;
    TlsBitmap: Pointer;
    TlsBitmapBits: array[0..1] of Cardinal;
    ReadOnlySharedMemoryBase: Pointer;
    ReadOnlySharedMemoryHeap: Pointer;
    ReadOnlyStaticServerData: PPointer;
    AnsiCodePageData: Pointer;
    OemCodePageData: Pointer;
    UnicodeCaseTableData: Pointer;
    NumberOfProcessors: Cardinal;
    NtGlobalFlag: Cardinal;
    Spare2: array[0..3] of Byte;
    CriticalSectionTimeout: LARGE_INTEGER;
    HeapSegmentReserve: Cardinal;
    HeapSegmentCommit: Cardinal;
    HeapDeCommitTotalFreeThreshold: Cardinal;
    HeapDeCommitFreeBlockThreshold: Cardinal;
    NumberOfHeaps: Cardinal;
    MaximumNumberOfHeaps: Cardinal;
    ProcessHeaps: Pointer;
    GdiSharedHandleTable: Pointer;
    ProcessStarterHelper: Pointer;
    GdiDCAttributeList: Pointer;
    LoaderLock: Pointer;
    OSMajorVersion: Cardinal;
    OSMinorVersion: Cardinal;
    OSBuildNumber: Cardinal;
    OSPlatformId: Cardinal;
    ImageSubSystem: Cardinal;
    ImageSubSystemMajorVersion: Cardinal;
    ImageSubSystemMinorVersion: Cardinal;
    GdiHandleBuffer: array [0..33] of Cardinal;
    PostProcessInitRoutine: Cardinal;
    TlsExpansionBitmap: Cardinal;
    TlsExpansionBitmapBits: array [0..127] of Byte;
    SessionId: Cardinal;
  end;

///

/// Получить блок PEB своего процесса
///
function GetPDB: PPEB; stdcall;
asm
  mov eax, dword ptr fs:[30h]
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  // Получаем реальную версию ОС
  Win32MajorVersionReal := GetPDB^.OSMajorVersion;
  Win32MinorVersionReal := GetPDB^.OSMinorVersion;
  ShowMessage(IntToStr(Win32MajorVersionReal) + '.' +
              IntToStr(Win32MinorVersionReal));
end;

// Способ второй
// по сути немного модифицированный первый способ
function GetVersionPEB: Word;
asm
  {$IFDEF WIN32}
  mov edx, fs:[30h]
  mov eax, [edx+0A4h]
  shl eax, 8
  mov  al, [edx+0A8h]
  {$ELSE IFDEF WIN64}
  mov rdx, qword ptr GS:[abs $60]
  mov eax, [rdx+118h]
  shl eax, 8
  mov  al, [rdx+11Ch]
  {$ENDIF}
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  WinVer: Word;
  Major, Minor: Byte;
begin
  WinVer := GetVersionPEB;
  Major := HiByte(WinVer);
  Minor := LoByte(WinVer);
 
  ShowMessage(IntToStr(Major) + '.' + IntToStr(Minor));
end;

// Способ третий
// WMI
uses
  ActiveX, ComObj{, Variants};

procedure TForm1.Button1Click(Sender: TObject);
const
  WbemUser = '';
  WbemPassword = '';
  WbemComputer = 'localhost';
  wbemFlagForwardOnly = $00000020;
var
  FSWbemLocator: OLEVariant;
  FWMIService: OLEVariant;
  FWbemObjectSet: OLEVariant;
  FWbemObject: OLEVariant;
  oEnum: IEnumvariant;
  iValue: LongWord;
begin
  try
    FSWbemLocator := CreateOleObject('WbemScripting.SWbemLocator');
    FWMIService := FSWbemLocator.ConnectServer(WbemComputer, 'root\CIMV2', WbemUser, WbemPassword);
    FWbemObjectSet := FWMIService.ExecQuery('SELECT * FROM Win32_OperatingSystem', 'WQL', wbemFlagForwardOnly);
    oEnum := IUnknown(FWbemObjectSet._NewEnum) as IEnumVariant;
    while oEnum.Next(1, FWbemObject, iValue) = 0 do
    begin
      ShowMessage(Format('Версия: %s',[String(FWbemObject.Version)]));
      FWbemObject := Unassigned;
    end;
  except
    on E: EOleException do
      ShowMessage(Format('EOleException %s (%x)', [E.Message, E.ErrorCode]));
    on E: Exception do
      ShowMessage(E.Classname + ':' + E.Message);
  end;
end;

//initialization
//  CoInitialize(nil);

//finalization
//  CoUninitialize;

// Способ четвертый
type
  WKSTA_INFO_100 = record
    wki100_platform_id: DWORD;
    wki100_computername: LPWSTR;
    wki100_langroup: LPWSTR;
    wki100_ver_major: DWORD;
    wki100_ver_minor: DWORD;
  end;
  LPWKSTA_INFO_100 = ^WKSTA_INFO_100;
 
  function NetWkstaGetInfo(ServerName: LPWSTR; Level: DWORD;
    BufPtr: Pointer): Longint; stdcall;
    external 'netapi32.dll' Name 'NetWkstaGetInfo';
 
function GetWindowsVersion: string;
var
  PBuf: LPWKSTA_INFO_100;
  Res: LongInt;
begin
  Result := '';
  Res := NetWkstaGetInfo(nil, 100, @PBuf);
  if Succeeded(Res) then
    Result := Format('%d.%d', [PBuf^.wki100_ver_major, PBuf^.wki100_ver_minor]);
end;
 
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(GetWindowsVersion);
end;

// Способ пятый
type
  NET_API_STATUS = DWORD;
 
  _SERVER_INFO_101 = record
    sv101_platform_id: DWORD;
    sv101_name: LPWSTR;
    sv101_version_major: DWORD;
    sv101_version_minor: DWORD;
    sv101_type: DWORD;
    sv101_comment: LPWSTR;
  end;
  SERVER_INFO_101 = _SERVER_INFO_101;
  PSERVER_INFO_101 = ^SERVER_INFO_101;
  LPSERVER_INFO_101 = PSERVER_INFO_101;
 
  function NetServerGetInfo(servername: LPWSTR; level: DWORD; var bufptr): NET_API_STATUS;
    stdcall; external 'Netapi32.dll';
  function NetApiBufferFree(Buffer: LPVOID): NET_API_STATUS; stdcall; external 'Netapi32.dll';
 
const
  MAJOR_VERSION_MASK = $0F;
 
procedure TForm1.Button1Click(Sender: TObject);
var
  Buffer: PSERVER_INFO_101;
begin
  if NetServerGetInfo(nil, 101, Buffer) = NO_ERROR then
  try
    // Выдает данные реальной ОС из режима совместимости
    ShowMessage(Format('NetServerGetInfo: %d.%d',
      [Buffer.sv101_version_major and MAJOR_VERSION_MASK, Buffer.sv101_version_minor]));
  finally
    NetApiBufferFree(Buffer);
  end;
end;

// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage(SysErrorMessage(GetLastError));
end;

// Способ второй
procedure TForm1.Button1Click(Sender: TObject);
var
  fm: Integer;
  lpMsgBuf: PChar;
begin
  // На языке системы
  fm := FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
                      nil, 1 {код ошибки}, LANG_SYSTEM_DEFAULT, @lpMsgBuf, 0, nil);
  // или на указанном языке
  //fm := FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_SYSTEM,
  //                    nil, 1 {код ошибки}, MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US),
  //                    @lpMsgBuf, 0, nil);
  MessageBox(Handle, lpMsgBuf, nil, MB_OK);
  LocalFree(Cardinal(lpMsgBuf));
end;

// Способ третий
// аналог второго способа, но описание ошибки находится в DLL
procedure TForm1.Button1Click(Sender: TObject);
const
  // Коды ошибок можно посмотреть здесь
  // https://msdn.microsoft.com/en-us/library/aa366209.aspx
  E_IMAPI_BURN_VERIFICATION_FAILED = $C0AA0007;
var
  PBuf: PChar;
  isLoad: Boolean;
  imapi2: NativeInt;
begin
  isLoad := False;
  imapi2 := GetModuleHandle('imapi2.dll');

  if imapi2 = 0 then
  begin
    imapi2 := LoadLibrary('imapi2.dll');
    isLoad := True;
  end;

  FormatMessage(FORMAT_MESSAGE_ALLOCATE_BUFFER or FORMAT_MESSAGE_FROM_HMODULE,
    Pointer(imapi2), E_IMAPI_BURN_VERIFICATION_FAILED, 0, @PBuf, 0, nil);
  ShowMessage(PBuf);
  LocalFree(HLOCAL(PBuf));

  if isLoad then
    FreeLibrary(imapi2);
end;

uses
  Winapi.Dwmapi;

type
  TForm1 = class(TForm)
  private
    FPreviewEnabled: Boolean;
    FTumbnail: HTHUMBNAIL;
    procedure PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);
    procedure PreviewDisable;
    {...}
  end;

implementation

{.$DEFINE USE_RECTSOURCE}
{.$DEFINE USE_OPACITY}

procedure TForm1.PreviewDisable;
begin
   DwmUnregisterThumbnail(FTumbnail);
end;

procedure TForm1.PreviewWindow(const ASource, ADest: HWND; const ARect: TRect);
var
  LResult: HRESULT;
  LThumpProp: DWM_THUMBNAIL_PROPERTIES;
begin
  if not DwmCompositionEnabled then
  begin
    MessageDlg('DWM composition выключен.', mtWarning, [mbOK], 0);
    Exit;
  end;

  PreviewDisable;
  FPreviewEnabled := Succeeded(DwmRegisterThumbnail(ADest, ASource, @FTumbnail));
  if FPreviewEnabled then
  begin
    LThumpProp.dwFlags := DWM_TNP_SOURCECLIENTAREAONLY or DWM_TNP_VISIBLE or
                          DWM_TNP_RECTDESTINATION
                          {$IFDEF USE_OPACITY} or DWM_TNP_OPACITY{$ENDIF}
                          {$IFDEF USE_RECTSOURCE} or DWM_TNP_RECTSOURCE{$ENDIF};
    LThumpProp.fSourceClientAreaOnly := False;
    LThumpProp.fVisible := True;
    LThumpProp.rcDestination := ARect;
    {$IFDEF USE_OPACITY}
    LThumpProp.opacity := 200;
    {$ENDIF}
    {$IFDEF USE_RECTSOURCE}
    LThumpProp.rcSource := Rect(0, 0, 250, 250);
    {$ENDIF}
    LResult := DwmUpdateThumbnailProperties(FTumbnail, LThumpProp);
    FPreviewEnabled := LResult = S_OK;
  end
  else
    MessageDlg('Невозможно получить доступ к окну ' + IntToStr(ASource), mtError, [mbOK], 0);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Wnd: HWND;
begin
  Wnd := FindWindow('Progman', 'Program Manager');
  // Или Wnd := какой-нибудь известный хэндл окна другого приложения
  PreviewWindow(Wnd, Handle, Rect(0, 0, ClientWidth, ClientHeight));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  PreviewDisable;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  if FPreviewEnabled then
  begin
    FPreviewEnabled := not Succeeded(DwmUnregisterThumbnail(FTumbnail));
    Button1Click(Button1);
  end;
end;

const
  WM_SENDICONICTHUMBNAILBITMAP = $0323;

type
  TForm1 = class(TForm)
    procedure FormCreate(Sender: TObject);
  private
    procedure WMSendIconicThumbnailBitmap(var Msg: TMessage); message WM_SENDICONICTHUMBNAILBITMAP;
  {...}
  end;

{...}

implementation

uses
  Winapi.Dwmapi;

var
  Bmp: TBItmap;

// При создании окна ему надо установить атрибуты, сообщающие
// системе, что окно использует собственную превьюшку.
procedure TForm1.FormCreate(Sender: TObject);
var
  DEnable: BOOL;
begin
  DEnable := True; // DWMNCRP_ENABLED;

  if not Succeeded(DwmSetWindowAttribute(Handle, DWMWA_HAS_ICONIC_BITMAP,
    @DEnable, SizeOf(DEnable))) then
    ShowMessage('DWMWA_HAS_ICONIC_BITMAP Error');

  if not Succeeded(DwmSetWindowAttribute(Handle, DWMWA_FORCE_ICONIC_REPRESENTATION,
    @DEnable, SizeOf(DEnable))) then
    ShowMessage('DWMWA_FORCE_ICONIC_REPRESENTATION Error');
end;

// Когда пользователь наводит курсор на панель задач, окну отправляется
// системное сообщение WM_SENDICONICTHUMBNAILBITMAP. В параметре lParam
// сообщения, в старшем и младшем WORD'е передается размер изображения,
// которую система хотела бы получить в качестве превьюшки.
procedure TForm1.WMSendIconicThumbnailBitmap(var Msg: TMessage);

  procedure ResizeBmp(var Bmp: TBitmap; NewWidth, NewHeight: Integer);
  var
    Tmp: TBitmap;
  begin
    Tmp := TBitmap.Create;
    Tmp.SetSize(NewWidth, NewHeight);
    Tmp.Canvas.StretchDraw(Rect(0, 0, NewWidth, NewHeight), Bmp);
    Bmp.Assign(Tmp);
    Tmp.Free;
  end;

const
  DWM_SIT_DISPLAYFRAME = 1;
begin
  inherited;

  if Assigned(Bmp) then
    FreeAndNil(Bmp);

  Bmp := TBitmap.Create;
  Bmp.LoadFromFile('d:\1.bmp');

  // Подгоняем картинку под размеры, требуемые ОС
  if (Bmp.Width <> Msg.LParamHi) or (Bmp.Height <> Msg.LParamLo) then
    ResizeBmp(Bmp, Msg.LParamHi, Msg.LParamLo);

  // Обязательно надо 32-битный ставить, иначе не получится
  Bmp.PixelFormat := pf32bit;

  if not Succeeded(DwmSetIconicThumbnail(Handle, Bmp.Handle, 0)) then
    ShowMessage('DwmSetIconicThumbnail Error');

  FreeAndNil(Bmp);
  Msg.Result := 0;
end;