Ich möchte 2 Bilder nebeneinander in einer Zelle einfügen, das klappt soweit, lediglich gelingt es mir nicht ein "Hochkant- Foto" von einem "Querliegenden- Foto" zu unterscheiden und entsprechend zu formatieren.
Es wird immer die längere Seite als "width" angepasst. Es sollte aber so sein, dass die beiden Bilder möglichst groß nebeneinander in der gleichen Zelle eingefügt werden ohne über deren Ränder hinauszuspringen, d.h. das Hochkantbild müsste verkleinert werden.
Irgendwo habe ich da einen Denkfehler oder die Auswertung funktioniert nicht wie es soll.
Gibt es eine Möglichkeit die Ausrichtung des Bildes festzustellen (Hoch oder Quer?)
Vielen Dank für jede Hlfe
Hier mein Macro:
Sub T_ransfer()
Dim Bild_1 As Variant
Dim Bild_2 As Variant
Dim rngZelle As Range
Dim sngTop As Single
Dim sngLeft As Single
Dim sngWidth As Single
Dim sngHeight As Single
Dim picPic As Picture
Dim wksT As Worksheet
Dim Weg As String
Dim Verz As String
Dim ziel As String
Set wksT = activesheet
Set rngZelle = wksT.Cells(77, 1)
sngTop = rngZelle.Top + 20
sngLeft = rngZelle.Left + 15
sngHeight = 250
sngWidth = 350
Weg = "I:\Projekte Tirol\"
Verz = Weg & Left(Range("d2").Value, 3) & "*"
ziel = Dir(Verz, vbDirectory)
ChDrive "I"
ChDir Weg & ziel
Bild_1 = Application.GetOpenFilename( _
FileFilter:="JPEG Files (*.jpg), *.jpg", _
title:=" Bild 1 auswählen", _
MultiSelect:=False)
If VarType(Bild_1) = vbBoolean Then Exit Sub
Bild_2 = Application.GetOpenFilename( _
FileFilter:="JPEG Files (*.jpg), *.jpg", _
title:=" Bild 2 auswählen", _
MultiSelect:=False)
If VarType(Bild_2) = vbBoolean Then Exit Sub
On Error Resume Next
wksT.Shapes("Bild 1").Delete
wksT.Shapes("Bild 2").Delete
On Error GoTo 0
With activesheet.Pictures.Insert(Bild_1)
With .ShapeRange
.LockAspectRatio = msoTrue
If .Height > sngHeight Then .Height = sngHeight
If .Width > sngWidth Then .Width = sngWidth
.Top = sngTop
.Left = sngLeft
End With
.Name = "Bild 1"
.SendToBack
End With
With activesheet.Pictures.Insert(Bild_2)
With .ShapeRange
.LockAspectRatio = msoTrue
If .Height > sngHeight Then .Height = sngHeight
If .Width > sngWidth Then .Width = sngWidth
.Top = sngTop
.Left = sngLeft + 350
End With
.Name = "Bild 2"
.SendToBack
End With
End Sub