'Option ExplicitPrivate Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As LongPrivate Declare Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByVal lpvParam As Any, ByVal fuWinIni As Long) As LongConst SPI_SETDESKWALLPAPER = 20Const SPIF_SENDWININICHANGE = &H2Const SPIF_UPDATEINIFILE = &H1Const REG_SZ As Long = 1'Const HKEY_CURRENT_USER = &H80000001Private Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As LongPrivate 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 LongPrivate 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 LongPrivate 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 LongPrivate Sub SetKeyValue(sKeyName As String, sValueName As String, vValueSetting As Variant, lValueType As Long, lPredefinedKey As String) lRetVal = RegOpenKeyEx(HKEY_CURRENT_USER, sKeyName, 0, KEY_ALL_ACCESS, hKey) lRetVal = SetValueEx(hKey, sValueName, lValueType, vValueSetting) RegCloseKey (hKey)End SubPrivate 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 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 SelectEnd FunctionPrivate 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 & "\MyFlower.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"End Sub

动画版