Option Explicit
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 Const IID_ActiveDesktop As String = "{F490EB00-1240-11D1-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 As GUID
Dim obj As Long
Dim hRes As Long
' CLSID (BSTR) to CLSID (GUID)
hRes = IIDFromString(StrPtr(CLSID_ActiveDesktop), classid)
If hRes <> 0 Then
Exit Function
End If
' IID (BSTR) to IID (GUID)
hRes = IIDFromString(StrPtr(IID_ActiveDesktop), iid)
If hRes <> 0 Then
Exit Function
End If
' create an instance of IActiveDesktop
' (Set IActiveDesktop = New IActiveDesktop)
hRes = CoCreateInstance(classid, 0, CLSCTX_INPROC_SERVER, iid, VarPtr(obj))
If hRes <> 0 Then
Exit Function
End If
' obj points now to a pointer to the VTable
' of IActiveDesktop
'
' dereference the VTable pointer
RtlMoveMemory vtblptr, ByVal obj, 4
' copy the VTable to our IActiveDesktop structure
RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)
' call IActiveDesktop::SetWallpaper
'
' the first parameter is always the object pointer
' the return value should always be a HRESULT (0 = S_OK)
hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
If hRes = 0 Then
ActiveDesktopSetWallpaper = True
End If
' call IActiveDesktop::ApplyChanges
hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE)
' release IActiveDesktop to free memory
' (Set IActiveDesktop = Nothing)
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
