[Webinar] Streamline your web hosting managementRegister Today

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 203
  • Last Modified:

API call ; I need to get the currentwallpaper ; This code may help

sorry i dont remembe where i got this code,,, but it dosnt work anyway (grin)
but im looking to get the currentwallpaper section to work, TIA

Description:
 Three functions, LoadWallpaper, ResetWallpaper, and CurrentWallpaper do what their name implies.
 
Code:
 Option Explicit

Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_UPDATEINIFILE = &H1
Private Const HKEY_CURRENT_USER = &H80000001
Private Const REG_SZ = 1

Private 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
   
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias _
   "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, _
   ByVal lpReserved As Long, lpType As Long, ByVal lpData As String, _
   lpcbData As Long) As Long
   
Private Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias _
   "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, _
   ByVal ulOptions As Long, ByVal samDesired As Long, _
   phkResult As Long) As Long
   
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey _
   As Long) As Long

Public Sub LoadWallpaper(sFilename As String)

    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, sFilename, _
                         SPIF_UPDATEINIFILE

End Sub

Public Sub ResetWallpaper()

    SystemParametersInfo SPI_SETDESKWALLPAPER, 0, CurrentWallpaper, 0

End Sub

Public Function CurrentWallpaper() As String

    Dim sValue As String
    Dim nReturn As Long
    Dim hKey As Long
   
    RegOpenKeyEx HKEY_CURRENT_USER, "Control panel\desktop", 0, 0, hKey
   
    nReturn = 1024
    sValue = Space(1024)
   
    RegQueryValueEx hKey, "Wallpaper", 0, REG_SZ, sValue, nReturn

    sValue = Mid(sValue, 1, nReturn)

    RegCloseKey hKey

    CurrentWallpaper = sValue

End Function


 
 
Sample Usage:
 
 LoadWallpaper "c:\windows\clouds.bmp"

 
0
5thcav
Asked:
5thcav
  • 2
1 Solution
 
softplusCommented:
(stolen from http://www.freevbcode.com/ShowCode.asp?ID=4487 ) :)

Imports Microsoft.Win32
    Public Function RegValue(ByVal Hive As RegistryHive, _
       ByVal Key As String, ByVal ValueName As String, _
       OptionalByRef ErrInfo As String = "") As String
 
      'DEMO USAGE

        'Dim sAns As String
        'Dim sErr As String = ""

        'sAns = RegValue(RegistryHive.LocalMachine, _
        '  "SOFTWARE\Microsoft\Windows\CurrentVersion", _
        '  "ProgramFilesDir", sErr)
        'If sAns <> "" Then
        '    Debug.WriteLine("Value = " & sAns)
        'Else
        '    Debug.WriteLine("This error occurred: " & sErr)

        'End If

        Dim objParent As RegistryKey
        Dim objSubkey As RegistryKey
        Dim sAns As String
        Select Case Hive
            Case RegistryHive.ClassesRoot
                objParent = Registry.ClassesRoot
            Case RegistryHive.CurrentConfig
                objParent = Registry.CurrentConfig
            Case RegistryHive.CurrentUser
                objParent = Registry.CurrentUser
            Case RegistryHive.DynData
                objParent = Registry.DynData
            Case RegistryHive.LocalMachine
                objParent = Registry.LocalMachine
            Case RegistryHive.PerformanceData
                objParent = Registry.PerformanceData
            Case RegistryHive.Users
                objParent = Registry.Users

        End Select

        Try
            objSubkey = objParent.OpenSubKey(Key)
            'if can't be found, object is not initialized
            If Not objSubkey Is Nothing Then
                sAns = (objSubkey.GetValue(ValueName))
            End If

        Catch ex As Exception

            ErrInfo = ex.Message
        Finally

            'if no error but value is empty, populate errinfo
            If ErrInfo = "" And sAns = "" Then
                ErrInfo = _
                   "No value found for requested registry key"
            End If
        End Try
        Return sAns
    End Function

Now adjust your function:
Public Function CurrentWallpaper() As String
        Dim sAns As String
        Dim sErr As String = ""

        sAns = RegValue(RegistryHive.CurrentUser,  "Control Panel\Desktop", "Wallpaper", sErr)
        If sAns <> "" Then
            Return sAns
        Else
            Return "" ' error in sErr, could raise one if you wanted to
        End If
End Function


Good? :)
0
 
5thcavAuthor Commented:
we will soon see! :)
0
 
5thcavAuthor Commented:
Thanks
0

Featured Post

The 14th Annual Expert Award Winners

The results are in! Meet the top members of our 2017 Expert Awards. Congratulations to all who qualified!

  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now