Bilder einfügen per Makro
20.02.2017 11:09:48
Erik
ich habe folgendes Problem.
Ich habe aus einem alten Add-In die Funktion zum Bilder einfügen in meine personal.xlsb übernommen. Wenn ich die FUnktion inkl. Argumente übernehme wird mir die Funktion nicht als Makro angezeigt. Nehme ich die Argumente (valign as String, adjustCell as Boolean)raus, wird die Funktion als Makro verfügbar. Die Bilder werden auch eingefügt, allerdings alle in Zelle A1 und die Zeilenhöhe wird nicht angepasst.
Kann mir jemand helfen?
Danke
Lg Erik
Sub AddImage(valign as String, adjustCell as Boolean)
Dim objSelectedRange As Range
Dim objCell As Range
Dim ImagePath As String
Dim ImageFolder As String
Dim ImageType As String
Dim objImg As Object
Dim ImgTop As Double
Dim ImgLeft As Double
Dim ImgWidth As Double
Dim ImgHeight As Double
Dim objXlShp As Excel.Shape
Dim image As Picture
Set objSelectedRange = Selection.Cells
ImageFolder = "C:\Users\Admin\Desktop\Produktbilder\Images_final\"
ImageType = ".png"
On Error Resume Next
Application.ScreenUpdating = False
For Each objCell In objSelectedRange
If objCell.Value "" Then
ImagePath = ImageFolder & objCell.Value & ImageType
Set objImg = ActiveSheet.Pictures.Insert(ImagePath)
objImg.Visible = False
'If Err.Number = 0 Then
Application.StatusBar = "Adding image ... " & objCell.Value
ImgWidth = 30
If objImg.ShapeRange.Height > 60 Then
ImgHeight = 60
Else
ImgHeight = objImg.ShapeRange.Height
'ImgHeight = 60
End If
objImg.ShapeRange.Width = ImgWidth
objImg.ShapeRange.Height = ImgHeight
'Resize Cell
If adjustCell Then
'objCell.RowHeight = ImgHeight + 18
objCell.RowHeight = objImg.ShapeRange.Height + 18
If objCell.ColumnWidth