1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142
|
unit Unit1;
{$mode objfpc}{$H+}
///////////////////////////////////////////////////////////////////////////////////////////////////
interface
///////////////////////////////////////////////////////////////////////////////////////////////////
uses
Classes, SysUtils, Forms, Controls, Graphics, Dialogs, StdCtrls, ExtDlgs;
type
TForm1 = class(TForm)
Button1: TButton;
Memo1: TMemo;
procedure Button1Click(Sender: TObject);
end;
var
Form1: TForm1;
///////////////////////////////////////////////////////////////////////////////////////////////////
implementation
///////////////////////////////////////////////////////////////////////////////////////////////////
{$R *.lfm}
uses
Windows, ActiveX, ShlObj, ComObj;
// ORDER is important when declaring the interface -- everything must match EXACTLY
// https://github.com/tpn/winsdk-10/blob/master/Include/10.0.16299.0/um/ShObjIdl_core.h
// https://docs.microsoft.com/en-us/windows/win32/api/shobjidl_core/nn-shobjidl_core-idesktopwallpaper
const
CLSID_DesktopWallpaper : TCLSID = '{C2CF3110-460E-4FC1-B9D0-8A1C0C9CC4BD}';
SID_DesktopWallpaper = '{B92B56A9-8B55-4E14-9A89-0199BBB6F93B}';
type
PIShellItemArray = ^IShellItemArray;
{$Z4}
DESKTOP_SLIDESHOW_OPTIONS =
(
DSO_DEFAULT = $0,
DSO_SHUFFLEIMAGES = $1
);
DESKTOP_SLIDESHOW_STATE =
(
DSS_ENABLED = $1,
DSS_SLIDESHOW = $2,
DSS_DISABLED_BY_REMOTE_SESSION = $4
);
DESKTOP_SLIDESHOW_DIRECTION =
(
DSD_FORWARD = 0,
DSD_BACKWARD = 1
);
DESKTOP_WALLPAPER_POSITION =
(
DWPOS_CENTER = 0,
DWPOS_TILE = 1,
DWPOS_STRETCH = 2,
DWPOS_FIT = 3,
DWPOS_FILL = 4,
DWPOS_SPAN = 5
);
IDesktopWallpaper = interface( IUnknown )
[SID_DesktopWallpaper]
procedure SetWallpaper( monitorID:PWideChar; wallpaper:PWideChar ); safecall;
function GetWallpaper( monitorID:PWideChar ): PWideChar; safecall;
function GetMonitorDevicePathAt( monitorIndex:LongWord ): PWideChar; safecall;
function GetMonitorDevicePathCount: LongWord; safecall;
function GetMonitorRECT( monitorID:PWideChar ): TRect; safecall;
procedure SetBackgroundColor( color:COLORREF ); safecall;
function GetBackgroundColor: COLORREF; safecall;
procedure SetPosition( position:DESKTOP_WALLPAPER_POSITION ); safecall;
function GetPosition: DESKTOP_WALLPAPER_POSITION; safecall;
procedure SetSlideshow( items:PIShellItemArray ); safecall;
function GetSlideshow: PIShellItemArray; safecall;
procedure SetSlideshowOptions( options:DESKTOP_SLIDESHOW_OPTIONS; slideshowTick:LongWord ); safecall;
procedure GetSlideshowOptions( out options:DESKTOP_SLIDESHOW_OPTIONS; out slideshowTick:LongWord ); safecall;
procedure AdvanceSlideShow( monitorID:PWideChar; direction:DESKTOP_SLIDESHOW_DIRECTION ); safecall;
function GetStatus: DESKTOP_SLIDESHOW_STATE; safecall;
procedure Enable( enable:LongBool ); safecall;
end;
function CopyAndCoTaskMemFree( s:PWideChar ): WideString;
begin
result := s;
CoTaskMemFree( s )
end;
procedure TForm1.Button1Click(Sender: TObject);
var
Wallpaper : IDesktopWallpaper;
MonitorCount : Integer;
n : Integer;
MonitorPath : WideString;
PicturePath : WideString;
begin
Memo1.Lines.Clear;
try
Wallpaper := CreateComObject( CLSID_DesktopWallpaper ) as IDesktopWallpaper;
Memo1.Lines.Add( 'IDesktopWallpaper instance created' );
try
// Single picture on all monitors
PicturePath := CopyAndCoTaskMemFree( Wallpaper.GetWallpaper( nil ) );
Memo1.Lines.Add( '(Single picture on all monitors)' );
Memo1.Lines.Add( 'file = ' + String(PicturePath) );
finally
MonitorCount := Wallpaper.GetMonitorDevicePathCount;
Memo1.Lines.Add( 'monitor count = ' + IntToStr( MonitorCount ) );
for n := 0 to MonitorCount-1 do
begin
Memo1.Lines.Add( IntToStr( n ) + ':' );
MonitorPath := CopyAndCoTaskMemFree( Wallpaper.GetMonitorDevicePathAt( n ) );
Memo1.Lines.Add( ' monitor id = ' + String(MonitorPath) );
PicturePath := CopyAndCoTaskMemFree( Wallpaper.GetWallpaper( PWideChar(MonitorPath) ) );
Memo1.Lines.Add( ' file path = ' + String(PicturePath) );
end
end
except
on E:EOleError do ShowMessage( E.Message )
end;
Wallpaper := nil
end;
| |