Программирование на Delphi

FAQ VCL
Windows

:: Меню ::

:: На главную ::

:: FAQ ::

:: Заметки ::

:: Практика ::

:: Win API ::

:: Проекты ::

:: Скачать ::

:: Секреты ::

:: Ссылки ::

:: Сервис ::

:: Написать ::

:: MVP ::

:: RSS ::

Как программно нажать на кнопку "Пуск"?


// Способ первый
SendMessage( GetWindow( FindWindow( 'Shell_TrayWnd', nil ), GW_CHILD ),
             WM_LBUTTONDOWN, MK_LBUTTON, LOWORD( 5 ) + HIWORD( 20 ) );

// Способ второй
SendMessage( Self.Handle, WM_SYSCOMMAND, SC_TASKLIST, 0 );

Как узнать стиль картинки рабочего стола "По центру/Рядом/Растянуть"?


uses
  {...,} Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
  TileWallpaper: string;
  WallpaperStyle: string;
begin
   Reg := TRegIniFile.Create;
   Reg.RootKey := HKEY_CURRENT_USER;
   Reg.OpenKey( 'Control Panel\Desktop', false );
   TileWallpaper := Reg.ReadString( 'TileWallpaper' );
   WallpaperStyle := Reg.ReadString( 'WallpaperStyle' );
   Reg.CloseKey;
   Reg.Free;
   case StrToInt( TileWallpaper ) of
      0: case StrToInt( WallpaperStyle ) of
            0: Edit1.Text := 'По центру';
            2: Edit1.Text := 'Растянуть';
         end;
      1: if StrToInt( WallpaperStyle ) = 0 then
         Edit1.Text := 'Рядом';
      else
         Edit1.Text := 'Без понятия';
   end;
end;

Как заставить рабочий стол Windows обновится?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  Desktop: HWND;
begin
   Desktop := FindWindow( 'Progman', 'Program Manager' );
   Desktop := FindWindowEx( Desktop, 0, 'SHELLDLL_DefView', '' );
   Desktop := FindWindowEx( Desktop, 0, 'SysListView32', '' );
   PostMessage( Desktop, WM_KEYDOWN, VK_F5, 0 );
   PostMessage( Desktop, WM_KEYUP, VK_F5, 1 shl 31 );
end;

// Способ второй
uses
   {...,} ShlObj, ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  ActiveDesktop: IActiveDesktop;
begin
   ActiveDesktop := CreateComObject( CLSID_ActiveDesktop ) as IActiveDesktop;
   ActiveDesktop.ApplyChanges( AD_APPLY_ALL or AD_APPLY_FORCE );
end;

// Способ третий
uses
   {...,} ShlObj;

procedure TForm1.Button1Click(Sender: TObject);
begin
   SHChangeNotify( SHCNE_ASSOCCHANGED, SHCNF_IDLIST, nil, nil );
end;

Как определить размер рабочего стола?


// Размер рабочего стола без Тaskbar'а
procedure TForm1.Button1Click(Sender: TObject);
var
  r: TRect;
begin
   SystemParametersInfo( SPI_GETWORKAREA, 0, @r, 0 );
   Memo1.Lines.Add( IntToStr( r.Top ) );
   Memo1.Lines.Add( IntToStr( r.Left ) );
   Memo1.Lines.Add( IntToStr( r.Bottom ) );
   Memo1.Lines.Add( IntToStr( r.Right ) );
end;

Как вызвать диалог "Завершение работы с Windows"?


SendMessage( FindWindow( 'Progman', 'Program Manager' ),
             WM_CLOSE, 0, 0 );

Как спрятать панель задач?


// Убрать панель задач
procedure TForm1.Button1Click(Sender: TObject);
var
  TaskBar: HWND;
begin
   TaskBar := FindWindow( 'Shell_TrayWnd', nil );
   ShowWindow( TaskBar, SW_HIDE );
end;

// Вернуть панель задач
procedure TForm1.Button2Click(Sender: TObject);
var
  TaskBar: HWND;
begin
   TaskBar := FindWindow( 'Shell_TrayWnd', nil );
   ShowWindow( TaskBar, SW_SHOW );
end;

Как узнать версию Windows?


// Способ первый
// Win95 или выше и NT3.5 или выше
function GetWinVer: string;
var
  temp1, temp2, temp3:  integer;
  OsVer: OSVERSIONINFO;
begin
   OsVer.dwOSVersionInfoSize := SizeOf( OSVERSIONINFO );
   GetVersionEx( OsVer );
   temp1 := OsVer.dwMajorVersion;
   temp2 := OsVer.dwMinorVersion;
   temp3 := OsVer.dwPlatformId;

   if temp1 = 4 then
      if temp2 = 0 then
         if temp3 = VER_PLATFORM_WIN32_WINDOWS then
            Result := 'Windows 95';

   if temp1 = 4 then
      if temp2 = 10 then
         Result := 'Windows 98';

   if temp1 = 4 then
      if temp2 = 90 then
         Result := 'Windows Me';

   if temp1 = 3 then
      if temp2 = 51 then
         Result := 'Windows NT 3.51';

   if temp1 = 4 then
      if temp2 = 0 then
         Result := 'Windows NT 4.0';

   if temp1 = 5 then
      if temp2 = 0 then
         Result := 'Windows 2000';

   if temp1 = 5 then
      if temp2 = 1 then
         Result := 'Windows XP';

   if temp1 = 6 then
      if temp2 = 0 then
         Result := 'Windows Vista';

   if temp1 = 6 then
      if temp2 = 1 then
         Result := 'Windows 7';
end;

// Способ второй
{true = Win9x, false = NT}
function isWin9x: Bool;
asm
   xor eax, eax
   mov ecx, cs
   xor cl, cl
   jecxz @@quit
   inc eax
   @@quit:
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   if isWin9x then
      Form1.Caption := 'Win9x'
   else
      Form1.Caption := 'WinNT';
end;

// Способ третий
procedure TForm1.FormCreate(Sender: TObject);
begin
   case Win32Platform of
      VER_PLATFORM_WIN32s: ShowMessage( 'System is Win32s' );
      VER_PLATFORM_WIN32_WINDOWS: ShowMessage( 'System is Windows 95' );
      VER_PLATFORM_WIN32_NT: ShowMessage( 'System is Windows NT' );
   end;
end;

// Способ четвертый
procedure TForm1.Button1Click(Sender: TObject);
var
  s: string;
begin
   s := 'Win32Platform = ' + IntToStr( Win32Platform ) + #13 +
        'Win32MajorVersion = ' + IntToStr( Win32MajorVersion ) + #13 +
        'Win32MinorVersion = ' + IntToStr( Win32MinorVersion ) + #13 +
        'Win32BuildNumber = ' + IntToStr( Win32BuildNumber );
   ShowMessage( s );
end;

// Способ пятый
procedure TForm1.Button1Click(Sender: TObject);
begin
   if CheckWin32Version( 6, 1 ) then
      ShowMessage( 'Windows 7' )
   else
   if CheckWin32Version( 6, 0 ) then
      ShowMessage( 'Windows Vista' )
   else
   if CheckWin32Version( 5, 1 ) then
      ShowMessage( 'Windows XP' )
   else
   if CheckWin32Version( 5, 0 ) then
      ShowMessage( 'Windows 2000' );
end;

// Способ шестой
uses
  {...,} ComObj;

procedure TForm1.Button1Click(Sender: TObject);
var
  WshShell: Variant;
begin
   WshShell := CreateOleObject( 'WScript.Shell' );
   try
      ShowMessage( WshShell.RegRead( 'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\ProductName' ) );
      ShowMessage( WshShell.RegRead( 'HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\EditionID' ) );
   finally
      WshShell := Unassigned;
   end;
end;

// Способ седьмой
uses
  {...,} Registry;

procedure TForm1.Button4Click(Sender: TObject);
var
  Reg: TRegistry;
begin
   Reg := TRegistry.Create( {KEY_READ or} KEY_WOW64_64KEY );
   Reg.RootKey := HKEY_LOCAL_MACHINE;
   try
      Reg.OpenKeyReadOnly( 'SOFTWARE\Microsoft\Windows NT\CurrentVersion' );
      ShowMessage( Reg.ReadString( 'ProductName' ) );
      ShowMessage( Reg.ReadString( 'EditionID' ) );
      ShowMessage( Reg.ReadString( 'ProductId' ) );
   finally
      Reg.CloseKey;
      Reg.Free;
   end;
