Hilfe bei VBA
24.01.2015 08:58:34
wavemaster
Das ist der VBA Text:
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 IUnknown
Dim objTabelle As Worksheet
Dim ICON_PATH$
Set objTabelle = Tabelle1 '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 Objekte 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, 1).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
Das Icon sollte 15mm hoch und 150mm lang sein.
Bitte die Stelle markieren wo geändert wurden
Danke
