Problem beim BILD-EINFÜGEN in Zelle per VBA
09.01.2019 20:01:44
Jens
Ich füge per VBA Bilder per DateiÖffnen-Dialog in einen ungeschützten Zellbereich einer geschützten Tabelle ein, wobei die Bildgröße dem Bereich automatisch angepasst wird. Dies funktioniert auch sehr gut; dass es sich beim Einfüge-Bereich um verbundene Zellen handelt spielt keine Rolle.
Problem / Frage:
Wenn es sich um Bilder handelt, die laut Eigenschaft ("Grafik formatieren") "Drehung 90 Grad" aufweisen (anstatt normal 0 Grad), werden diese IRGENDWO (!!) im Blatt eingefügt. Nun habe ich im u. a. Code schon mal die Zeile
.IncrementRotation -90
hinter With Selection.ShapeRange eingefügt, doch das hilft nur bei solchen mit 90 Grad (allerdings liegen diese dann auf der Seite und werden von der urspr. Höhe her minimal gestutzt). Bilder mit 180 Grad werden dann auf den Kopf gestellt und doch wieder IRGENDWO eingefügt.
Wie kann ich durch welche Abfragen (habe bei ShapeRange und in unzähligen Posts nichts gefunden) und Code-Ergänzung dieses Problem lösen? Wäre sehr dankbar für Antworten!!!
Mein Code (der gestartet wird über
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
... _
Call Bild_einfügen1
...) :
Sub Bild_einfügen1()
Dim Dat As String
Dim Zelle As Range
Dim ScaleA As Double
Application.ScreenUpdating = False
Set Zelle = Sheets("Bautenstand").Range("B4:E14") 'hier wird das bild eingefügt
Dat = Application.GetOpenFilename(, , "Bild auswählen", , False)
Select Case Right(Dat, 4)
Case ".bmp", ".jpg", "jpeg", ".tif", ".gif", ".png", ".BMP", ".JPG", ".JPEG", ".TIF", ".GIF", ". _
PNG"
ActiveSheet.Pictures.Insert(Dat).Select
With Selection.ShapeRange
.IncrementRotation -90 'dreht 90er Bilder und passt linksgedreht
'gestaucht ein ---> hier brauche ich Hilfe!
.Top = Zelle.Top
.Left = Zelle.Left
ScaleA = WorksheetFunction.Min(Zelle.Width / .Width, Zelle.Height / .Height)
.Height = .Height * ScaleA
End With
Selection.Placement = xlMoveAndSize
Selection.PrintObject = True
Case Else
MsgBox "Sie haben kein gültiges Bild ausgewählt"
End Select
Application.ScreenUpdating = True
End Sub