Attribute VB_Name = "modDeskShots"
Option Explicit
Const HKEY_CURRENT_USER = &H80000001
Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1
Public Declare Function SystemParametersInfo Lib "USER32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As Long
Public Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hkey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Public Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpData As String, ByVal cbData As Long) As Long
Public Declare Function RegFlushKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hkey As Long) As Long
Private Type SHITEMID
    cb      As Long    'Size of the ID (including cb itself)
    abID    As Byte    'The item ID (variable length)
End Type

Private Type ITEMIDLIST
    mkid    As SHITEMID
End Type
Public Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Public Declare Function GetWindowsDirectoryA Lib "kernel32" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Public ShowInfo As Boolean

' Routine to change the windows wallpaper.
' Call - ChangeWallPaper "c:\winnt\hello.bmp","Stretch"
' First param is name (and path) of required bmp.
' Second param is display type flag (either "Center", "Stretch" or "Tile" or "Clear" to clear the paper).
'
Public Sub SetWallPaper(ByVal DisplayType As String, ByVal sFile As String, Pic As PictureBox, ByVal Idx As Long)
Dim Newpaper As String
    On Error Resume Next
        If InStr(LCase$(sFile), ".png") Or InStr(LCase$(sFile), ".tif") Then
            Set Pic.Picture = LoadPictureEx(sFile)
        Else
            Set Pic.Picture = LoadPicture(sFile)
        End If
                If Pic.Picture Is Nothing Then
                    Set Pic.Picture = LoadPictureEx(sFile)
                End If
'            Pic.AutoRedraw = True
    Newpaper = GetWindowsDirectory & "DeskShots.bmp"
            SavePicture Pic.Picture, Newpaper
                Set Pic.Picture = Nothing
    If DisplayType = "Center" Or DisplayType = "Clear" Then
       WriteRegistry HKEY_CURRENT_USER, "Control Panel\Desktop", "TileWallpaper", "0"
       WriteRegistry HKEY_CURRENT_USER, "Control Panel\Desktop", "WallpaperStyle", "0"
    ElseIf DisplayType = "Tile" Then
       WriteRegistry HKEY_CURRENT_USER, "Control Panel\Desktop", "TileWallpaper", "1"
       WriteRegistry HKEY_CURRENT_USER, "Control Panel\Desktop", "WallpaperStyle", "0"
    ElseIf DisplayType = "Stretch" Then
       WriteRegistry HKEY_CURRENT_USER, "Control Panel\Desktop", "TileWallpaper", "0"
       WriteRegistry HKEY_CURRENT_USER, "Control Panel\Desktop", "WallpaperStyle", "2"
    End If
    If DisplayType = "Clear" Then
        SystemParametersInfo SPI_SETDESKWALLPAPER, 0&, ByVal vbNullString, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE
        SystemParametersInfo SPI_SETDESKWALLPAPER, 0&, " ", SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE
    Else
        SystemParametersInfo SPI_SETDESKWALLPAPER, 0&, Newpaper, SPIF_UPDATEINIFILE Or SPIF_SENDWININICHANGE
    End If
If NotifyAdded = True Then
    Dim hIcon As Long
        hIcon = ImageList_GetIcon(hIml, Thumbs(Idx).hBmp, ILD_NORMAL)
            If hIcon = 0 Then hIcon = frmDeskShots.Icon.handle
    If ShowInfo = True Then
        ShowBalloon sFile, App.Title & " - wallpaper changed", , hIcon
    Else
        ChangeIcon hIcon
    End If
        DestroyIcon hIcon
End If
End Sub

' Cut down version of the write routine in the registry module
Private Sub WriteRegistry(ByVal Group As Long, ByVal Section As String, ByVal Key As String, NewVal As String)
Dim lKeyValue As Long
Dim InLen As Long
On Error Resume Next
    RegOpenKey Group, Section, lKeyValue
    InLen = Len(NewVal)
    RegSetValueEx lKeyValue, Key, 0&, 1&, NewVal, InLen
    RegFlushKey lKeyValue
    RegCloseKey lKeyValue
End Sub

Public Function GetSpecialFolder(CSIDL As Long) As String
    Dim R As Long
    Dim IDL As ITEMIDLIST
    Dim Path As String
    'Get the special folder
    R = SHGetSpecialFolderLocation(100, CSIDL, IDL)
    If R = 0 Then 'hier stond NOERROR, maar wat was dat???
        'Create a buffer
        Path = Space$(512)
        'Get the path from the IDList
        R = SHGetPathFromIDList(ByVal IDL.mkid.cb, ByVal Path)
        'Remove the unnecessary chr$(0)'s
        GetSpecialFolder = left$(Path, InStr(Path, Chr$(0)) - 1)
        Exit Function
    End If
    GetSpecialFolder = ""
End Function
'
'  Returns the windows directory.
'
Public Function GetWindowsDirectory() As String
   Dim S As String
   Dim I As Integer
   I = GetWindowsDirectoryA("", 0)
   S = Space(I)
   Call GetWindowsDirectoryA(S, I)
   GetWindowsDirectory = AddBackslash(left$(S, I - 1))
End Function

'  Adds a backslash if the string doesn't have one already.
'
Public Function AddBackslash(S As String) As String
   If Len(S) > 0 Then
      If right$(S, 1) <> "\" Then
         AddBackslash = S + "\"
      Else
         AddBackslash = S
      End If
   Else
      AddBackslash = "\"
   End If
End Function


