Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1684to1688
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

VBA für Objekt einbetten

VBA für Objekt einbetten
09.04.2019 14:28:57
Kisska
Hallo zusammen,
könnte mir jemand helfen, folgendes VBA zu erweitern:
Sub Datei_Objekt_einbetten()
Dim varDatei As Variant
varDatei = Application.GetOpenFilename(FileFilter:="AlleDateien(*.*),*.*", _
Title:="Bitte einzubettende Datei auswählen")
If varDatei  False Then
ActiveSheet.OLEObjects.Add Filename:=varDatei, _
Link:=False, DisplayAsIcon:=True, IconFileName:="packager.dll", _
IconIndex:=0, _
IconLabel:=Mid(varDatei, InStrRev(varDatei, "\") + 1)
End If
End Sub

Quelle: https://www.herber.de/forum/archiv/1248to1252/1250201_Datei_als_Objekt_einbetten.html (Franz)
Folgende Erweiterungen hätte ich gerne:
1) Die Symbole sollen genau so aussehen, wenn man die Objekte über das Menü manuell einfügen würde. Bei dem Code oben wird für pdf und excel-Datei falsches Symbol verwendet.
2) Es soll nach der Datei-Auswahl eine Abfrage für Beschriftung kommen. Dabei soll bereits eine voreingestellte Beschriftung erscheinen (Dateiname ohne Pfad), die man frei editieren kann.
3) Der originale Dateiname soll als Alternativtext gespeichert werden. Manuell würde ich dies wie folgt machen: Rechte Maustaste auf das Objekt, dann Objekt formatieren, dann Alternativtext und zum Schluss den vorher kopierten Dateinamen einfügen.
VG, Kisska

14
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: VBA für Objekt einbetten
09.04.2019 15:05:18
Nepumuk
Hallo Kisska,
teste mal:
Option Explicit

Private Declare Function SHGetFileInfoA Lib "shell32.dll" ( _
    ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    ByRef psfi As ShellFileInfoType, _
    ByVal cbFileInfo As Long, _
    ByVal uFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef pDicDesc As IconType, _
    ByRef riid As CLSIdType, _
    ByVal fown As Long, _
    ByRef lpUnk As Object) As Long

Private Const MAX_PATH = 260&
Private Const LARGE_ICON = &H100&
Private Const vbPicTypeIcon = 3

Private Type ShellFileInfoType
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type

Private Type IconType
    cbSize As Long
    picType As Long
    hIcon As Long
End Type

Private Type CLSIdType
    id(16) As Byte
End Type

