Как программно в Windows XP поменять картинку на рабочем столе, используя файл JPG?

' Декларации API...
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoW" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long
 
' Константы
Private Const SETDESKWALLPAPER = &H14
Private Const UPDATEINIFILE = &H1
 
' Изменение обоев на рабочем столе
Public Function SetWallpaper(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    
    RetVal = SystemParametersInfo(SETDESKWALLPAPER, 0, StrPtr(FileName), UPDATEINIFILE)
    If RetVal = 1 Then SetWallpaper = True
End Function

Option Explicit
 
Private Sub Command1_Click()
    Print SetWallpaper("C:\WINDOWS\Web\Wallpaper\Nature\img6.jpg")
End Sub

Option Explicit
'/////////////////////////////////////////////////
'// Модуль для изменения обоев на рабочем столе //
'// Copyright (c) 01.08.2023 by HackerVlad      //
'// e-mail: vladislavpeshkov@yandex.ru          //
'// Версия 2.2                                  //
'/////////////////////////////////////////////////
 
' Декларации API...
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoW" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long
 
' Константы
Private Const SETDESKWALLPAPER = &H14
Private Const UPDATEINIFILE = &H1
 
' Изменение обоев на рабочем столе
Public Function SetWallpaper(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    
    RetVal = SystemParametersInfo(SETDESKWALLPAPER, 0, StrPtr(FileName), UPDATEINIFILE)
    If RetVal = 1 Then SetWallpaper = True
End Function
 
' Изменение обоев на рабочем столе с конвертацией в BMP
Public Function SetWallpaperAndConvertToBMP(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    Dim WshShell As Object
    Dim pathStr As String
    
    pathStr = Environ("windir")
    If Right$(pathStr, 1) = "\" Then pathStr = Mid$(pathStr, 1, Len(pathStr) - 1)
    pathStr = pathStr & "\wall.bmp"
    
    SavePicture LoadPicture(FileName), pathStr ' Конвертировать в BMP
    RetVal = SystemParametersInfo(SETDESKWALLPAPER, 0, StrPtr(pathStr), UPDATEINIFILE)
    
    If RetVal = 1 Then
        Set WshShell = CreateObject("WScript.Shell")
        WshShell.RegWrite "HKCU\Control Panel\Desktop\Wallpaper", FileName, "REG_SZ"
        SetWallpaperAndConvertToBMP = True
    End If
End Function

Option Explicit
'/////////////////////////////////////////////////
'// Модуль для изменения обоев на рабочем столе //
'// Copyright (c) 01.08.2023 by HackerVlad      //
'// e-mail: vladislavpeshkov@yandex.ru          //
'// Версия 3.0                                  //
'/////////////////////////////////////////////////
 
' Декларации API...
Private Declare Function SystemParametersInfoW Lib "user32" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long
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 Declare Function GetMem4 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
 
' Константы
Private Const SETDESKWALLPAPER = &H14
Private Const UPDATEINIFILE = &H1
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 SetWallpaperUniversal(ByVal FileName As String) As Boolean
    If SetWallpaper(FileName) = False Then
        If ActiveDesktopSetWallpaper(FileName) = True Then
            SetWallpaperUniversal = True
        End If
    Else
        SetWallpaperUniversal = True
    End If
End Function
 
' Изменение обоев на рабочем столе
Public Function SetWallpaper(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    
    RetVal = SystemParametersInfoW(SETDESKWALLPAPER, 0, StrPtr(FileName), UPDATEINIFILE)
    If RetVal = 1 Then SetWallpaper = True
End Function
 
' Изменение обоев на рабочем столе с помощью интерфейса IActiveDesktop
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
    
    ' Создать экземпляр IActiveDesktop
    ' (Set IActiveDesktop = New IActiveDesktop)
    hRes = CoCreateInstance(classid, 0, CLSCTX_INPROC_SERVER, iid, VarPtr(obj))
    If hRes <> 0 Then
        Exit Function
    End If
    
    GetMem4 ByVal obj, vtblptr
    RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)
    
    ' IActiveDesktop::SetWallpaper
    ' Первым параметром всегда является указатель на объект
    ' Возвращаемое значение всегда должно быть HRESULT (0 = S_OK)
    hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
    If hRes = 0 Then
        ActiveDesktopSetWallpaper = True
    End If
    
    ' IActiveDesktop::ApplyChanges
    hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE)
    
    ' Освободить память
    ' (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)
    GetMem4 lng, ByVal pASM
    pASM = pASM + 4
End Sub
 
Private Sub AddByte(pASM As Long, bt As Byte)
    GetMem1 bt, ByVal pASM
    pASM = pASM + 1
End Sub

Sub SetWallpaper(FileName)    
    On Error Resume Next
    Set oShA = oShA.Windows.Item.document.Application
    If Not IsObject(oSHA) Then _
    Set oShA = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}").document.Application
    On Error GoTo 0: Er = Not IsObject(oSHA)
    If Er Then Set oShA = CreateObject("Shell.Application")
    oShA.NameSpace(0).ParseName(FileName).InvokeVerb "setdesktopwallpaper"
    If Er Then WSH.Sleep 4000
    Set oFSO = Nothing: Set oShA = Nothing
End Sub

Public Sub SetWallpaperFlasherX(FileName)
    Dim oShA, Er, oFSO
    
    Set oShA = CreateObject("Shell.Application")
    
    On Error Resume Next
    Set oShA = oShA.Windows.Item.document.Application
    If Not IsObject(oShA) Then _
    Set oShA = GetObject("new:{C08AFD90-F2A1-11D1-8455-00A0C91F3880}").document.Application
    On Error GoTo 0: Er = Not IsObject(oShA)
    If Er Then Set oShA = CreateObject("Shell.Application")
    oShA.NameSpace(0).ParseName(FileName).InvokeVerb "setdesktopwallpaper"
    
    Set oShA = Nothing
End Sub

Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
Public Sub EnableActiveDesktop()
    Dim result As Long
    
    SendMessageTimeout FindWindow("Progman", vbNullString), &H52C, ByVal 0&, ByVal 0&, ByVal 0&, 500, result
End Sub

Option Explicit
'/////////////////////////////////////////////////
'// Модуль для изменения обоев на рабочем столе //
'// Copyright (c) 15.07.2024 by HackerVlad      //
'// e-mail: vladislavpeshkov@yandex.ru          //
'// Версия 3.5                                  //
'/////////////////////////////////////////////////
 
' Декларации API...
Private Declare Function SystemParametersInfoW Lib "user32" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Long, ByVal fuWinIni As Long) As Long
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 Declare Function GetMem4 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function GetMem1 Lib "msvbvm60" (srcAddr As Any, dstValue As Long) As Long
Private Declare Function IsFileAPI Lib "shlwapi" Alias "PathFileExistsW" (ByVal pszPath As Long) As Long
Private Declare Function SendMessageTimeout Lib "user32" Alias "SendMessageTimeoutA" (ByVal hwnd As Long, ByVal msg As Long, ByVal wParam As Long, ByVal lParam As Long, ByVal fuFlags As Long, ByVal uTimeout As Long, lpdwResult As Long) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
 
