Antworten und eine Beispielarbeitsmappe zu Fragen zum Thema "Dateien" finden Sie hier: Hier klicken

Einbetten verschiedener Dateien

Bewerten Sie hier bitte das Excel-Portal

Der kurze Weg zum Ziel: Auftragsprogrammierung

Informationen und Beispiele zum Thema InputBox
Screenshot zu InputBox	InputBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema MsgBox
Screenshot zu MsgBox	MsgBox-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema CommandButton
Screenshot zu CommandButton	CommandButton-Seite mit Beispielarbeitsmappe aufrufen

Informationen und Beispiele zum Thema Label
Screenshot zu Label	Label-Seite mit Beispielarbeitsmappe aufrufen

Einbetten verschiedener Dateien

Einbetten verschiedener Dateien von jk vom 06.11.2020 13:25:25

AW: Einbetten verschiedener Dateien - von volti am 06.11.2020 14:08:32
- AW: Einbetten verschiedener Dateien - von jk am 10.11.2020 15:47:42
  - AW: Einbetten verschiedener Dateien - von volti am 10.11.2020 17:40:53
    - AW: Einbetten verschiedener Dateien - von jk am 11.11.2020 11:23:09
      - AW: Einbetten verschiedener Dateien - von jk am 11.11.2020 11:36:27
        
        AW: Einbetten verschiedener Dateien - von volti am 11.11.2020 14:34:12
        
        AW: Einbetten verschiedener Dateien - von jk am 11.11.2020 16:23:35
        
        AW: Einbetten verschiedener Dateien - von volti am 11.11.2020 16:50:04
        
        AW: Einbetten verschiedener Dateien - von jk am 17.11.2020 09:24:16

Betrifft: Einbetten verschiedener Dateien von: jk
Geschrieben am: 06.11.2020 13:25:25

Hallo zusammen,

ich habe eine Frage zum Einbetten von Dateien in Excel und hoffe darauf das mir jemand weiterhelfen kann:

Ich möchte gern mit einem CommandButton ein Auswahlfeld öffnen mit dessen Hilfe ich eine beliebige Datei auswählen und einbetten kann.

Diese soll dann in einen neunen Reiter abgelegt werden, dessen Name frei wählbar ist.

Ich habe das bisher nur mit einem PDF Dokument hinbekommen:


Sub Makro1()
        ' Anhang Reiter erstellen
        Sheets.Add After:=ActiveSheet
        Range("D13").Select
    On Error GoTo Fehler2
        neuname = InputBox("Bezeichnen Sie den Anhang", "", "hier eingeben")
        ActiveSheet.Name = neuname
   
        ' Einbetten
        ActiveSheet.OLEObjects.Add(ClassType:="AcroExch.Document.DC", Link:=False, _
        DisplayAsIcon:=False).Activate

    On Error GoTo Fehler
    MsgBox "Das Dokument wurde erfolgreich eingebettet"
    End
    Exit Sub
Fehler2:
        MsgBox "Abgebrochen", , ""
Fehler:
        MsgBox "Es ist ein Fehler aufgetreten"

End Sub

Es sollen aber auch Excel Dokumente zum Einbetten gehen.

Ist das möglich

Vielen Dank schonmal im Voraus

Josef

Betrifft: AW: Einbetten verschiedener Dateien
von: volti
Geschrieben am: 06.11.2020 14:08:32

Hallo Josef,

vielleicht ist diese Funktion für Dich interessant oder als Anregung hilfreich:

Code:
[Cc][+][-]
Option Explicit

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

Private Const MAX_PATH As Long = 260&