Public Sub InsertFileObject()
    
    Dim udtShellInfo As ShellFileInfoType
    Dim udtIcon As IconType
    Dim udtCLSID As CLSIdType
    Dim objUnknown As IUnknown
    Dim strPath As String, strFilename As String
    Dim strDisplayName As String, strIconPath As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        .Filters.Clear
        .Title = "Add General Document"
        .AllowMultiSelect = False
        
        If .Show Then
            
            strPath = .SelectedItems(1)
            strFilename = Mid$(strPath, InStrRev(strPath, "\") + 1)
            strFilename = Left$(strFilename, InStrRev(strFilename, ".") - 1)
            
            strIconPath = Environ$("TMP") & "\Icon.ico"
            
            Call SHGetFileInfoA(strPath, 0, udtShellInfo, Len(udtShellInfo), LARGE_ICON)
            
            udtIcon.cbSize = Len(udtIcon)
            udtIcon.picType = vbPicTypeIcon
            udtIcon.hIcon = udtShellInfo.hIcon
            udtCLSID.id(8) = &HC0
            udtCLSID.id(15) = &H46
            
            Call OleCreatePictureIndirect(udtIcon, udtCLSID, 1, objUnknown)
            Call SavePicture(objUnknown, strIconPath)
            
            strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
            If StrPtr(strDisplayName) <> 0 Then
                
                Call ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strIconPath, IconLabel:=strDisplayName)
                
            End If
            
            Call Kill(strIconPath)
            
            Set objUnknown = Nothing
            
        End If
    End With
End Sub

Gruß
Nepumuk
Anzeige
AW: VBA für Objekt einbetten
09.04.2019 15:20:19
Nepumuk
Ooooooooooooops,
gerade schmeiß ich die Kaffeemaschine an da fällt mir ein, der "AlternativeText" fehlt.
Also:
Option Explicit

Private Declare Function SHGetFileInfoA Lib "shell32.dll" ( _
    ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    ByRef psfi As ShellFileInfoType, _
    ByVal cbFileInfo As Long, _
    ByVal uFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef pDicDesc As IconType, _
    ByRef riid As CLSIdType, _
    ByVal fown As Long, _
    ByRef lpUnk As Object) As Long

Private Const MAX_PATH = 260&
Private Const LARGE_ICON = &H100&
Private Const vbPicTypeIcon = 3

Private Type ShellFileInfoType
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type

Private Type IconType
    cbSize As Long
    picType As Long
    hIcon As Long
End Type

Private Type CLSIdType
    id(16) As Byte
End Type

Public Sub InsertFileObject()
    
    Dim udtShellInfo As ShellFileInfoType
    Dim udtIcon As IconType
    Dim udtCLSID As CLSIdType
    Dim objUnknown As IUnknown
    Dim objOLEObject As OLEObject
    Dim strPath As String, strFilename As String
    Dim strDisplayName As String, strIconPath As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        .Filters.Clear
        .Title = "Add General Document"
        .AllowMultiSelect = False
        
        If .Show Then
            
            strPath = .SelectedItems(1)
            strFilename = Mid$(strPath, InStrRev(strPath, "\") + 1)
            strFilename = Left$(strFilename, InStrRev(strFilename, ".") - 1)
            
            strIconPath = Environ$("TMP") & "\Icon.ico"
            
            Call SHGetFileInfoA(strPath, 0, udtShellInfo, Len(udtShellInfo), LARGE_ICON)
            
            udtIcon.cbSize = Len(udtIcon)
            udtIcon.picType = vbPicTypeIcon
            udtIcon.hIcon = udtShellInfo.hIcon
            udtCLSID.id(8) = &HC0
            udtCLSID.id(15) = &H46
            
            Call OleCreatePictureIndirect(udtIcon, udtCLSID, 1, objUnknown)
            Call SavePicture(objUnknown, strIconPath)
            
            strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
            If StrPtr(strDisplayName) <> 0 Then
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strIconPath, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strPath
                
            End If
            
            Call Kill(strIconPath)
            
            Set objUnknown = Nothing
            Set objOLEObject = Nothing
            
        End If
    End With
End Sub

Gruß
Nepumuk
Anzeige
2) perfekt, 1) & 3) optimieren
09.04.2019 15:34:24
Kisska
Hallo Nepumuk,
danke für die prompte Hilfe!
Punkt 2) ist perfekt umgesetzt!
Bei Punkt 1) sehen die Symbole nicht ganz so aus wie auf dem manuellen Weg, bspw. erscheinen die Symbole für Excel, pdf, Word und Text-Editor mit einem schwarzen Hintergrund und bei Word ist der Buchstabe W in Grün statt wie üblich in Blau.
Kann man die Symbole hübscher darstellen?
3) Der AlternativeText wird wie gewünscht angezeigt, allerdings mit dem Pfad. Was müsste ich im Code anpassen, um den Pfad zu löschen?
Eine Kleinigkeit noch:
Wenn ich bspw. eine Excel-Datei einbette, dann erscheint in Millisekunden zuerst ein großes Fenster, welches dann verschwindet. Es ist wie ein Flattern. Kann man das irgendwie vermeiden?
VG, Kisska
Anzeige
AW: 2) perfekt, 1) & 3) optimieren
09.04.2019 15:48:48
Nepumuk
Hallo Kisska,
die Icons hole ich mit einer Windows-Funktion aus der Datei. Auf dessen aussehen habe ich leider keinen Einfluss.
Auch das Verhalten von Excel (das aufgehen des Fensters) kann ich nicht beeinflussen. Aber du kannst ja mal mit abgeschalteten "ScreenUpdating" testen.
Die Icons sehen bei mir so aus:
Userbild
Also ganz normal.
Den "AlternativeText" kannst du so setzen:
objOLEObject.ShapeRange.AlternativeText = strFilename
Gruß
Nepumuk
3) super
09.04.2019 16:09:32
Kisska
Hallo Nepumuk,
danke, Punkt 3) ist nun auch perfekt.
Bzgl. Punkt 1): Bei mir sehen die Symbole weniger schön aus:
Userbild
komisch, dass die Anzeige bei uns unterschiedlich ist.
Ich habe auf deine Empfehlung
Application.ScreenUpdating = False
nach

