AW: Bild aus Userform in Zelle kopieren
31.07.2020 19:42:04
volti
Hallo Sleepyhead,
hier noch eine Variante, bei der die Grafiken auch in einem nicht aktivierten Blatt eingefügt werden kann.
[+][-]
Sub Paste_Picture_From_Userform()
'Makro löscht die letzte Grafik, verschiebt die Verbliebenen nach unten
'und fügt oben die aktuelle Grafik aus einer Userform wieder ein
Dim iZeile As Long, iSpalte As Long, yBeginn As Long, yEnde As Long
Dim oShp As Object, oLastShp As Object, rRette As Range
Dim WSh As Worksheet
Dim xPt As Double, yPt As Double
'Hier die Parameter eingeben
yBeginn = 1: yEnde = 20: iSpalte = 3 'Grafiken in Spalte $C
Set WSh = ActiveSheet 'Zielblatt angeben
If WSh Is ActiveSheet Then Set rRette = ActiveCell 'Aktive Zelle retten
hPic = CopyImage(UserForm1.Image1.Picture, _
IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG) 'Bild kopieren
If hPic <> 0 Then
If OpenClipboard(Application.hWnd) <> 0 Then 'Zwiscehnablage öffnen
EmptyClipboard 'Zwischenablage leeren
SetClipboardData CF_BITMAP, hPic 'Bild in Zwischenablage setzen
CloseClipboard 'Zwischenablage schließen
DeleteObject hPic 'Temporäres Bild löschen
'Alle Grafiken um eine Zeile nach unten schieben
For iZeile = yEnde To yBeginn Step -1 'Alle Zeilen durchgehen
For Each oShp In WSh.Shapes 'Je Zeile alle Shapes durchgehen
With oShp
xPt = WSh.Cells(iZeile, iSpalte).Left - 1 'xPosition der Zelle
yPt = WSh.Cells(iZeile, iSpalte).Top - 1 'yPosition der Zelle
If .Left > xPt And .Top > yPt And .Left < xPt + 6 And .Top < yPt + 6 Then
If iZeile = yEnde Then
.Delete 'erste bzw. letzte Grafik entfernen
Else
.Top = WSh.Cells(iZeile + 1, iSpalte).Top 'Shape verschieben
End If
Exit For 'Dieses Shape ist erledigt
End If
End With
Next oShp
Next iZeile
'Neue Grafik vorne einfügen und formatieren
WSh.Paste Destination:=WSh.Cells(yBeginn, iSpalte)
For Each oShp In WSh.Shapes
Set oLastShp = oShp 'Zuletzt eingefügte Grafik
Next oShp
With oLastShp
.Left = WSh.Cells(yBeginn, iSpalte).Left
.Top = WSh.Cells(yBeginn, iSpalte).Top
If .Width < .Height Then
.Width = WSh.Cells(yBeginn, iSpalte).Width 'Verhältnis bleibt gleich
Else
.Height = WSh.Cells(yBeginn, iSpalte).Height
End If
End With
If Not rRette Is Nothing Then rRette.Select 'Position wiederherstellen
End If 'If OpenClipboard
End If 'If hPic <> 0
End Sub
viele Grüße aus Freigericht
Karl-Heinz