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 

[ktxmax]

Hello,can you show how to modify this code to apply Active Desktop Item?? And how to make use of this COMPONENT to setup the Active Destop Item setting??

http://msdn.microsoft.com/library/de.../component.asp

typedef struct _tagCOMPONENT {
    DWORD dwSize;
    DWORD dwID;
    int iComponentType;
    BOOL fChecked;
    BOOL fDirty;
    BOOL fNoScroll;
    COMPPOS cpPos;
    WCHAR wszFriendlyName[MAX_PATH];
    WCHAR wszSource[INTERNET_MAX_URL_LENGTH];
    WCHAR wszSubscribedURL[INTERNET_MAX_URL_LENGTH];
    DWORD dwCurItemState;
    COMPSTATEINFO csiOriginal;
    COMPSTATEINFO csiRestored;
} COMPONENT, *LPCO 

Thanks for any guide.

[schoolbusdriver]

Many thanks for this rm_03. You've understated your code! It works for HTM files too.