Excel: Bilder erzeugen aus Bildname oder Hyperlink und in Nachbarzelle anzeigen

[barsch1969]

Ich danke euch für den Input.
Da unsere Bilder so unterschiedlich dimensioniert siind, geht das Ganze leider nur teilweise mit der Excelllösung.
Für die schwierigen Produktgruppen muss dann doch Indesign herhalten.

[schauan]

Hallöchen,

mit VBA ist viel möglich. Der Code passt ja nur die Bildhöhe an die Zellhöhe an. Man kann auch die Zellhöhe an die Bildhöhe anpassen. Man kann auch die Zellbreite an die Bildbriete anpassen. Oder die Bildbreite an die Zellbreite. Man kann dafür auch Maximalwerte definieren. Mann kann auch Breite und Höhe und Maximum kombinieren. Man kann auch …
Zellbreite und Zellhöhe wirkt dann natürlich auf die komplette Spalte bzw. Zeile. Wenn da mehr Bilder drin sind, sollte man die Maße eher nicht verkleinern - die können ja von einem anderen Bild stammen …

An der Dateigröße ändert sich mit diesem Stauchen nix. Dazu müsste man das Bild in echt verkleinern.

[Kuwer]

An der Dateigröße ändert sich mit diesem Stauchen nix. Dazu müsste man das Bild in echt verkleinern.

Das wäre aber auch lösbar: https://www.clever-excel-forum.de/thread...l#pid16036

Gruß Uwe

[barsch1969]

Mit diesem Code von CASE hatte ich ja halbwegs akzeptable Ergebnisse.
Anwelcher Stelle müsste ich den Code anpassen, wenn ich die Lösung möchte "Zellbreite an Bildbreite und Zellhöhe an Bildhöhe" anpassen.


Option Explicit
Sub Main()
    Dim objPic As Shape
    Dim lngRow As Long
    Dim strFile As String
    For Each objPic In ActiveSheet.Shapes
        If Not Intersect(objPic.TopLeftCell, Range("B:B")) Is Nothing Then
            objPic.Delete
        End If
    Next objPic
    Const cstrPath As String = "C:\Users\v1eil\Desktop\Links\"  'Pfad anpassen!!!!
    With ThisWorkbook.Worksheets("Tabelle1") 'Tabellenname ggfl. anpassen!
        lngRow = Application.Max(1, .Cells(.Rows.Count, 1).End(xlUp).Row)
        For lngRow = 2 To lngRow
            If Not IsEmpty(.Cells(lngRow, 1).Value) Then
                strFile = Dir(cstrPath & .Cells(lngRow, 1).Value, vbNormal)
                If strFile <> "" Then
                    With .Shapes.AddPicture _
                        (cstrPath & strFile, False, True, 0, 0, 50, 20)
                        .Left = .Parent.Cells(lngRow, 2).Left
                        .Top = .Parent.Cells(lngRow, 2).Top
                        .Height = .Parent.Cells(lngRow, 2).Height
                        .Width = .Parent.Cells(lngRow, 2).Width
                        .Name = "picture" & lngRow
                    End With
                End If
            End If
        Next lngRow
    End With
End Sub

[schauan]

Hallöchen,

an der Stelle

Code:

With .Shapes.AddPicture _
    (cstrPath & strFile, False, True, 0, 0, 50, 20)

musst Du erst mal die Originalgröße reinholen, also statt , 50, 20 dann , -1, -1

hier

Code:

.Height = .Parent.Cells(lngRow, 2).Height
                        .Width = .Parent.Cells(lngRow, 2).Width

nimmst Du

Code:

.Height = WorksheetFunction.Max(.Parent.Cells(lngRow, 2).Height, .Height)
                        .Width = Worksheetfunction.Max(.Parent.Cells(lngRow, 2).Width, .Width)
                       if .height > .Parent.Cells(lngRow, 2).Height then .height = .Parent.Cells(lngRow, 2).Height

Allerdings ist das nicht ganz das optimale. man müsste, falls sich durch das If die Breite wieder verringert, auch nochmal die Zellbreite prüfen. Das ganze dann nochmal im Vergleich mit den ursprünglichen Werten … Aber, probier's erst mal so.

[barsch1969]

Hallo Schauan,

das sieht schon mal sehr gut aus.
Es funktioniert zwar nicht auf einen Rutsch über unsere 10000 Artikel, aber damit kann ich große Bereiche super abdecken - 1000 Dank.