Public Sub InsertFileObject()
und

Application.ScreenUpdating = True
vor

End Sub
gesetzt, aber gebracht hat es leider trotzdem nichts.
Danke für deine Hilfe!
VG, Kisska
Anzeige
AW: 3) super
09.04.2019 17:15:59
Nepumuk
Hallo Kisska,
besser bringe ich das nicht hin:
Option Explicit

Private Declare Function SHGetFileInfoA Lib "shell32.dll" ( _
    ByVal pszPath As String, _
    ByVal dwFileAttributes As Long, _
    ByRef psfi As ShellFileInfoType, _
    ByVal cbFileInfo As Long, _
    ByVal uFlags As Long) As Long
Private Declare Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
    ByRef pDicDesc As IconType, _
    ByRef riid As CLSIdType, _
    ByVal fown As Long, _
    ByRef lpUnk As Object) As Long
Private Declare Function FindExecutableA Lib "shell32.dll" ( _
    ByVal lpFile As String, _
    ByVal lpDirectory As String, _
    ByVal lpResult As String) As Long

Private Const MAX_PATH = 260&
Private Const LARGE_ICON = &H100&
Private Const vbPicTypeIcon = 3

Private Type ShellFileInfoType
    hIcon As Long
    iIcon As Long
    dwAttributes As Long
    szDisplayName As String * MAX_PATH
    szTypeName As String * 80
End Type

Private Type IconType
    cbSize As Long
    picType As Long
    hIcon As Long
End Type

Private Type CLSIdType
    id(16) As Byte
End Type

Public Sub InsertFileObject()
    
    Dim udtShellInfo As ShellFileInfoType
    Dim udtIcon As IconType
    Dim udtCLSID As CLSIdType
    Dim objUnknown As IUnknown
    Dim objOLEObject As OLEObject
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String
    Dim strDisplayName As String, strIconPath As String
    Dim strTemp As String * MAX_PATH, strExecutable As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        .Filters.Clear
        .Title = "Add General Document"
        .AllowMultiSelect = False
        
        If .Show Then
            
            strPath = .SelectedItems(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
                MsgBox "Kein Programm zum Öffnen gefunden.", vbCritical, "Programmabbruch"
                Exit Sub
            End If
            
            strIconPath = Environ$("TMP") & "\Icon.ico"
            
            Call SHGetFileInfoA(strExecutable, 0, udtShellInfo, Len(udtShellInfo), LARGE_ICON)
            
            udtIcon.cbSize = Len(udtIcon)
            udtIcon.picType = vbPicTypeIcon
            udtIcon.hIcon = udtShellInfo.hIcon
            udtCLSID.id(8) = &HC0
            udtCLSID.id(15) = &H46
            
            Call OleCreatePictureIndirect(udtIcon, udtCLSID, 1, objUnknown)
            Call SavePicture(objUnknown, strIconPath)
            
            strDisplayName = InputBox("Bitte Anzeigetext eingeben.", "Einagbe", strFilename)
            If StrPtr(strDisplayName) <> 0 Then
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strIconPath, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strFilename
                
            End If
            
            Call Kill(strIconPath)
            
            Set objUnknown = Nothing
            Set objOLEObject = Nothing
            
        End If
    End With
End Sub

Gruß
Nepumuk
Anzeige
AW: 3) super
09.04.2019 19:18:18
Nepumuk
Hallo Kisska,
ein bisschen mehr geht immer:
Option Explicit

