Hallo Zusammen,
bin jetzt schon ein paar Tage an diesem ***** Problem dran.
Möchte gerne Bilder einfügen, deren (Datei)Namen in den markierten Zellen stehen und entsprechend die Zeile vergrößern.
Meine aktuelle Lösung fügt leider nur die "Verknüpfung" ein:
Vielen Dank für eure Hilfe.
bin jetzt schon ein paar Tage an diesem ***** Problem dran.
Möchte gerne Bilder einfügen, deren (Datei)Namen in den markierten Zellen stehen und entsprechend die Zeile vergrößern.
Meine aktuelle Lösung fügt leider nur die "Verknüpfung" ein:
Visual Basic-Quellcode
- 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 Set objSelectedRange = Selection.Cells
- ImageFolder = "C:\" ImageType = ".gif" On Error Resume Next
- Application.ScreenUpdating = False
- For Each objCell In objSelectedRange If objCell.Value <> "" Then ImagePath = ImageFolder & objCell.Value & ImageType 'Set objImg = ActiveSheet.Shapes.AddPicture(ImagePath, True, True, objCell.Top, objCell.Height * 3, 30, 60) Set objImg = ActiveSheet.Pictures.Insert(ImagePath) If Err.Number = 0 Then Application.StatusBar = "Adding image ... " & objCell.Value If objImg.ShapeRange.Height > 60 Then ImgHeight = 60 Else ImgHeight = objImg.ShapeRange.Height End If objImg.ShapeRange.Width = ImgWidth objImg.ShapeRange.Height = ImgHeight 'Resize Cell If adjustcell Then objCell.RowHeight = objImg.ShapeRange.Height + 18 If objCell.ColumnWidth < (objImg.ShapeRange.Width / 5) Then objCell.ColumnWidth = objImg.ShapeRange.Width / 5 End If End If If vAlign = "Top" Then objCell.VerticalAlignment = xlVAlignTop objImg.Top = objCell.Top + 15 objImg.Left = objCell.Left + 5 Else If vAlign = "Bottom" Then objCell.VerticalAlignment = xlVAlignBottom objImg.Top = objCell.Top + 5 objImg.Left = objCell.Left + 5 End If End If objImg.Placement = xlMoveAndSize
- Set objImg = Nothing Else Err.Clear End If End If
- Next objCell Application.ScreenUpdating = True Application.StatusBar = False
- End Sub
Vielen Dank für eure Hilfe.