Public Sub InsertFileObjectNEU()
    
    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
    
    Dim vntItem As Variant
    Dim lngRow As Long, lngColumn As Long
    Dim lngMaxColumn As Long, lngMaxRow As Long
    Dim lngRowBegin As Long, lngColumnBegin As Long
    Dim bCheck As Boolean, bBesetzt As Boolean
    Dim oShape As Object, AC As Range
    
    lngRowBegin = 4
    lngColumnBegin = 2
    lngMaxColumn = 10
    lngMaxRow = 20

    With Application.FileDialog(msoFileDialogFilePicker)
  
      .Filters.Clear
      .Title = "Add General Document"
      .AllowMultiSelect = False
        
      If .Show Then
         For Each vntItem In .SelectedItems
        
           bCheck = False
           For lngRow = lngRowBegin To lngMaxRow Step 5
              For lngColumn = lngColumnBegin To lngMaxColumn Step 2
                  
                  Set AC = ActiveSheet.Cells(lngRow, lngColumn)
                  bBesetzt = False
                  
                  For Each oShape In ActiveSheet.Shapes
                     With oShape
                       If .Top > AC.Top - 2 And .Left > AC.Left - 2 _
                          And .Top < AC.Top + 5 And .Left < AC.Left + 5 Then
                          bBesetzt = True: Exit For
                       End If
                     End With
                  Next oShape
                  
                  If bBesetzt = False Then bCheck = True: Exit For

              Next lngColumn
              If bCheck = True Then Exit For
           Next lngRow
               
           strPath = .SelectedItems(1)
           If InStr(".pdf .xls xlsm xlsx xlsb .jpg", LCase(Right(strPath, 4))) > 0 Then
             
             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
                
                With objOLEObject
                    .Left = Columns(lngColumn).Left
                    .Top = Rows(lngRow).Top
                End With

                Call LockWindowUpdate(0&)
                
                Set objOLEObject = Nothing
             
             End If
                 
          Else
             Call MsgBox("Falsches Dateiformat!", vbCritical, "Programmabbruch")
             Exit Sub
           
           End If
         Next
      End If
        
    End With
   
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Betrifft: AW: Einbetten verschiedener Dateien
von: jk
Geschrieben am: 10.11.2020 15:47:42

Hallo volti,

vielen Dank für die Antwort.

Das muss ich mir erstmal in Ruhe anschauen.

Was genau macht der Erste Teil?
Option Explicit

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

Private Const MAX_PATH As Long = 260&

Nochmals vielen Dank für Deine Hilfe

Josef

Betrifft: AW: Einbetten verschiedener Dateien
von: volti
Geschrieben am: 10.11.2020 17:40:53

Hallo Josef,

der Code ist zunächst nur ein Beispielcode, wie Du eine beliebige Datei auswählen kannst und diese in eine Exceltabelle einbettest.

Da einige API-Funktionen benutzt werden, müssen diese zunächst deklariert werden.
Windows arbeitet bei Strings mit fester Länge, so dass vor dem Aufruf entsprechender Speicher bereitgestellt werden muss.
Const MAX_PATH As Long = 260& reseviert 260 Zeichen für die Rückgabe eines Pfades.

FindExecutable
Diese Funktion ermittelt zu einer vorhandenen Datei die verknüpfte Anwendung, die für die Einbettung benötigt wird.

LockWindowUpdate
Sperrt oder entsperrt zur Sicherheit das Zeichnen auf einem Fenster. Ggf. kann man das weglassen

Dieses Beispiel fügt auch (mehrere) Bilder auf dem nächsten freien Platz rechts des letzten Bildes bzw. in die nächste Zeile ein.
Hierfür sind die Parameter im oberen Bereich gedacht.
Und hierfür wird auch die Schleife For Each oShape benötigt, die feststellt, ob einem Feld schon eine Grafik abgelegt wurde.

Wenn Du noch mal genau mitteilst, wie Du das haben möchtest (festes Zielfeld, immer in Aktiver Tabelle, nur eine Einbettung usw.) und ggf. eine Datei hier hochlädst kann das auch genau auf Deine Bedürfnisse optimiert werden und ggf. Codeteile wegfallen...