Private Declare Function FindExecutableA Lib "shell32.dll" ( _
    ByVal lpFile As String, _
    ByVal lpDirectory As String, _
    ByVal lpResult As String) As Long

Private Const MAX_PATH As Long = 260&

Public Sub InsertFileObject()
    
    Dim objOLEObject As OLEObject
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String, strDisplayName As String
    Dim strTemp As String * MAX_PATH, strExecutable As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        .Filters.Clear
        .Title = "Add General Document"
        .AllowMultiSelect = False
        
        If .Show Then
            
            strPath = .SelectedItems(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
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strExecutable, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strFilename
                
            End If
            
            Set objOLEObject = Nothing
            
        End If
    End With
End Sub

Gruß
Nepumuk
Anzeige
endgültige Version
09.04.2019 19:49:22
Nepumuk
Hallo Kisska,
teste mal:
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

Private Const MAX_PATH As Long = 260&

Public Sub InsertFileObject()
    
    Dim objOLEObject As OLEObject
    Dim lngReturn As Long
    Dim strPath As String, strFilename As String, strDisplayName As String
    Dim strTemp As String * MAX_PATH, strExecutable As String
    
    With Application.FileDialog(msoFileDialogFilePicker)
        
        .Filters.Clear
        .Title = "Add General Document"
        .AllowMultiSelect = False
        
        If .Show Then
            
            strPath = .SelectedItems(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
                
                Call LockWindowUpdate(GetDesktopWindow)
                
                Set objOLEObject = ActiveSheet.OLEObjects.Add(Filename:=strPath, _
                    Link:=False, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=strExecutable, IconLabel:=strDisplayName)
                objOLEObject.ShapeRange.AlternativeText = strFilename
                
                Call LockWindowUpdate(0&)
                
                Set objOLEObject = Nothing
                
            End If
        End If
    End With
End Sub

Gruß
Nepumuk
Anzeige
großartig!
09.04.2019 20:10:31
Kisska
Jetzt ist es perfekt!
Die Symbole sehen gut aus und beim Laden der Excel-Datei sieht man keine temporär erscheinendes Fenster.
Herzlichen Dank, Nepumuk!
VG, Kisska
kurze Rückfrage
09.04.2019 21:31:38
Kisska
Hallo Nepumuk,
ich habe noch eine kurze Rückfrage: Du hast IconIndex:=0 gewählt. Ist es möglich nur für pdf-Dateien IconIndex:=1 zu machen und für andere Datei-Typen IconIndex:=0?
VG, Kisska
AW: kurze Rückfrage
10.04.2019 04:37:15
Nepumuk
Hallo Kisska,
so:
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

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$(strExecutable) = "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

Gruß
Nepumuk
Anzeige
klappt nicht
10.04.2019 22:47:00
Kisska
Hallo Nepumuk,
die Bedingung für pdf scheint nicht zu klappen. Könntest du bitte nachprüfen?
VG, Kisska
AW: klappt nicht
11.04.2019 08:31:47
Nepumuk
Hallo Kisska,
mein Fehler. Andere diese Zeile:
If LCase$(strExecutable) = "pdf" Then
so:
If LCase$(strExtension) = "pdf" Then
Gruß
Nepumuk
Einfach mega!
12.04.2019 02:29:23
Kisska
1000 x Danke, Nepumuk!
VG, Kisska

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige