Dieses Forum nutzt Cookies
Dieses Forum verwendet Cookies, um deine Login-Informationen zu speichern, wenn du registriert bist, und deinen letzten Besuch, wenn du es nicht bist. Cookies sind kleine Textdokumente, die auf deinem Computer gespeichert werden. Die von diesem Forum gesetzten Cookies werden nur auf dieser Website verwendet und stellen kein Sicherheitsrisiko dar. Cookies aus diesem Forum speichern auch die spezifischen Themen, die du gelesen hast und wann du zum letzten Mal gelesen hast. Bitte bestätige, ob du diese Cookies akzeptierst oder ablehnst.

Ein Cookie wird in deinem Browser unabhängig von der Wahl gespeichert, um zu verhindern, dass dir diese Frage erneut gestellt wird. Du kannst deine Cookie-Einstellungen jederzeit über den Link in der Fußzeile ändern.

Foto in Zellbereich skaliert einfügen per VBA
#1
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. Dodgy  
Ich habe jetzt schon diverse verschiedene Varianten ausprobiert aber immer ohne Erfolg. Wie muss ich diesen VBA code ändern damit alles rund läuft? Huh


    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)
Antworten Top
#2
Hi,

(19.07.2016, 08:17)CleverStrauss schrieb: 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. Dodgy  

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
Antworten Top
#3
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. Undecided

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.

  Dodgy 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:
Antworten Top
#4
Hi Ralf,

(19.07.2016, 11:29)CleverStrauss schrieb: 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
Antworten Top
#5
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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#6
Hi André,

(20.07.2016, 06:33)schauan schrieb: - 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
Antworten Top
#7
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
.      \\\|///      Hoffe, geholfen zu haben.
       ( ô ô )      Grüße, André aus G in T  
  ooO-(_)-Ooo    (Excel 97-2019+365)
Antworten Top
#8
Hi André,

(20.07.2016, 10:13)schauan schrieb: 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
[-] Folgende(r) 1 Nutzer sagt Danke an Rabe für diesen Beitrag:
  • CleverStrauss
Antworten Top
#9
Wink 
Hallo,

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


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste