Option Explicit
注册表:
Private Declare Function RegCreateKey Lib "advapi32.dll" Alias "RegCreateKeyA" (ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
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 Const HKEY_CURRENT_USER = H80000001
Private Const HKEY_LOCAL_MACHINE = H80000002
Private Const REG_SZ = 1
----------------------------------------------------------
获取Windows目录:
Private Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
Private Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long
------------------------------------------------------------
浏览文件夹
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_BROWSEFORCOMPUTER = H1000
Private Const BIF_BROWSEFORPRINTER = H2000
Private Const BIF_BROWSEINCLUDEFILES = H4000
Private Const BIF_DONTGOBELOWDOMAIN = H2
Private Const BIF_EDITBOX = H10
Private Const BIF_RETURNFSANCESTORS = H8
Private Const BIF_RETURNONLYFSDIRS = H1
Private Const BIF_STATUSTEXT = H4
Private Const BIF_USENEWUI = H40
Private Const BIF_VALIDATE = H20
------------------------------------------------------------
切换当前壁纸
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 Const SPI_SETDESKWALLPAPER = 20
Private Const SPIF_SENDWININICHANGE = H2
Private Const SPIF_UPDATEINIFILE = H1
Dim Arry() As String, PicCounts As Integer
Dim fso As New FileSystemObject, WinPath As String
Sub SetWallPaperReg(strNull As String)
Dim Ret2 As Long
RegOpenKey HKEY_CURRENT_USER, "Control PanelDesktop", Ret2
RegSetValueEx Ret2, "Wallpaper", 0, REG_SZ, ByVal strNull, 255 清除当前壁纸
RegCloseKey Ret2 关闭注册表句柄
End Sub
Private Sub Form_Load()
Dim s As String * 80, Length As Long
Length = GetWindowsDirectory(s, Len(s))
WinPath = Left(s, Length)
Me.Hide
If Not Command = "Start" Then
------------------------------------------------------------------------
浏览文件夹
Dim WallPath As String, Ret As Long, MyPath As String
ReSelect:
WallPath = BrowseFolder(Me.hWnd)
If WallPath = "" Then End
If GetFileList(WallPath) = True Then
SaveSetting "Wallpaper", "Set", "Path", WallPath
SaveSetting "Wallpaper", "Set", "Counts", "0"
写注册表
MyPath = App.Path "wallpaper.exe Start"
RegOpenKey HKEY_LOCAL_MACHINE, "SOFTWAREMicrosoftWindowsCurrentVersionRun", Ret
RegSetValueEx Ret, "Wallpaper Start", 0, REG_SZ, ByVal MyPath, 255 自动启动本程序
RegCloseKey Ret
SetWallPaper 设置壁纸(Count=1)
SetWallPaperReg (WinPath "WallPaper.bmp") 设置当前壁纸注册表
SystemParametersInfo SPI_SETDESKWALLPAPER, 0, WinPath "WallPaper.bmp", 0 刷新当前壁纸
SetWallPaper 设置壁纸(Count=2,以备首次设置后更改)
MsgBox "设置完毕，祝使用愉快～～"
Else
MsgBox "选择的文件夹中没有图形文件,请重新选择!"
GoTo ReSelect
End If
Else
SystemParametersInfo SPI_SETDESKWALLPAPER, 0, WinPath "WallPaper.bmp", 0 刷新当前壁纸
SetWallPaper 设置壁纸
End If
End
End Sub
Sub SetWallPaper()
Dim GV As String, GC As String, xFile As String
GV = GetSetting("Wallpaper", "Set", "Path")
If GV "" Then
If fso.FolderExists(GV) Then
If GetFileList(GV) = True Then
GC = GetSetting("Wallpaper", "Set", "Counts")
PicCounts = GC + 1
If PicCounts UBound(Arry) Then PicCounts = 1
SaveSetting "Wallpaper", "Set", "Counts", PicCounts
Set Picture1.Picture = LoadPicture(GV "" Arry(PicCounts))
xFile = WinPath "WallPaper.bmp"
SavePicture Picture1.Picture, xFile
End If LoadIt?
Else fso Check?
MsgBox "桌面墙纸文件夹已被删除或改变？请重新设置."
Me.Show
End If fso check?
End If GV?
End Sub
Function GetFileList(folder As String) As Boolean
Dim F As Object, FC As Object, Counts As Integer, F1 As Variant, F2 As String, LoadIt As Boolean
Set F = fso.GetFolder(folder)
Set FC = F.Files
Counts = 0
ReDim Preserve Arry(0)
LoadIt = False
For Each F1 In FC
F2 = UCase(Right(F1.Name, 3))
If F2 = "BMP" Or F2 = "JPG" Or F2 = "GIF" Then
Counts = Counts + 1
ReDim Preserve Arry(Counts)
Arry(Counts) = F1.Name
LoadIt = True
End If
Next
If LoadIt Then GetFileList = True Else GetFileList = False
End Function
Function BrowseFolder(Optional hWnd As Long) As String
Dim bi As BROWSEINFO
Dim pidl As Long
Dim folder As String
folder = String(255, vbNullChar)
With bi
.hOwner = hWnd
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_USENEWUI Or BIF_EDITBOX
.pidlRoot = 0
.lpszTitle = "请选择作为桌面墙纸的图片文件夹:" vbNullChar
End With
pidl = SHBrowseForFolder(bi)
If SHGetPathFromIDList(ByVal pidl, ByVal folder) Then
BrowseFolder = Left(folder, InStr(folder, vbNullChar) - 1)
Else
BrowseFolder = ""
End If
End Function
