' 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 strukter yapisina dunusturelim (nedemekse)
hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid)
If hRes <> 0 Then
Debug.Print "IDD ye cevirme basarisizlikla sonuclandi"
Exit Function
End If

' IActiveDesktop Instanz olustu
hRes = CoCreateInstance(classid, 0, &H1, IID_IUnknown, VarPtr(obj))
If hRes <> 0 Then
Debug.Print " IActiveDesktop Instanz olusturulmasi basarisizlikla sonuclandi"
Exit Function
End If

' VTable den Instanz kopyala
RtlMoveMemory vtblptr, ByVal obj, 4
RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)

' SetWallpaper den VTable cagiralim
hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
If hRes <> 0 Then
Debug.Print "yeni wallpaperi yerlestirilemedi"
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 "masa usutu aktualize edilemedi"
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: