Bilder immer mit gleicher Größe einfügen

[Karlheinz16]

Hallo,
ich habe vor, ein Etikett zu erstellen, in dem in der obere Zeile die Artikel-Nr. steht und darunter das dazu gehörige Bild eingefügt wird. Da die Bilder nicht alle die gleiche Größe haben, ist das für mich ein unlösbares Problem. Im Internet finde ich leider aktuell nur Anleitungen für OFFICE 365, ich habe aber "nur" Excel 2019.

Mein Etikett hat ein gesamte Höhe von 292, wobei die 1. Zelle eine Höhe von 54 hat, also bleiben 238 für das Bild übrig. Die Breite ist 71,14. Ich dachte mir, vielleicht gibt es eine Möglichkeit einen Rahmen zu erstellen, wo dann die verschiedenen Bilder automatisch sich dem Rahmen anpassen, doch dies übersteigt bei weitem meine Fähigkeiten. 

Ich kann, wenn in einer Spalte eine Nummer eingetragen wird, ein Bild an einer bestimmten Stelle einfügen aber die Größe automatisch einstellen kann ich nicht.

Code:

Private Sub Worksheet_Change(ByVal Target As Range)
'
On Error Resume Next
Dim rngZiel As Range
Dim ImportBildName As String
ActiveSheet.Unprotect
    Application.ScreenUpdating = False
   
   
    For InI = ActiveSheet.Shapes.Count To 1 Step -1
       If Left(ActiveSheet.Shapes(InI).Name, 3) = "Pic" Then
           ActiveSheet.Shapes(InI).Delete
       End If
    Next

        ImportBildName = "C:\Users\.....\Bilder\Bilder Original\" & Range("d1").Value & ".jpg" ' Dateiname zusammenstellen

        Set rngZiel = Range("a2") ' Zielzelle festlegen
        With ActiveSheet.Pictures.Insert(ImportBildName) ' Bild einfügen
            .Top = rngZiel.Top ' Position in Zielzelle oben
            .Left = rngZiel.Left ' Position in Zielzelle links
            .Height = 213 ' Bildhöhe
            .Width = 213  ' Bildbreite
        End With

           
       
    Application.ScreenUpdating = True
ActiveSheet.Protect
 
End Sub

Die Bilder werden zwar eingefügt, aber mit unterschiedlichen Größen. Auch kann ich sie nicht zentrieren. Kleinere Bilder sollten entweder vergrößert werden, oder einfach nur in der Mitte dargestellt werden.

Ist das möglich? Ich wäre für jede Hilfe dankbar.

Falls noch Fragen offen sind, stehe ich natürlich gerne zur Verfügung.

Bayerische Grüße

Karlheinz

[schauan]

Hallöchen,

wenn Du Bilder einfügst, kann es sein, dass die Einstellung für das Seitenverhältnis (LockAspectRatio) beibehalten noch aktiv ist. Dann führt die Einstellung der Höhe auch zu einer Breitenänderung und die folgende Einstellung der Breite wiederum zu einer Höhenänderung. Deiner Bilder sollten also alle die gleiche Breite, aber unterschiedliche Höhen haben.

Wenn Du die Bilder zentrieren willst, dann reicht das nicht. Steht ja auch im Kommentar.
.Top = rngZiel.Top ' Position in Zielzelle oben
.Left = rngZiel.Left ' Position in Zielzelle links

Du musst z.B. für die horizontale Ausrichtung die Breite der Zelle minus die Breite des Bildes / 2 rehnen und das zu .Left addieren.


Du könntest, falls der Ansatz passt, aber auch einfach die Bilder in die Zelle einfügen statt über die Zelle. Dann werden die Bilder automatisch angepasst, allerdings das Größenverhältnis beibehalten. Also sind sie dann entweder schmaler als die Zelle oder niedriger, je nachdem ... Dann kann man sie auch über das normale Zentrieren entsprechend ausrichten.

[Uduuh]

Hallo,
so geht das:

Code:

Sub BildRein()
    Dim myPic As Object
    Dim strDatei As String
    Dim rngZiel As Range
    Set rngZiel = Range("A2")
   
    strDatei = "d:\test\dsc00989.jpg"
   
    Set myPic = ActiveSheet.Pictures.Insert(strDatei)
    With myPic
        If .Width > .Height Then
            .Width = rngZiel.Width
            .Height = Application.Min(.Height, rngZiel.Height)
        Else
            .Height = rngZiel.Height
            .Width = Application.Min(.Width, rngZiel.Width)
        End If
        .Left = rngZiel.Left + (rngZiel.Width - .Width) / 2
        .Top = rngZiel.Top + (rngZiel.Height - .Height) / 2
    End With
End Sub

Gruß aus'm Pott
Udo

[schauan]

Hallöchen,

... und so könnte der Code aussehen, wenn Du die Funktion "Bild in Zelle einfügen" nutzt.

Code:

Sub Makro1()
    With ActiveCell
      .InsertPictureInCell ("C:\Temp\Test\PXL_20250722_162418242.jpg")
      .HorizontalAlignment = xlCenter
    End With
End Sub

Ist auch schön z.B. beim Sortieren u.a.

Das hat allerdings den Nachteil, dass man das Bild so nicht einfach zu fassen bekommt, eigentlich auch nicht per VBA. Dazu müsste man es wieder rausholen.

Code:

ActiveCell.PlacePictureOverCells

[slowboarder]

Hi

mal so grundsätzlich:
wenn du beim Bild Höhe ODER Breite veränderst, wird der jeweils andere Wert auch automatisch mit geändert (LookAspectRatio)
dh du darfst immer entweder die .Widht oder die .Height deines Bildes anspassen.

um zu entscheiden, ob du Höhe oder Breite anpassen muss, musst du  erstmal feststellen, ob dein Bild in der Relation höher oder breiter als das Etikett ist.
Hierzu teilst du die Höhe durch die Breite (H:B) von deinem Bild und vergleichst das mit dem H:B deines Etiketts

hierbei gilt:
Wenn H:B-Bild größer als H:B-Etikett -> Höhe anpassen
Wenn H:B-Bild kleiner als H:B-Etikett -> Breite anpassen

wenn du die Höhe angepasst hast, musst du die Breite ausmitteln

dh dann im Prinzip:
Bild.Left = Zelle.Left + (Etikett.Width - Bild.Width) / 2

wenn du die Breite angepasst hast, das gleiche Spiel mit der Höhe.

So im Prinzip, kannst du das selber programmieren?


wenn du die Breite einer Zelle ermittelst, musst du aufpassen, hierfür auch immer die .Widht verwenden.
es gibt für Spalten auch noch die .ColumnWidth, aber dieser Wert hat einen anderen Hintergrund und ist nicht für die Grafik relevant, denn er sagt aus, wiev iele Ziffern bei Standardschriftart und -größe vollständig in der Zelle angezeigt werden.

Gruß Daniel

[slowboarder]

Hi

vielleicht am einfachsten so, wenn die Bilder aus einen Verzeichnis gelesen werden:

teil 1 vorbereitend von Hand
- erstelle ein  Image-Control (Bild) aus den ActiveX-Steuerelementen
- platziere es an der gewünschten stelle und ziehe es auf die gewünschte Größe
- Öffne die Eigenschaften und setze die Eigenschaft PictureSizeMode auf 3...Zoom

Teil 2 Makro
im Makros sollte dann folgender Code ausreichen, weitere Platzierungen und Größenänderungen gehen automatisch.

Code:

Activesheet.Image1.Picture = LoadPicture(Pfad- und Dateiname)

Hintergrund und Rahmen des Image-Controls kannst du in der Eigenschaftsliste anpassen.

Gruß Daniel

[Uduuh]

Hallo,
So im Prinzip, kannst du das selber programmieren?
Muss er nicht. Alles in meinem Code enthalten. Nur einfacher

Gruß aus'm Pott
Udo

[Karlheinz16]

Hallo schauan, Uduuh und slowboarder, 
vielen Dank für eure Beiträge.
 @schauan die Werte 
.Top = rngZiel.Top ' Position in Zielzelle oben
.Left = rngZiel.Left ' Position in Zielzelle links
haben bei einem Bild gepasst. Damit wollte ich ja nur zeigen, wie mein Kenntnisstand ist. Das dies nicht immer zum Erfolg führt, habe ich gemerkt. Da die Bilder mit meinem Code in eine Zelle eingefügt werden, habe ich aber nichts davon gemerkt, dass die Bilder automatisch angepasst werden, leider. Vielleicht habe ich aber auch etwas falsch verstanden.

 @Uduuh deinen Code werde ich schnell testen, was mir aber auffällt, er wird nicht (so wie mein Code) automatisch bei einem Eintrag in Zelle D1 gestartet, ich werde probieren, den Code für meine Bedürfnisse anzupassen.

 @slowboarder Teil 1 deines Vorschlags habe ich verstanden und mit Erfolg ausgeführt. Teil 2 muss ich noch versuchen für mich anzupassen.

[slowboarder]

@Uduuh
Ja, wenn die Zielfläche ein Quadrat ist, kann man es so machen wie du es gezeigt hast.
Wenn nicht, so wie von mir beschrieben.

[schauan]

@slowbiarder,
Die Einstellung LockRatioAspect kann man übrigens ändern, wie ich weiter oben schon schrieb...Kommt eben drauf an, was man will. Der Code von Uduu passt schon.