Objekte per VBA einfügen!
03.06.2020 08:44:49
Micha
ich hatte vor einiger Zeit hier in Forum den untenstehenden Code zum Einfügen von Objekten gefunden. Der Code funktioniert soweit prima, aber
Die Arbeitsmappe mit dem Code ist als Addin gespeichert. Beim ausführen des Code wird das Objekt in der Addin-Mappe eingefügt, aber leider nicht in der aktiven Arbeitsmappe.
Würde mich riesig freuen, wenn mir jemand den Code so anpassen würde das die Objekte immer in der aktiven Arbeitsmappe eingefügt werden.
Vielen Dank und lieben Gruß,
Micha
Option Explicit
Option Private Module
Private Declare
Function SHGetFileInfo Lib "shell32.dll" Alias "SHGetFileInfoA" ( _
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 OleCreatePictureIndirectA Lib "oleaut32.dll" Alias "OleCreatePictureIndirect" ( _
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
Sub Objekt_Einbetten()
Dim varPaths, varPath, NextLeft!, MsgResult As VbMsgBoxResult
Dim udtShellInfo As ShellFileInfoType
Dim udtIcon As IconType
Dim udtCLSID As CLSIdType
Dim objUnknown As IUnknown
Dim objTabelle As Worksheet
Dim ICON_PATH$
On Error Resume Next
Set objTabelle = Tabelle1 'evtl. Tabelle anpassen
varPaths = Application.GetOpenFilename( _
"Excel; Bilder; PDF(*.msg;*.xls;*.xlsx;*.xlsm;*.bmp;*.jpg;*.gif;*.png;*.ppt;*.pptx;*. _
doc?;*.pdf),*.bmp;*.jpg;*.gif;*.png;*.doc?;*.pdf," & _
"Word(*.doc?),*.doc?," & _
"Bilder(*.bmp;*.jpg;*.png;*.gif),*.bmp;*.jpg;*.png;*.gif," & _
"PDF(*.pdf),*.pdf", title:="EXCEL | Dateien auswählen", MultiSelect:=True)
If Not IsArray(varPaths) Then Exit
Sub 'Benutzer hat abgebrochen
With Application
.ScreenUpdating = False
.EnableEvents = False
ICON_PATH = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & " _
\") & "temp.ico"
For Each varPath In varPaths
Call SHGetFileInfo(varPath, 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 OleCreatePictureIndirectA(udtIcon, udtCLSID, 1, objUnknown)
Call SavePicture(objUnknown, ICON_PATH)
With objTabelle.OLEObjects.Add(Filename:=varPath, _
Link:=False, DisplayAsIcon:=True, IconIndex:=0, IconFileName:=ICON_PATH, _
IconLabel:=Right$(varPath, Len(varPath) - InStrRev(varPath, "\")))
End With
Call Kill(ICON_PATH)
Next varPath
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub