自动更换壁纸vb代码

从网上找到很多有关设置壁纸的代码,但它们好像都有些小的缺陷,至少在我的电脑上都经过修改才能调试通过,所以我写了下面一段代码,取各家之长,应该没问题.

'有关系统设置的声明
Private Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_SENDWININICHANGE = &H2
Private Const SPIF_UPDATEINIFILE = &H1
Private Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByValfuWinIni As Long) As Long

'有关修改注册表的声明
Const REG_SZ As Long = 1
Const REG_BINARY = 3
Const REG_DWORD = 4
Const HKEY_CURRENT_USER = &H80000001
Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegSetValueEx Lib "advapi32.dll" Alias "RegSetValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long
Private Declare Function RegDeleteKey Lib "advapi32.dll" Alias "RegDeleteKeyA" (ByVal hKey As Long, ByVal lpSubKey As String) As Long
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Dim filearray() As String'文件名数组
Dim i As Integer
Dim path As String'保存壁纸文件夹路径的字符串
'自定义的修改注册表键值的函数
Private Sub setReg(rootstr As String, name As String, value As String, l As Long)
Dim hKey As Long
Dim temp As String * 255
temp = value & Chr$(0)
RegOpenKey HKEY_CURRENT_USER, rootstr, hKey
RegSetValueEx hKey, name, 0, REG_SZ, ByVal temp, l
RegCloseKey hKey
End Sub

'得到所有的壁纸文件名,将它们放入filearray
Private Sub dirpath()
Dim filenames As String
path = "C:/Documents and Settings/Administrator/My Documents/desktop_jpg/" '修改此句,用你的壁纸文件夹路径来替换
filenames = Dir(path + "*.jpg")
Do While filenames <> ""
i = i + 1
ReDim Preserve filearray(i)
filearray(i) = filenames
filenames = Dir '再次调用dir函数,此时可以不带参数
Loop
End Sub
Private Sub Form_Load()
Dim myvalue As Integer
Dim cureentpic As String
'设置程序为自启动
Dim hKey As Long
Dim temp As String * 255
temp = App.path + "/Autodesktop.exe" & Chr$(0)
RegOpenKey HKEY_CURRENT_USER, "SOFTWARE/Microsoft/Windows/CurrentVersion/Run", hKey
RegSetValueEx hKey, "auto", 0, REG_SZ, ByVal temp, 255
RegCloseKey hKey

dirpath
Randomize
myvalue = (i - 1) * Rnd + 1
'转换文件格式,从jpg格式到bmp格式
imgVector.Picture = LoadPicture(path + filearray(myvalue))
cureentpic = path + "my.bmp"
SavePicture imgVector, cureentpic
Call SystemParametersInfo(SPI_SETDESKWALLPAPER, 0, "", SPIF_UPDATEINIFILE)'清空壁纸设置
SystemParametersInfo SPI_SETDESKWALLPAPER, 0, ByVal cureentpic, SPIF_UPDATEINIFILE '更换壁纸
'设置壁纸为"拉伸"
setReg "Control Panel/Desktop", "TileWallpaper", "0", 4
setReg "Control Panel/Desktop", "WallpaperStyle", "2", 4
'保存壁纸的文件名到注册表
setReg "Control Panel/Desktop", "Wallpaper", cureentpic, 255
'关掉程序
End
End Sub