viele Grüße
Karl-Heinz

Betrifft: AW: Einbetten verschiedener Dateien
von: jk
Geschrieben am: 11.11.2020 11:23:09

Hallo volti,

ich bin beeindruckt.
Das Ergebnis ist ja Wahnsinn.

Vielen Dank für Deine Hilfe.
Muss ich das Thema irgendwie schließen, da alle Anforderungen erfüllt sind?

Danke

Betrifft: AW: Einbetten verschiedener Dateien
von: jk
Geschrieben am: 11.11.2020 11:36:27

Hallo,

mir ist doch noch etwas eingefallen. Wenn ich die eingebetteten Dateien öffnen möchte, muss ein Doppelklick herhalten. Dabei werden auch die Positionsrahmen sichtbar und die schöne Anordnung geht kaputt.

Ist es möglich nach der Prozedur zum Einbetten noch ein Makro erstellt und dem Objekt zugewiesen wird der das einfache Öffnen per Klick erlaubt?

Beispiel:

ActiveSheet.Shapes.Range(Array("Object 4")).Select
Selection.Verb Verb:=xlPrimary

Dies sollte halt stets zugeordnet werden.

Oder geht das nicht?

Danke nochmal

Josef

Betrifft: AW: Einbetten verschiedener Dateien
von: volti
Geschrieben am: 11.11.2020 14:34:12

Danke Josef,

für die Anforderung. 😊

So etwas habe ich noch nie gemacht, aber es scheint zu funktionieren. Schau mal, ob es das ist, was Du Dir gewünscht hast. Ich habe es auch nur an einem Objekt getestet.

Code:
[Cc][+][-]
Option Explicit

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

Private Const MAX_PATH As Long = 260&

Public Sub DateiObjektEinbetten()
    
    Dim oOleObj As OLEObject
    Dim lReturn As Long, oRette As Range
    Dim sPath   As String, sFilename As String, sDisplayName As String
    Dim sTmp    As String * MAX_PATH, sExecutable As String
    
    Dim vItem As Variant
    Dim lRow As Long, lColumn As Long
    Dim lMaxColumn As Long, lMaxRow As Long
    Dim lRowBegin As Long, lColumnBegin As Long
    Dim bCheck As Boolean, bBesetzt As Boolean
    Dim oShape As Object, AC As Range
    
    lRowBegin = 4                   'Anfangszeile setzen
    lColumnBegin = 2                'Anfangsspalte setzen
    lMaxColumn = 10                 'Letzte mögliche Zeile setzen
    lMaxRow = 20                    'Letzte mögliche Spalte setzen

    With Application.FileDialog(msoFileDialogFilePicker)
  
      .Filters.Clear
      .Title = "Neues Dokument einbetten"
      .AllowMultiSelect = False     'Mehrere Dateien auswählbar?
        
      If .Show Then
         For Each vItem In .SelectedItems
        
           bCheck = False
           For lRow = lRowBegin To lMaxRow Step 5
              For lColumn = lColumnBegin To lMaxColumn Step 2
                  
                  Set AC = ActiveSheet.Cells(lRow, lColumn)
                  bBesetzt = False
                  
                  For Each oShape In ActiveSheet.Shapes
                     With oShape
                       If .Top > AC.Top - 2 And .Left > AC.Left - 2 _
                          And .Top < AC.Top + 5 And .Left < AC.Left + 5 Then
                          bBesetzt = True: Exit For
                       End If
                     End With
                  Next oShape
                  
                  If bBesetzt = False Then bCheck = True: Exit For

              Next lColumn
              If bCheck = True Then Exit For
           Next lRow
               
           sPath = .SelectedItems(1)
           If InStr(".pdf .xls xlsm xlsx xlsb .jpg", LCase(Right(sPath, 4))) > 0 Then
             
             sFilename = Mid$(sPath, InStrRev(sPath, "\") + 1)
             sFilename = Left$(sFilename, InStrRev(sFilename, ".") - 1)
            
             lReturn = FindExecutableA(sPath, vbNullString, sTmp)
            
             If lReturn > 32 Then
                 sExecutable = Left$(sTmp, InStr(sTmp & vbNullChar, vbNullChar) - 1)
             Else
                 Call MsgBox("Kein Programm zum Öffnen gefunden.", vbCritical, "Programmabbruch")
                 Exit Sub
             End If
            
             sDisplayName = InputBox("Bitte den Anzeigetext eingeben!", "Eingabe", sFilename)
             If StrPtr(sDisplayName) <> 0 Then
               
                Call LockWindowUpdate(GetDesktopWindow)
                
                Set oOleObj = ActiveSheet.OLEObjects.Add(Filename:=sPath, _
                    Link:=True, DisplayAsIcon:=True, IconIndex:=0, _
                    IconFileName:=sExecutable, IconLabel:=sDisplayName)
                oOleObj.ShapeRange.AlternativeText = sFilename
                
                With oOleObj
                    .Left = Columns(lColumn).Left
                    .Top = Rows(lRow).Top
                    Set oRette = ActiveCell
                    .Select
                    Selection.OnAction = ThisWorkbook.Name & "!" & "OeffneMich"
                    oRette.Select
                End With

                Call LockWindowUpdate(0&)
                
                Set oOleObj = Nothing
             
             End If
                 
          Else
             Call MsgBox("Falsches Dateiformat!", vbCritical, "Programmabbruch")
             Exit Sub
           
           End If
         Next
      End If
        
    End With
   
End Sub

Sub OeffneMich()
 Dim oRette As Range
   
 Set oRette = ActiveCell
 ActiveSheet.Shapes.Range(Array(Application.Caller)).Select
 Selection.Verb Verb:=xlPrimary
 oRette.Select
End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Betrifft: AW: Einbetten verschiedener Dateien
von: jk
Geschrieben am: 11.11.2020 16:23:35

Hallo volti,

nun ja.

Es funktioniert nur wenn ich das Makro "Sub OeffneMich()" dem Objekt manuell zuordne.
Traumhaft wäre es wenn diese Zuordnung bereits durch die Prozedur vorher übernommen wird.
Also eine Makrozuordnung durch Makro.

Oder begehe ich einen Fehler wenn ich das Makro "Sub OeffneMich()" im Objekt "Tabelle1" hinterlege?

Josef

Betrifft: AW: Einbetten verschiedener Dateien
von: volti
Geschrieben am: 11.11.2020 16:50:04

Hallo Josef,

die Zuordnung erfolgt durchaus durch das Makro und zwar hier und bei mir funktioniert es auch..

Code:

                 With oOleObj
                    .Left = Columns(lColumn).Left
                    .Top = Rows(lRow).Top
                    Set oRette = ActiveCell
                    .Select
                    Selection.OnAction = ThisWorkbook.Name & "!" & "OeffneMich"
                    oRette.Select
                End With

Allerdings habe ich es in einem normaen Modul und da solltest Du es auch hintun, denn ich bin mir nicht sicher, ob es in eine Tabellenmodul funktioniert.

viele Grüße
Karl-Heinz

Betrifft: AW: Einbetten verschiedener Dateien
von: jk
Geschrieben am: 17.11.2020 09:24:16

Hallo nochmal volti,

entschuldige bitte die verspätete Antwort.

Ich habe nun alles in ein Modul gepackt und erneut zugeordnet.

Nur wo muss ich diesen Teil einfügen:

With oOleObj
.Left = Columns(lColumn).Left
.Top = Rows(lRow).Top
Set oRette = ActiveCell
.Select
Selection.OnAction = ThisWorkbook.Name & "!" & "OeffneMich"
oRette.Select

End With

Ich finde die richtige Stelle leider nicht.

Viele Grüße und vielen Dank
Josef