Object einbetten mit Icon
16.10.2020 12:10:05
Thomas
ich möchte in mein Dokument noch die Möglichkeit haben, Objekte (PDF, JPG, XLS) einzubetten. Ich habe untenstehenden Code hier gefunden und eingebaut. Soweit so gut, nur dass beim hinzufügen des dritten Dokuments das Icon über dem zweiten Icon liegt. Also schaltet die Column Anweisung nicht weiter.
Ich möchte auch das Script noch so abändern, dass nur PDF, JPG, XLS eingefügt werden können und die Row zwar im Endeffekt bei 216 beginnt, aber ggf. durch hinzufügen von Zeilen sich auch ändern kann wie z.B. 220 (falls vier Zeilen hinzugefügt werden).
Hier mein Code Versuch:
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
lngRow = 4
lngColumn = 2
With Application.FileDialog(msoFileDialogFilePicker)
.Filters.Clear
.Title = "Add General Document"
.AllowMultiSelect = False
If .Show Then
For Each vntItem In .SelectedItems
If (IsEmpty(ActiveSheet.Cells(lngRow, lngColumn)) = False) Then
lngColumn = lngColumn + 2
End If
If lngColumn Mod 9 = 0 Then
lngRow = lngRow + 5
lngColumn = 2
End If
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
With objOLEObject
.Left = Columns(lngColumn).Left
.Top = Rows(lngRow).Top
End With
ActiveSheet.Cells(lngRow, lngColumn) = lngColumn
lngColumn = lngColumn + 2
Call LockWindowUpdate(0&)
Set objOLEObject = Nothing
End If
Next
End If
End With
End Sub