VBA-Code anpassen für 64-bit

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

Hi,
Hab nur WIN64/Office 32Bit zur Verfügung, da läuft es so:


Option Explicit

Private Declare PtrSafe Function FindExecutable64 Lib "shell32.dll" Alias "FindExecutableA" ( _
ByVal lpFile As String, _
ByVal lpDirectory As String, _
ByVal lpResult As String) As LongPtr
Private Declare PtrSafe Function LockWindowUpdate64 Lib "user32.dll" Alias "LockWindowUpdate" ( _
ByVal hwndLock As LongPtr) As Long
Private Declare PtrSafe Function GetDesktopWindow64 Lib "user32.dll" Alias "GetDesktopWindow" () As LongPtr

Private Declare Function FindExecutable86 Lib "shell32.dll" _
  Alias "FindExecutableA" ( _
  ByVal lpFile As String, _
  ByVal lpDirectory As String, _
  ByVal lpResult As String) As Long
Private Declare Function LockWindowUpdate86 Lib "user32.dll" Alias "LockWindowUpdate" ( _
ByVal hwndLock As Long) As Long
Private Declare Function GetDesktopWindow86 Lib "user32.dll" Alias "GetDesktopWindow" () As Long
    
Private Declare Function lstrlen Lib "kernel32.dll" _
  Alias "lstrlenA" ( _
  ByVal lpString As Any) As Long
     
Private Const MAX_PATH As Long = 256
     
Public Function FindExecutableA(ByVal lpFile As String, _
    ByVal lpDirectory As String, _
    ByRef lpResult As String)
   If InStr(Application.Path, "x86") Then
       FindExecutableA = FindExecutable86(lpFile, lpDirectory, lpResult)
   Else
       FindExecutableA = FindExecutable64(lpFile, lpDirectory, lpResult)
   End If
End Function

Public Function LockWindowUpdate(ByVal hwndLock As Long)
    If InStr(Application.Path, "x86") Then
        LockWindowUpdate = LockWindowUpdate86(hwndLock)
    Else
        Dim hwndLockPtr As LongPtr
        hwndLockPtr = hwndLock
        LockWindowUpdate = LockWindowUpdate86(hwndLockPtr)
    End If
End Function

Public Function GetDesktopWindow()
    If InStr(Application.Path, "x86") Then
        GetDesktopWindow = GetDesktopWindow86()
    Else
        GetDesktopWindow = GetDesktopWindow64()
    End If
End Function

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 '
    Dim strExtension As String, strExecutable As String
    strTemp = Space(MAX_PATH)
    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, "", strTemp)
            If lngReturn > 32 Then
                strExecutable = Left$(strTemp, lstrlen(strTemp))
            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

hth
Ulf

Forumthread: VBA-Code anpassen für 64-bit

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial