Microsoft Excel

Herbers Excel/VBA-Archiv

Informationen und Beispiele zum Thema InputBox
BildScreenshot zu InputBox InputBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema MsgBox
BildScreenshot zu MsgBox MsgBox-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema CommandButton
BildScreenshot zu CommandButton CommandButton-Seite mit Beispielarbeitsmappe aufrufen
Informationen und Beispiele zum Thema Label
BildScreenshot zu Label Label-Seite mit Beispielarbeitsmappe aufrufen

Einbetten verschiedener Dateien

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

Beiträge aus dem Excel-Forum zum Thema "Einbetten verschiedener Dateien"