VB6 - JPEGs as wallpapers (without conversion)

[rm_03]

Hi there,

today I want to show you how to access IActiveDesktop to set
a new wallpaper (Active Desktop has to be enabled).
Actually nothing special, just declare IActiveDesktop in a type library,
and instance it with the "new" keyword in VB.
In this example I did it without the use of a type lib. Hardcore!!

Put the following in a module:

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

How to use it:

If ActiveDesktopSetWallpaper("C:\wallpaper.jpg") Then
    MsgBox "Successfully set new wallpaper"
Else
    MsgBox "Failed to set new wallpaper"
End If