AW: Bild einfügen und an Zelle anpassen
20.02.2022 22:50:44
volti
Hallo Ulla,
ich weiß nicht, ob ihr Dir jetzt genau folgen kann,
ich möchte mit einem weiteren Steuerelement die Grafik in 2 Zellen einbetten.
Hierfür kannst Du, wenn Du das bisherige Makro weiternutzen möchtest, die ActiveCell einfach durch Selection ersetzen.
Hierbei wäre dann z.B. "B2:B3" markiert, evtl. auch als verbundene Zellen, das Ziel.
In B2 und B4 kann man kein Bild einfügen, oder wolltest Du ein Bild zweimal einfügen?
Da müsste man dann z.B. eine Schleife "For Each" programmieren
Code:
[Cc][+][-]
Sub Bild_einfügen_und_Bildgröße_anpassen1()
' Bild aus Zwischenspeicher einfügen
Dim X As Long, Y As Long, H As Long, B As Long
Dim rZelle As Range
For Each rZelle In Selection
With rZelle
X = .Left: Y = .Top: H = .Height: B = .Width
End With
ActiveSheet.Paste
If TypeName(Selection) = "Picture" Then
With Selection.ShapeRange
.LockAspectRatio = False
.Left = X: .Top = Y: .Height = H: .Width = B
End With
End If
Next rZelle
End Sub
Sub Bild_einfügen_und_Bildgröße_anpassen2()
' Bild aus Zwischenspeicher einfügen
Dim X As Long, Y As Long, H As Long, B As Long, R1 As Double, R2 As Double
Dim rZelle As Range
For Each rZelle In Selection
With rZelle
X = .Left: Y = .Top: H = .Height: B = .Width
End With
ActiveSheet.Paste
If TypeName(Selection) = "Picture" Then
With Selection.ShapeRange
.LockAspectRatio = True
.Left = X: .Top = Y
R1 = .Width / B: R2 = .Height / H
If R1 < R2 Then
.Height = H
Else
.Width = B
End If
.Left = X + ((B - .Width) \ 2): .Top = Y + ((H - .Height) \ 2)
End With
End If
Next rZelle
End Sub
Code:
[Cc][+][-]
Sub Bild_einfügen_und_Bildgröße_anpassen1()
' Bild aus Zwischenspeicher einfügen
Dim X As Long, Y As Long, H As Long, B As Long
With Selection
X = .Left: Y = .Top: H = .Height: B = .Width
End With
ActiveSheet.Paste
If TypeName(Selection) = "Picture" Then
With Selection.ShapeRange
.LockAspectRatio = False
.Left = X: .Top = Y: .Height = H: .Width = B
End With
End If
End Sub
Sub Bild_einfügen_und_Bildgröße_anpassen2()
' Bild aus Zwischenspeicher einfügen
Dim X As Long, Y As Long, H As Long, B As Long, R1 As Double, R2 As Double
With Selection
X = .Left: Y = .Top: H = .Height: B = .Width
End With
ActiveSheet.Paste
If TypeName(Selection) = "Picture" Then
With Selection.ShapeRange
.LockAspectRatio = True
.Left = X: .Top = Y
R1 = .Width / B: R2 = .Height / H
If R1 < R2 Then
.Height = H
Else
.Width = B
End If
.Left = X + ((B - .Width) \ 2): .Top = Y + ((H - .Height) \ 2)
End With
End If
End Sub
_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz