VBA-Code anpassen für 64-bit
10.07.2023 10:53:49
Kisska
Hallo zusammen,
ich möchte einen älteren Code verwenden, der mal in diesem Beitrag gepostet wurde:
https://www.herber.de/forum/cgi-bin/callthread.pl?index=1686150#1686256
Es erscheint ein Fehler bei diesem Teil des Codes:
Option Explicit
Private Declare Function FindExecutableA Lib "shell32.dll" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare Function LockWindowUpdate Lib "user32.dll" ( _
ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Fehlermeldung:
"Fehler beim Kompilieren:
Der Code in diesem Projekt muss für die Verwendung auf 64-Bit-Systemen aktualisiert werden. Überarbeiten und aktualisieren Sie Declare-Anweisungen, und markieren Sie sie mit dem PtrSafe-Attribut."
Ich habe den o.a. Code dann wie folgt ergänzt:
#If VBA7 Then
Private Declare PtrSafe Function FindExecutableA Lib "shell32.dll" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32.dll" ( _
ByVal hwndLock As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long
#Else
Private Declare Function FindExecutableA Lib "shell32.dll" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare Function LockWindowUpdate Lib "user32.dll" ( _
ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
#End If
Aber dann kommt wieder eine Fehlermeldung, dass das Objekt nicht eingefügt werden kann.
Debuggen führt mich zu diesem Teil des Codes:
Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
Link:=False, DisplayAsIcon:=True, IconIndex:=lngIconIndex, _
IconFileName:=strExecutable, IconLabel:=strDisplayName)
Mein Gesamtcode:
Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function FindExecutableA Lib "shell32.dll" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare PtrSafe Function LockWindowUpdate Lib "user32.dll" ( _
ByVal hwndLock As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As Long
#Else
Private Declare Function FindExecutableA Lib "shell32.dll" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As Long
Private Declare Function LockWindowUpdate Lib "user32.dll" ( _
ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
#End If
Private Const MAX_PATH As Long = 260&
Public Sub InsertFileObject()
Dim objOLEObject As OLEObject
Dim lngReturn As Long, lngIconIndex As Long
Dim strPath As String, strFilename As String, strDisplayName As String
Dim strTemp As String * MAX_PATH
Dim strExtension As String, strExecutable As String
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Title = "Add General Document"
.AllowMultiSelect = False
If .Show Then
strPath = .SelectedItems(1)
strExtension = Mid$(strPath, InStrRev(strPath, ".") + 1)
strFilename = Mid$(strPath, InStrRev(strPath, "\") + 1)
strFilename = Left$(strFilename, InStrRev(strFilename, ".") - 1)
lngReturn = FindExecutableA(strPath, vbNullString, strTemp)
If lngReturn > 32 Then
strExecutable = Left$(strTemp, InStr(strTemp & vbNullChar, vbNullChar) - 1)
Else
Call MsgBox("Kein Programm zum Öffnen gefunden.", vbCritical, "Programmabbruch")
Exit Sub
End If
strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
If StrPtr(strDisplayName) > 0 Then
If LCase$(strExtension) = "pdf" Then
lngIconIndex = 1
Else
lngIconIndex = 0
End If
Call LockWindowUpdate(GetDesktopWindow)
Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
Link:=False, DisplayAsIcon:=True, IconIndex:=lngIconIndex, _
IconFileName:=strExecutable, IconLabel:=strDisplayName)
objOLEObject.ShapeRange.AlternativeText = strFilename
Call LockWindowUpdate(0&)
Set objOLEObject = Nothing
End If
End If
End With
End Sub
Kann jemand helfen, den Code wieder ans Laufen zu bringen?
VG, Kisska