end;

// Способ восьмой
type
  SizeZZ = {$IFDEF CPUX64}UInt64{$ELSE}LongWord{$ENDIF}; //NativeUInt;

function GetPEB: SizeZZ;
asm
   {$IFDEF CPUX64}
   MOV RAX, GS:[60h]
   {$ELSE}
   MOV EAX, FS:[30h]
   {$ENDIF}
end;

//function GetUSD: SizeZZ;
//asm
//   {$IFDEF CPUX64}
//   MOV RAX, 7FFE0000h
//   {$ELSE}
//   MOV EAX, 7FFE0000h
//   {$ENDIF}
//end;

function GetTEB: SizeZZ;
asm
   {$IFDEF CPUX64}
   MOV RAX, GS:[30h]
   {$ELSE}
   MOV EAX, FS:[18h]
   {$ENDIF}
end;

function OSinfo: string;
var
  dwMajorVersion,
  dwMinorVersion,
  dwBuildNumber,
  wProductType,
  dwPlatformId: Cardinal;
  Peb, Usd: SizeZZ;
  NtSystemRoot: PWideChar;
  Is64: string;
begin
   {$IFDEF CPUX64}
   Is64 := 'x64';
   {$ELSE}
   if PCardinal(GetTEB+$C0)^ = 0 then
      Is64 := 'x32'
   else
      Is64 := 'x64';
   {$ENDIF}

   Peb := GetPEB;
   {$IFDEF CPUX64}
   dwMajorVersion := PCardinal(Peb+$118)^;
   dwMinorVersion := PCardinal(Peb+$11C)^;
   dwBuildNumber := PCardinal(Peb+$120)^;
   dwPlatformId := PCardinal(Peb+$124)^;
   {$ELSE}
   dwMajorVersion := PCardinal(Peb+$A4)^;
   dwMinorVersion := PCardinal(Peb+$A8)^;
   dwBuildNumber := PCardinal(Peb+$AC)^;
   dwPlatformId := PCardinal(Peb+$B0)^;
   {$ENDIF}

   // Usd := GetUSD;
   // wProductType := PCardinal(Usd+$264)^;
   // NtSystemRoot := PWideChar(Usd+$30);

   Result := 'Major = ' + IntToStr(dwMajorVersion) + #13 +
             'Minor = ' + IntToStr(dwMinorVersion) + #13 +
             'Build = ' + IntToStr(dwBuildNumber) + #13 +
             'PlatID = ' + IntToStr(dwPlatformId) + #13 +
             'CSD = ' + Is64;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   ShowMessage(OSinfo);
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;

procedure TForm1.Button2Click(Sender: TObject);
type
  TWinVer = record
    case Integer of
      0: (Version: Word);
      1: (Minor, Major: Byte);
  end;
var
  WinVer: TWinVer;
begin
   WinVer.Version := GetVersionPEB;
 
   ShowMessage(IntToStr(WinVer.Major) + '.' + IntToStr(WinVer.Minor));
end;

procedure TForm1.Button3Click(Sender: TObject);
type
  TWinVer = record
    Minor, Major: Byte;
  end;
var
  Ver: Word;
  WinVer: TWinVer absolute Ver;
begin
   Ver := GetVersionPEB;
 
   ShowMessage(IntToStr(WinVer.Major) + '.' + IntToStr(WinVer.Minor));
end;

// Способ десятый
type
  TRtlGetVersion = function(var RTL_OSVERSIONINFOEXW): LONG; stdcall;

procedure TForm1.Button1Click(Sender: TObject);
var
  RtlGetVersion: TRtlGetVersion;
  ver: RTL_OSVERSIONINFOEXW;
begin
   @RtlGetVersion := GetProcAddress(GetModuleHandle('ntdll.dll'), 'RtlGetVersion');
   if Assigned(RtlGetVersion) then
   begin
      ZeroMemory(@ver, SizeOf(ver));
      ver.dwOSVersionInfoSize := SizeOf(ver);

      if RtlGetVersion(ver) = 0 then
         ShowMessage(Format('RtlGetVersion: %d.%d'#13'%s',
            [ver.dwMajorVersion, ver.dwMinorVersion, ver.szCSDVersion]));
   end;
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;