' Константы
Private Const SETDESKWALLPAPER = &H14
Private Const SPI_GETDESKWALLPAPER = 115
Private Const MAX_PATH As Long = 260
Private Const UPDATEINIFILE = &H1
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 SetWallpaperUniversal(ByVal FileName As String) As Boolean
    If IsFileAPI(StrPtr(FileName)) = 0 Then ' Файл не существует, с вероятностью 99%
        Exit Function
    End If
    
    If SetWallpaper(FileName) = False Then
        If ActiveDesktopSetWallpaper(FileName) = True Then
            SetWallpaperUniversal = True
        End If
    Else
        SetWallpaperUniversal = True
    End If
End Function
 
' Изменение обоев на рабочем столе
Public Function SetWallpaper(ByVal FileName As String) As Boolean
    Dim RetVal As Long
    
    RetVal = SystemParametersInfoW(SETDESKWALLPAPER, 0, StrPtr(FileName), UPDATEINIFILE)
    If RetVal = 1 Then SetWallpaper = True
End Function
 
' Получение пути и имени файла к обоям на рабочем столе
Public Function GetWallpaper() As String
    Dim RetVal As Long
    Dim str As String
    Dim lNullPos As Long
    
    str = Space$(MAX_PATH)
    
    RetVal = SystemParametersInfoW(SPI_GETDESKWALLPAPER, MAX_PATH, StrPtr(str), 0)
    
    If RetVal Then
        lNullPos = InStr(1, str, vbNullChar)
        If lNullPos Then
            str = Left$(str, lNullPos - 1)
        End If
        GetWallpaper = str
    End If
End Function
 
' Включить ActiveDesktop для того чтобы картинка на рабочем столе появлялась с красивым fade эффектом
Public Sub EnableActiveDesktop()
    Dim result As Long
    
    SendMessageTimeout FindWindow("Progman", vbNullString), &H52C, ByVal 0&, ByVal 0&, ByVal 0&, 500, result
End Sub
 
' Изменение обоев на рабочем столе с помощью интерфейса IActiveDesktop
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
    
    If IsFileAPI(StrPtr(strFile)) = 0 Then ' Файл не существует, с вероятностью 99%
        Exit Function
    End If
    
    ' 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
    
    ' Создать экземпляр IActiveDesktop
    ' (Set IActiveDesktop = New IActiveDesktop)
    hRes = CoCreateInstance(classid, 0, CLSCTX_INPROC_SERVER, iid, VarPtr(obj))
    If hRes <> 0 Then
        Exit Function
    End If
    
    GetMem4 ByVal obj, vtblptr
    RtlMoveMemory vtbl, ByVal vtblptr, Len(vtbl)
    
    ' IActiveDesktop::SetWallpaper
    ' Первым параметром всегда является указатель на объект
    ' Возвращаемое значение всегда должно быть HRESULT (0 = S_OK)
    hRes = CallPointer(vtbl.SetWallpaper, obj, StrPtr(strFile), 0)
    If hRes = 0 Then
        ActiveDesktopSetWallpaper = True
    End If
    
    ' IActiveDesktop::ApplyChanges
    hRes = CallPointer(vtbl.ApplyChanges, obj, AD_APPLY_ALL Or AD_APPLY_FORCE Or AD_APPLY_BUFFERED_REFRESH)
    
    ' Освободить память
    ' (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)
    GetMem4 lng, ByVal pASM
    pASM = pASM + 4
End Sub
 
Private Sub AddByte(pASM As Long, bt As Byte)
    GetMem1 bt, ByVal pASM
    pASM = pASM + 1
End Sub