AW: Einbetten verschiedener Dateien
11.11.2020 14:34:12
volti
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