Bild hochformat/querformat
07.08.2013 14:13:12
Albert
ist es möglich, dass man beim Auswählen/Einfügen eines Bildes automatisch eine Größe vorgeben kann ohne dies manuell machen zu müssen.
Den nachfolgenden Code hab ich zusammengebastelt. Aber so wirklich zufrieden bin ich nicht, da auch die Abbruchbedingung nicht passt.
Private Sub Ok_Click()
Dim rngLocation As Range
Dim i As Integer
Dim shpBild As Shape
Set rngLocation = ActiveCell
Bild = Application.GetOpenFilename("C:\,*.jpg")
If Bild 0 Then
On Error GoTo fehlerbehandlung
ActiveSheet.Pictures.Insert(Bild).Select
'On Error GoTo 0
If FileLen(Bild) / 1024 > 500 Then
MsgBox ("Die Bilddateigröße übersteigt die 500kb Größe! Bitte reduzieren sie erst die _
Dateigröße! ")
Exit Sub
Else
If querformat = True Then
If TypeName(Selection) = "Picture" Or TypeName(Selection) = "Grafik" Then 'nur _
wenn Grafik markiert ist :
With Selection.ShapeRange
.LockAspectRatio = True
'Breite und Höhe der Grafik bitte in Klammer hier anpassen :
.Top = rngLocation.Top + 32
.Left = rngLocation.Left + 8
.Height = Application.CentimetersToPoints(6.77)
.Width = Application.CentimetersToPoints(9)
End With
For Each shpBild In ActiveSheet.Shapes
If shpBild.Type = msoPicture Then
shpBild.Placement = xlFreeFloating
End If
Next
End If
End If
If hochformat = True Then
If TypeName(Selection) = "Picture" Or TypeName(Selection) = "Grafik" Then 'nur _
wenn Grafik markiert ist :
With Selection.ShapeRange
.LockAspectRatio = True
'Breite und Höhe der Grafik bitte in Klammer hier anpassen :
.Top = rngLocation.Top + 10
.Left = rngLocation.Left + 30
.Height = Application.CentimetersToPoints(9)
.Width = Application.CentimetersToPoints(7.25)
End With
For Each shpBild In ActiveSheet.Shapes
If shpBild.Type = msoPicture Then
shpBild.Placement = xlFreeFloating
End If
Next
End If
End If
End If
End If
Exit Sub
fehlerbehandlung:
If Err.Number = 1004 Then MsgBox "Fehler beim Einfügen der Grafik!" _
& Chr(13) & Chr(13) & "Wahrscheinlich kein lesbares Grafikformat"
End Sub
Ich wär euch für Hilfe super dankbar!Gruß
A.