JPEGs als Wallpapers Mit IActiveDesktop können auch JPEGs als Wallpapers genommen werden
Autor:   Arne Elster	Bewertung:     [ Jetzt bewerten ]	Views:  11.085
actorics.de/rm_code	System:  Win9x, WinNT, Win2k, WinXP, Win7, Win8, Win10, Win11	Beispielprojekt auf CD

Geben Sie hier Ihre persönliche Bewertung ab! Anzahl Bewertungen bisher: 17 Bewertung insgesamt: gut Durchschnittliche Bewertung: 3.5 von 5 Sternen

sehr gut     gut     nützlich     mittelmäßig     mangelhaft

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