Opět budeme využívat externí systémovou dll knihovnu a celý zdrojový kód bude vypadat následovně:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
Forms,
Dialogs, StdCtrls, ComObj;
type
TForm1
= class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
GetCurrentThemeName: function (pszThemeFileName: LPWSTR; cchMaxNameChars:
Integer; pszColorBuff: LPWSTR; cchMaxColorChars: Integer; pszSizeBuff: LPWSTR;
cchMaxSizeChars: Integer): HRESULT;
stdcall;
implementation
{$R
*.dfm}
procedure TForm1.Button1Click(Sender:
TObject);
var
FileName, ColorScheme, SizeName:
WideString;
hThemeLib: THandle;
begin
try
hThemeLib := LoadLibrary(`uxtheme.dll`);
if hThemeLib > 0 then GetCurrentThemeName :=
GetProcAddress(hThemeLib, `GetCurrentThemeName`);
if
Assigned(GetCurrentThemeName) then
begin
SetLength(FileName, 255);
SetLength(ColorScheme, 255);
SetLength(SizeName,
255);
OleCheck(GetCurrentThemeName(PWideChar(FileName),
255, PWideChar(ColorScheme), 255, PWideChar(SizeName), 255));
ShowMessage(PWideChar(FileName) + ` ` + PWideChar(ColorScheme) +
` ` + PWideChar(SizeName));
end;
finally
FreeLibrary(hThemeLib);
end;
end;
end.
Po stisknutí tlačítka budou všechny hledané informace vypsány pomocí ShowMessage. Zřejmě je zbytečné připomínat, že tato funkce má samozřejmě smysl pouze pod Windows XP a v ostatních verzích Windows se nestane nic.
