19.07.2016, 08:17
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)
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)