VBA XLS AutoChange Desktop Image

Fehler beim Kompilieren: Der Code in diesem Projekt muss für die Verwendung von 64-Bit-Systemen aktualisiert werden. Überarbeiten und aktualisieren Sie Declare-Anweisungen und markieren Sie sie mit dem PtrSafe-Attribut.

'Quelle:
'http://www.office-loesung.de/ftopic662414_0_0_asc.php
Option Explicit
Option Private Module
Private Declare Function SystemParametersInfoA Lib "user32.dll" ( _
ByVal uAction As Long, _
ByVal uParam As Long, _
ByVal lpvParam As Any, _
ByVal fuWinIni As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" ( _
ByRef PicDesc As PIC_DESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
ByRef IPic As IPictureDisp) As Long
Private Declare Function CopyImage Lib "user32.dll" ( _
ByVal handle As Long, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
ByVal hWnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Integer) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As Long) As Long
Private Declare Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Any, _
ByRef pCLSID As GUID) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PIC_DESC
lngSize As Long
lngType As Long
lnghPic As Long
lnghPal As Long
End Type
Private Const PICTYPE_BITMAP As Long = 1
Private Const CF_BITMAP As Long = 2
Private Const IMAGE_BITMAP As Long = 0
Private Const LR_COPYRETURNORG  As Long = &H4
Private Const SPI_SETDESKWALLPAPER As Long = 20
Private Const SPIF_SENDWININICHANGE As Long = &H2
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Private llngCopy As Long
Private Function Paste_Picture() As IPictureDisp
Dim lngReturn As Long, lngPointer As Long
If CBool(IsClipboardFormatAvailable(CF_BITMAP)) Then
lngReturn = OpenClipboard(Application.Hwnd)
If lngReturn > 0 Then
lngPointer = GetClipboardData(CF_BITMAP)
llngCopy = CopyImage(lngPointer, _
IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call CloseClipboard
If lngPointer  0 Then Set Paste_Picture = _
Create_Picture(llngCopy, 0&, CF_BITMAP)
End If
End If
End Function
Private Function Create_Picture( _
ByVal lnghPic As Long, _
ByVal lnghPal As Long, _
ByVal lngPicType As Long) As IPictureDisp
Dim udtPicInfo As PIC_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
Call CLSIDFromString(StrPtr( _
GUID_IPICTUREDISP), udtID_IDispatch)
With udtPicInfo
.lngSize = Len(udtPicInfo)
.lngType = PICTYPE_BITMAP
.lnghPic = lnghPic
.lnghPal = lnghPal
End With
Call OleCreatePictureIndirect(udtPicInfo, _
udtID_IDispatch, 0&, objPicture)
Set Create_Picture = objPicture
Set objPicture = Nothing
End Function
Public Sub Desk_Images()
Call CreateDesktopPicture("Desktop_NAME", Tabelle1.Range("A4:F30"), True)
End Sub
Private Sub CreateDesktopPicture(ByVal pvstrFileName As String, _
ByRef probjRange As Range, ByVal pvblnShowOnDesktop As Boolean)
Dim strFirstFileName As String, strSecondFileName As String
Dim objPicture As IPictureDisp
Dim objImageFile As Object
Dim objImageProcess As Object
Call OpenClipboard(Application.Hwnd)
Call EmptyClipboard
Call CloseClipboard
On Error Resume Next
Do
DoEvents
Call probjRange.CopyPicture(Appearance:=xlScreen, Format:=xlBitmap)
If Err.Number = 0 Then Exit Do
Call Err.Clear
Loop
On Error GoTo 0
Set objPicture = Paste_Picture()
If Not objPicture Is Nothing Then
strFirstFileName = Environ$("TMP") & "\TMP.bmp"
Call SavePicture(Picture:=objPicture, Filename:=strFirstFileName)
strSecondFileName = "Beispiel-URL" & "\" & pvstrFileName & ".bmp"
If Dir$(PathName:=strSecondFileName)  vbNullString Then _
Call Kill(PathName:=strSecondFileName)
Set objImageFile = CreateObject(Class:="WIA.ImageFile")
Set objImageProcess = CreateObject(Class:="WIA.ImageProcess")
Call objImageFile.LoadFile(Filename:=strFirstFileName)
Call objImageProcess.Filters.Add(FilterID:=objImageProcess.FilterInfos("Crop").FilterID)
With objImageProcess.Filters(1)
.Properties("Top") = 1
.Properties("Bottom") = 0
.Properties("Left") = 1
.Properties("Right") = 0
End With
Set objImageFile = objImageProcess.Apply(Source:=objImageFile)
Call objImageFile.SaveFile(Filename:=strSecondFileName)
Set objImageFile = Nothing
Set objImageProcess = Nothing
If pvblnShowOnDesktop Then Call SystemParametersInfoA(SPI_SETDESKWALLPAPER, _
0&, strSecondFileName, SPIF_SENDWININICHANGE)
Call Kill(PathName:=strFirstFileName)
Else
MsgBox "Error - table can't show on desktop", vbCritical, "Error"
End If
Call DeleteObject(llngCopy)
End Sub