VB:更改桌面背景的例子

Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long

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

Const SPI_SETDESKWALLPAPER = 20
Const SPIF_SENDWININICHANGE = &H2
Const SPIF_UPDATEINIFILE = &H1
Const REG_SZ As Long = 1
Const HKEY_CURRENT_USER = &H80000001

Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey 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 RegSetValueExString Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, ByVal lpValue As String, ByVal cbData As Long) As Long

Private Declare Function RegSetValueExLong Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpValue As Long, ByVal cbData As Long) As Long

Private Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long, lPredefinedKey As Long)

  lRetVal = RegOpenKeyEx(lPredefinedKey, sKeyName, 0, KEY_ALL_ACCESS, hKey)
  lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting)
  RegCloseKey (hKey)
End Sub

Private Function SetValueEx(ByVal hKey As Long, sValueName As String, lType As Long, vValue As Variant) As Long
  Dim lValue As Long
  Dim sValue As String
  Select Case lType
    Case REG_SZ
          sValue = vValue & Chr$(0)
          SetValueEx = RegSetValueExString(hKey, sValueName, 0&, lType, sValue, Len(sValue))
    Case REG_DWORD, REG_BINARY
          lValue = vValue
          SetValueEx = RegSetValueExLong(hKey, sValueName, 0&, lType, lValue, 4)
  End Select
End Function

Private Sub Form_Load()
'取得windows目录
  Dim Path As String, strSave As String
  strSave = String(50, Chr$(0))
  Path = Left$(strSave, GetWindowsDirectory(strSave, Len(strSave)))
  '转换图片并保存到Windows目录下面
  Image1.Picture = LoadPicture(App.Path & "/四块式桌面.jpg")
  SavePicture Image1, Path & "/MyFlower.bmp"
  Dim aa As String
  '写入注册表
  '设定居中
  SetKeyValue "Control Panel/desktop", "TileWallpaper", "0", REG_SZ, HKEY_CURRENT_USER
  '设定平铺
  ' SetKeyValue "Control Panel/desktop","TileWallpaper", "1", REG_SZ, HKEY_CURRENT_USER
  '更换墙纸
  aa = Path & "/MyFlower.bmp"
  ChangeWP = SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, aa, 0)
  '在注册表中记录图片位置
  SetKeyValue "Control Panel/desktop", "Wallpaper", aa, REG_SZ, HKEY_CURRENT_USER
  Unload Me
  End Sub