Code funktioniert nicht als Ribbon in Addin Datei
17.01.2019 17:30:34
Pramkies
Ziel: ist es in eine Excel Datei an einer bestimmte stelle eine PDF-Datei einzubetten! Funktioniert auch wenn ich den Code als Button in der Excel Datei auslösen ! Aber sobald ich es als "Ribbon Button" auslöse bekomme ich ein Fehler:
"Fehler beim kompilieren: benutzerdefinierter Typ nicht definiert"
Code:
Option Explicit
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 lngRowPosObjekt As Long
Dim udtShellInfo As ShellFileInfoType
Dim udtIcon As IconType
Dim udtCLSID As CLSIdType
Dim objUnknown As IUnknow
Dim objTabelle As Worksheet
Dim ICON_PATH$
'Set objTabelle = Cover 'evtl. Tabelle anpassen
lngRowPosObjekt = 10 'Zeile wo Objekte platziert werden, evtl. anpassen
varPaths = Application.GetOpenFilename( _
"Word; Bilder; PDF(*.bmp;*.jpg;*.gif;*.doc?;*.pdf),*.bmp;*.jpg;*.gif;*.doc?;*.pdf," & _
"Word(*.doc?),*.doc?," & _
"Bilder(*.bmp;*.jpg;*.gif),*.bmp;*.jpg;*.gif," & _
"PDF(*.pdf),*.pdf", Title:="Dateien auswählen", MultiSelect:=True)
If Not IsArray(varPaths) Then Exit Sub 'Benutzer hat abgebrochen
MsgResult = MsgBox("Vorhandene Pdf löschen?", vbQuestion + vbYesNo)
With Application
.ScreenUpdating = False
.EnableEvents = False
NextLeft = Loesche_Alte(objTabelle, MsgResult = vbYes)
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, "\")))
.Top = objTabelle.Cells(lngRowPosObjekt, 1).Top
.Left = objTabelle.Cells(lngRowPosObjekt, 4).Left + NextLeft
NextLeft = .Left + .Width + 10
End With
Call Kill(ICON_PATH)
Next varPath
.ScreenUpdating = True
.EnableEvents = True
End With
End Sub
Private Function Loesche_Alte(oTabelle As Worksheet, booKillObj As Boolean) As Single
Dim OleObj As OLEObject, sngMaxLeft!
sngMaxLeft = 5
With Application.WorksheetFunction
For Each OleObj In oTabelle.OLEObjects
If InStr(LCase(OleObj.Name), "object") > 0 Then
If booKillObj Then
OleObj.Delete
Else
sngMaxLeft = .Max(OleObj.Left + OleObj.Width + 10, sngMaxLeft)
End If
End If
Next
End With
Loesche_Alte = sngMaxLeft
End Function