Foto in Zellbereich skaliert einfügen per VBA

[CleverStrauss]

Hallo,
ich möchte gerne ein Foto in einen Zellbereich einfügen und dabei aber das Seitenverhältnis beim skalieren beibehalten.
Aus den I'net habe ich mir dazu verschiedene VBA Schnippsel zusammen gefügt und ich bekomme auch die Bilder eingefügt ABER beim skalieren werden die Fotos gestaucht bzw. gezerrt (das ist der VBA code unten aber ohne den Bereich mit der # markiert ist.
Ein VBA code zum Skalieren unter Beibehaltung der Seitenverhältnisse habe ich auch gefunden (das ist der Bereich mit # markiert) bekomme aber immer ab der 3. Zeile (ActiveSheet.Shapes("Picture 1").Select) ein Fehlermeldung.  
Ich habe jetzt schon diverse verschiedene Varianten ausprobiert aber immer ohne Erfolg. Wie muss ich diesen VBA code ändern damit alles rund läuft?


    Dim ws As Worksheet
    Dim rngTarget As Range
    Dim myImage As Shape
    Dim pct As Picture
    Dim strFotobereich As String
    Dim strDateipfad As String
    Dim varBreite As Variant
    Dim varHoehe As Variant

    strFotobereich = ("A1:E7")
    strDateipfad ="C:\Daten\Foto1.jpg"
       
    'Tabellenblatt festlegen
    Set ws = Worksheets(1)
   
    ' Ziel-Range für das Bild
    Set rngTarget = ws.Range(strFotobereich)
          
    # Range(strFotobereich).Select
    # Set pct = ActiveSheet.Pictures.Insert(strDateipfad)
    # ActiveSheet.Shapes("Picture 1").Select
    # Selection.ShapeRange.LockAspectRatio = msoTrue
      
    # '** Bild auf Spaltenbreite skallieren
    # Selection.ShapeRange.Width = varBreite
 
    # '** Zeilenhöhe festlegen
    #  varHoehe = ActiveSheet.Shapes("Picture 1").Height
    #  Rows(lngZeile).RowHeight = varHoehe
               
    ' Bild hinzufügen
    Set myImage = ws.Shapes.AddPicture(strDateipfad, msoTrue, msoTrue, rngTarget.Left, rngTarget.Top, rngTarget.Width, rngTarget.Height)

[Rabe]

Hi,

Ein VBA code zum Skalieren unter Beibehaltung der Seitenverhältnisse habe ich auch gefunden (das ist der Bereich mit # markiert) bekomme aber immer ab der 3. Zeile (ActiveSheet.Shapes("Picture 1").Select) ein Fehlermeldung.  

das kommt daher, daß das eingefügte Bild nicht Picture 1 heißt, so heißt es nur, wenn nach dem Start der Datei das erste Bild eingefügt wird.

Woher weiß Dein Makro wie die Original-Höhe und -Breite ist? Wo wird den Variablen varBreite und lngZeile ein Wert zugewiesen?

Das Bild wird zwei Mal eingefügt, hier:
  ActiveSheet.Shapes("Picture 1").Select
und hier:
  ' Bild hinzufügen
  Set myImage = ws.Shapes.AddPicture(strDateipfad, msoTrue, msoTrue, rngTarget.Left, rngTarget.Top, rngTarget.Width, rngTarget.Height)

Jetzt macht es was und passt auch etwas an, ob das aber das ist, was Du willst, weiß ich nicht:

Option Explicit

Sub FotoEinfügen()
   
   Dim ws As Worksheet
   Dim rngTarget As Range
   Dim myImage As Shape
   Dim pct As Picture
   Dim strFotobereich As String
   Dim strDateipfad As String
   Dim varBreite As Variant
   Dim varHoehe As Variant
   Dim lngZeile As Long
   
   strFotobereich = ("A1:E7")
   strDateipfad = "C:\temp\Foto1.jpg"
   
   'Tabellenblatt festlegen 
   Set ws = Worksheets(1)
   
   ' Ziel-Range für das Bild 
   Set rngTarget = ws.Range(strFotobereich)
   
   Range(strFotobereich).Select
   ' Set pct = ActiveSheet.Pictures.Insert(strDateipfad) 
   
   ' Bild hinzufügen 
   Set myImage = ws.Shapes.AddPicture(strDateipfad, msoTrue, msoTrue, rngTarget.Left, rngTarget.Top, rngTarget.Width, rngTarget.Height)
   
   ActiveSheet.Shapes("Picture 1").Select
   Selection.ShapeRange.LockAspectRatio = msoTrue
   
   '** Bild auf Spaltenbreite skalieren 
   Selection.ShapeRange.Width = varBreite
   
   '** Zeilenhöhe festlegen 
   lngZeile = Range("A1").Row
   varHoehe = ActiveSheet.Shapes("Picture 1").Height
   Rows(lngZeile).RowHeight = varHoehe
   
End Sub

[CleverStrauss]

Hallo Ralf

vielen Dank für deine prompte Antwort und Lösung. Das Mako läuft jetzt ohne Fehlermedung durch- supi! FirstStep!
Das Bild wird eingefügt aber die Seitenverhätnisse immer noch verzerrt dargestellt. Ich hatte mich bei der Aufgabenstellung aber auch nicht richtig ausgedrückt.

Das Bild soll in den Bereich (A1:E7) eingefügt werden und die Höhe des Bildes dem Zellbereich (A1-A7) angepast werden. Die Breite des Bildes soll dann im Verhältnis zum original Bild angepasst werden d.h ohne Verzerrung und unabhängig davon ob das Bild dann den vollen Bereich (A1:E7) in der Breite ausfüllt. Hier können dann am Rand Lücken entstehen. Soweit so gut , hiermit kann ich leben.

  So, und wenn ich mir das Ganze so durchlese wäre die super Finale Lösung - das Mako stellt fest ob es sich um ein Hoch - oder Querformat Bild handelt , klemmt sich entweder an die Höhe oder an die Breite des Bereichs an und zentriert das Foto noch in dem Bereich (A1:E7)

Gruß heiße auch Ralf :43:

[Rabe]

Hi Ralf,

Das Bild soll in den Bereich (A1:E7) eingefügt werden und die Höhe des Bildes dem Zellbereich (A1-A7) angepast werden. Die Breite des Bildes soll dann im Verhältnis zum original Bild angepasst werden d.h ohne Verzerrung und unabhängig davon ob das Bild dann den vollen Bereich (A1:E7) in der Breite ausfüllt. Hier können dann am Rand Lücken entstehen. Soweit so gut , hiermit kann ich leben.

nimm mal diesen Code:

Option Explicit

Sub FotoEinfügen()
   
   Dim ws As Worksheet
   Dim rngTarget As Range
   Dim myImage As Shape
   Dim myImageName As String
   Dim pct As Picture
   Dim strFotobereich As String
   Dim strDateipfad As String
   Dim varBreite As Variant
   Dim varHoehe As Variant
   Dim lngZeile As Long
   
   strFotobereich = ("A1:E7")
   strDateipfad = "C:\temp\Foto1.jpg"
   varHoehe = 0
   
   'Tabellenblatt festlegen 
   Set ws = Worksheets(1)
   
   ' Ziel-Range für das Bild 
   Set rngTarget = ws.Range(strFotobereich)
   
   Range(strFotobereich).Select
   
   ' Bild hinzufügen 
   Set myImage = ws.Shapes.AddPicture(strDateipfad, msoTrue, msoTrue, rngTarget.Left, rngTarget.Top, rngTarget.Width, rngTarget.Height)
   myImageName = myImage.Name               'Name des eingefügten Fotos 
   
   ws.Shapes(myImageName).Select
   Selection.ShapeRange.LockAspectRatio = msoTrue       'hiermit wird das Länge-Breitenverhältnis fixiert? 

   '** Bild auf Spaltenbreite skalieren 
   Selection.ShapeRange.Width = varBreite    'die Breite proportional zu verkleinern, klappt ncoh nicht 
   
   '** Bildhöhe nach Zeilenhöhe festlegen 
   lngZeile = Range("A1").Row
   For lngZeile = 1 To 7
      varHoehe = varHoehe + Rows(lngZeile).RowHeight
   Next lngZeile
   ActiveSheet.Shapes(myImageName).Height = varHoehe
   
   
End Sub

[schauan]

Hallöchen,
Nur mal als Ansatz - bin gerade am Smartphone und kann da nicht programmieren.
- Bild in Originalgröße einfügen
- Höhe anpassen
- ggf. Seitenverhältnis sperren (dürfte nicht nötig sein, ist glaube Standard).
- Breite des Bildes mit Breite des Bereiches vergleichen und
- nur wenn breiter, anpassen

[Rabe]

Hi André,

- Bild in Originalgröße einfügen
- Höhe anpassen
- ggf. Seitenverhältnis sperren (dürfte nicht nötig sein, ist glaube Standard).
- Breite des Bildes mit Breite des Bereiches vergleichen und
- nur wenn breiter, anpassen

das Blöde ist, daß das Bild bei dem bisher geposteten Code immer verzerrt ist, auch wenn die Breite gar nicht angepasst wird. Das kommt daher, daß es bei der folgenden Zeile immer auf den Zielbereich angepasst wird:
Set myImage = ws.Shapes.AddPicture(strDateipfad, msoTrue, msoTrue, rngTarget.Left, rngTarget.Top, rngTarget.Width, rngTarget.Height)

Aber so geht es jetzt:

Code:

  ' Bild hinzufügen,
'   Set myImage = ws.Shapes.AddPicture(strDateipfad, msoTrue, msoTrue, rngTarget.Left, rngTarget.Top, rngTarget.Width, rngTarget.Height)
  Set pct = ActiveSheet.Pictures.Insert(strDateipfad)
  myImageName = pct.Name               'Name des eingefügten Fotos

Option Explicit

Sub FotoEinfügen()
   
   Dim ws As Worksheet
   Dim rngTarget As Range
'   Dim myImage As Shape 
   Dim myImageName As String
   Dim pct As Picture
   Dim strFotobereich As String
   Dim strDateipfad As String
   Dim varBreite As Variant
   Dim varHoehe As Variant
   Dim lngZeile As Long
   
   strFotobereich = ("A1:E7")
   strDateipfad = "C:\temp\Foto1.jpg"
   varHoehe = 0
   
   'Tabellenblatt festlegen 
   Set ws = Worksheets(1)
   
   ' Ziel-Range für das Bild 
   Set rngTarget = ws.Range(strFotobereich)
   
   Range(strFotobereich).Select
   
   ' Bild hinzufügen, 
   Set pct = ActiveSheet.Pictures.Insert(strDateipfad)
   'Name des eingefügten Fotos 
   myImageName = pct.Name
   
   '** Länge-Breitenverhältnis fixiert 
   ws.Shapes(myImageName).LockAspectRatio = msoTrue

   '** Bild-Breite proportional skalieren 
   ws.Shapes(myImageName).Width = varBreite
   
   '** Bildhöhe nach Zeilenhöhe festlegen 
   For lngZeile = 1 To 7
      varHoehe = varHoehe + Rows(lngZeile).RowHeight
   Next lngZeile
   ws.Shapes(myImageName).Height = varHoehe
   
End Sub

[schauan]

Hallo Ralf,

so könnte es aber passieren, dass das Bild wieder zu lang wird. Ich würde das so lösen:
'*** Bildhöhe nach Zeilenhöhe festlegen
ws.Shapes(myImageName).Height = Rows("1:7").Height
'***Wenn Bild zu breit, dann
If ws.Shapes(myImageName).Width > Columns("A:E").Width Then
'Breite auf A:E-Breite verringern
ws.Shapes(myImageName).Width = Columns("A:E").Width
'Hoehe zentrieren, dazu Hoehendifferenz durch 2 teilen
ws.Shapes(myImageName).Top = (Rows("1:7").Height - ws.Shapes(myImageName).Height) / 2
'***oder wenn zu schmal
Else
'Breite zentrieren, dazu Breitendifferenz durch 2 teilen
ws.Shapes(myImageName).Left = (Columns("A:E").Width - ws.Shapes(myImageName).Width) / 2
'***Ende Wenn Bild zu breit, dann
End If

[Rabe]

Hi André,

so könnte es aber passieren, dass das Bild wieder zu lang wird. Ich würde das so lösen:

ich hatte jetzt noch gar keinen Fall, in dem das Bild höher als die sieben Zeilen war, egal ob Quer- oder Hochformat, egal welche Größe das Ursprungsbild hatte.
   
   

Aber Du hast recht, so ist es schöner:

Option Explicit

Sub FotoEinfügen()
   
   Dim ws As Worksheet
   Dim rngTarget As Range
   'Dim myImage As Shape 
   Dim myImageName As String
   Dim pct As Picture
   Dim strFotobereich As String
   Dim strDateipfad As String
   Dim varBreite As Variant
   Dim varHoehe As Variant
   Dim lngZeile As Long
   
   strFotobereich = ("A1:E7")
   strDateipfad = "C:\temp\" & Range("I9").Value & ".jpg"
   
   varHoehe = 0
   
   'Tabellenblatt festlegen 
   Set ws = Worksheets(1)
   
   ' Ziel-Range für das Bild 
   Set rngTarget = ws.Range(strFotobereich)
   rngTarget.Select
   
   ' Bild hinzufügen, 
   Set pct = ws.Pictures.Insert(strDateipfad)
   'Name des eingefügten Fotos 
   myImageName = pct.Name
   
   '   '** Länge-Breitenverhältnis fixiert 
   '   ws.Shapes(myImageName).LockAspectRatio = msoTrue 
   ' 
   
   '*** Bildhöhe nach Zeilenhöhe festlegen 
   ws.Shapes(myImageName).Height = Rows("1:7").Height
   '*** Wenn Bild zu breit, dann 
   If ws.Shapes(myImageName).Width > Columns("A:E").Width Then
      'Breite auf A:E-Breite verringern 
      ws.Shapes(myImageName).Width = Columns("A:E").Width
      'Hoehe zentrieren, dazu Hoehendifferenz durch 2 teilen 
      ws.Shapes(myImageName).Top = (Rows("1:7").Height - ws.Shapes(myImageName).Height) / 2
      '*** oder wenn zu schmal 
   Else
      'Breite zentrieren, dazu Breitendifferenz durch 2 teilen 
      ws.Shapes(myImageName).Left = (Columns("A:E").Width - ws.Shapes(myImageName).Width) / 2
      '*** Ende Wenn Bild zu breit, dann 
   End If
End Sub

[CleverStrauss]

Hallo,

ich habe es gerade ausgetestet und ...einfach genial...das Macro macht es jetzt genau so wie ich es brauche. Supi! Danke! :)