Rubrik: System/Windows · Desktop/Bildschirm/Display | VB-Versionen: VB6 | 26.09.05 |
JPEGs als Wallpapers Mit IActiveDesktop können auch JPEGs als Wallpapers genommen werden | ||
Autor: Arne Elster | Bewertung: | Views: 10.850 |
actorics.de/rm_code | System: Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11 | Beispielprojekt auf CD |
Der weitverbreitete Tipp zum Setzen eines Wallpapers per SystemParametersInfo() hat einen Nachteil: Er erlaubt nur BMPs.
Der Active Desktop macht es da besser; er unterstützt mehrere Formate, u.a. JPEGs und GIFs. Allerdings gibt's den Active Desktop nur in der COM Variante, besser gesagt, als Interface. Und hier bockt VB, es unterstützt nur Interfaces, die es kennt oder die per Type Lib definiert wurden. Mit ein wenig Getrickse lässt sich das aber aushebeln. Als "Objekt", das das IActiveDesktop Interface aufnimmt, nehmen wir einfach einen Long, klauen uns über den die VTable des Interfaces und rufen die gewünschten Funktionen SetWallpaper() und ApplyChanges() mit Hilfe von ein wenig Assembler auf.
Modul modWallpaper
Option Explicit ' Benötigte API-Deklarationen Private Declare Function IIDFromString Lib "ole32" ( _ ByVal lpszIID As Long, _ iid As Any) As Long Private Declare Function CoCreateInstance Lib "ole32" ( _ rclsid As Any, _ ByVal pUnkOuter As Long, _ ByVal dwClsContext As Long, _ riid As Any, _ ByVal ppv As Long) As Long Private Declare Function CallWindowProcA Lib "user32" ( _ ByVal addr As Long, _ ByVal p1 As Long, _ ByVal p2 As Long, _ ByVal p3 As Long, _ ByVal p4 As Long) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" ( _ pDst As Any, _ pSrc As Any, _ ByVal dlen As Long) Private Const CLSCTX_INPROC_SERVER As Long = 1& Private Const CLSID_ActiveDesktop As String = _ "{75048700-EF1F-11D0-9888-006097DEACF9}" Private Type GUID data1 As Long data2 As Integer data3 As Integer data4(7) As Byte End Type Private Type IActiveDesktop ' IUnknown QueryInterface As Long AddRef As Long Release As Long ' IActiveDesktop ApplyChanges As Long GetWallpaper As Long SetWallpaper As Long GetWallpaperOptions As Long SetWallpaperOptions As Long GetPattern As Long SetPattern As Long GetDesktopItemOptions As Long SetDesktopItemOptions As Long AddDesktopItem As Long AddDesktopItemWithUI As Long ModifyDesktopItem As Long RemoveDesktopItem As Long GetDesktopItemCount As Long GetDesktopItem As Long GetDesktopItemByID As Long GenerateDesktopItemHtml As Long AddUrl As Long GetDesktopItemBySource As Long End Type Private Enum AD_APPLY AD_APPLY_SAVE = &H1 AD_APPLY_HTMLGEN = &H2 AD_APPLY_REFRESH = &H4 AD_APPLY_ALL = &H7 AD_APPLY_FORCE = &H8 AD_APPLY_BUFFERED_REFRESH = &H10 AD_APPLY_DYNAMICREFRESH = &H20 End Enum
Public Function ActiveDesktopSetWallpaper( _ ByVal strFile As String) As Boolean Dim vtbl As IActiveDesktop Dim vtblptr As Long Dim classid As GUID Dim IID_IUnknown As GUID Dim obj As Long Dim hRes As Long With IID_IUnknown .data4(0) = &HC0 .data4(7) = &H46 End With ' CLSID String in Struktur umschiffen hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid) If hRes <> 0 Then Debug.Print "Konnte String nicht in IID umwandeln" Exit Function End If ' IActiveDesktop Instanz erstellen hRes = CoCreateInstance(classid, 0, &H1, IID_IUnknown, VarPtr(obj)) If hRes <> 0 Then Debug.Print "Konnte IActiveDesktop Instanz nicht erstellen" Exit Function End If ' VTable von Instanz kopieren RtlMoveMemory vtblptr, ByVal obj, 4 RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl) ' SetWallpaper aus VTable aufrufen hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0) If hRes <> 0 Then Debug.Print "Konnte neues Wallpaper nicht setzen" Else ActiveDesktopSetWallpaper = True End If ' ApplyChanges aus VTable aufrufen hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE) If hRes <> 0 Then Debug.Print "Konnte Desktop nicht aktualisieren" End If ' Instanz zerstören CallPointer vtbl.Release, obj End Function
Private Function CallPointer(ByVal fnc As Long, ParamArray params()) As Long Dim btASM(&HEC00& - 1) As Byte Dim pASM As Long Dim i As Integer pASM = VarPtr(btASM(0)) AddByte pASM, &H58 ' POP EAX AddByte pASM, &H59 ' POP ECX AddByte pASM, &H59 ' POP ECX AddByte pASM, &H59 ' POP ECX AddByte pASM, &H59 ' POP ECX AddByte pASM, &H50 ' PUSH EAX For i = UBound(params) To 0 Step -1 AddPush pASM, CLng(params(i)) ' PUSH dword Next AddCall pASM, fnc ' CALL rel addr AddByte pASM, &HC3 ' RET CallPointer = CallWindowProcA(VarPtr(btASM(0)), 0, 0, 0, 0) End Function
Private Sub AddPush(pASM As Long, lng As Long) AddByte pASM, &H68 AddLong pASM, lng End Sub
Private Sub AddCall(pASM As Long, addr As Long) AddByte pASM, &HE8 AddLong pASM, addr - pASM - 4 End Sub
Private Sub AddLong(pASM As Long, lng As Long) RtlMoveMemory ByVal pASM, lng, 4 pASM = pASM + 4 End Sub
Private Sub AddByte(pASM As Long, bt As Byte) RtlMoveMemory ByVal pASM, bt, 1 pASM = pASM + 1 End Sub
Code zum Testen:
If ActiveDesktopSetWallpaper("C:\wallpaper.jpg") Then MsgBox "Neues Wallpaper erfolgreich gesetzt" Else MsgBox "Konnte neues Wallpaper nicht setzen" End If