// Способ двенадцатый
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 GetNetParam(AParam: Integer): string;
var
  PBuf: LPWKSTA_INFO_100;
  Res: LongInt;
begin
   Result := '';
   Res := NetWkstaGetInfo(nil, 100, @PBuf);
   if Succeeded(Res) then
   begin
      case AParam of
         0: Result := String(PBuf^.wki100_computername);
         1: Result := String(PBuf^.wki100_langroup);
         2: Result := Format('%d.%d', [PBuf^.wki100_ver_major, PBuf^.wki100_ver_minor]);
      end;
   end;
end;

function GetComputerName: string;
begin
   Result := GetNetParam(0);
end;

function GetDomainName: string;
begin
   Result := GetNetParam(1);
end;

function GetWindowsVersion: string;
begin
   Result := GetNetParam(2);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
   // Выдает данные реальной ОС из режима совместимости
   ShowMessage(GetWindowsVersion);
end;

Как получить список всех запущенных приложений?


procedure TForm1.Button1Click(Sender: TObject);
var
  Wnd: hWnd;
  buff: array [0..127] of Char;
begin
   ListBox1.Clear;
   // Получаем hWnd первого окна
   Wnd := GetWindow( Handle, gw_HWndFirst );
   // Цикл поиска окон
   while Wnd <> 0 do
   begin
      // Исключаем невидимые окна
      if IsWindowVisible( Wnd ) and
         // Исключаем дочернии окна
         ( GetWindow( Wnd, gw_Owner ) = 0 ) and
         // Исключаем окна без заголовков
         ( GetWindowText( Wnd, buff, sizeof( buff ) ) <> 0 ) then
         begin
            GetWindowText( Wnd, buff, sizeof( buff ) );
            ListBox1.Items.Add( StrPas( buff ) );
         end;
      // Ищем следующее окно
      Wnd := GetWindow( Wnd, gw_hWndNext );
   end;
   ListBox1.ItemIndex := 0;
end;

Как узнать, отключена перерисовка окна при его перетаскивании или нет?


// Способ первый
procedure TForm1.Button1Click(Sender: TObject);
var
  b: BOOL;
begin
   SystemParametersInfo( SPI_GETDRAGFULLWINDOWS, 0, @b, 0 );
   if b then
      ShowMessage( 'Перерисовка включена' )
   else
      ShowMessage( 'Перерисовка отключена' );
end;

// Способ второй
uses
  {...,} Registry;

procedure TForm1.Button1Click(Sender: TObject);
var
  Reg: TRegistry;
  temp: string;
  DragFull: Byte;
begin
   with TRegistry.Create do
   begin
      RootKey := HKEY_CURRENT_USER;
      OpenKey( 'Control Panel\Desktop', false );
      DragFull := StrToInt( ReadString( 'DragFullWindows' ) );
      case DragFull of
         0: ShowMessage( 'Перерисовка отключена' );
         1: ShowMessage( 'Перерисовка включена' );
      end;
      CloseKey;
      Free;
   end;
end;

Как узнать, сколько времени работает Windows?


// Вариант первый
// Timer1.Interval = 1000
procedure TForm1.Timer1Timer(Sender: TObject);
var
  Time, h, m, s: Integer;
begin
   Time := GetMessageTime div 1000;
   s := Time mod 60;
   m := ( Time div 60 ) mod 60;
   h := ( Time div 3600 );
   Form1.Caption := Format( '%d:%.2d:%.2d', [h,m,s] );
end;

// Вариант второй
// Timer1.Interval = 1000
procedure TForm1.Timer1Timer(Sender: TObject);
var
  Time, h, m, s: Integer;
begin
   Time := GetTickCount div 1000;
   s := Time mod 60;
   m := ( Time div 60 ) mod 60;
   h := ( Time div 3600 );
   Form1.Caption := Format( '%d:%.2d:%.2d', [h,m,s] );
end;

При использовании материала - ссылка на сайт обязательна