Sub BildgroesseAnpassen()
'Aktivierte Grafik formatieren :
If TypeName(Selection) = "Picture" Then 'nur wenn Grafik markiert ist :
With Selection.ShapeRange
.LockAspectRatio = False
'Breite und Höhe der Grafik bitte in Klammer hier anpassen :
.Height = Application.CentimetersToPoints(6.77)
.Width = Application.CentimetersToPoints(9.03)
End With
End If
End Sub
Sub AlleBildgroessenAnpassen()
Dim objPic As Object
For Each objPic In ActiveSheet.Pictures
'Alle Grafiken formatieren :
With objPic.ShapeRange
.LockAspectRatio = False
'Breite und Höhe der Grafik bitte in Klammer hier anpassen :
.Height = Application.CentimetersToPoints(6.77)
.Width = Application.CentimetersToPoints(9.03)
End With
Next
End Sub
Sub AlleBildgroessenAnpassen()
Dim objPic As Object
For Each objPic In ActiveDocument.InlineShapes
With objPic
.LockAspectRatio = msoFalse
.Width = Application.CentimetersToPoints(9.03)
.Height = Application.CentimetersToPoints(6.77)
End With
Next
End Sub
ein Querformatbild muss die Maße ja "anders herum" haben.
Geht es nicht irgendwie, dass das Bild bereits beim einfügen angepasst wird?
'Erstellt unter Word 2003 / Windows XP
Sub Grafik_Laden()
' Grafik_Laden Makro
' Grafik laden, Größe anpassen und ggf. drehen
Dim objDoc As Document, DateiGrafik As Variant, objGrafik As InlineShape
Dim objShape As Shape
Dim Auswahl
Set objDoc = ActiveDocument
With Application.FileDialog(msoFileDialogOpen)
.Title = "Bitte zu ladende Grafikdatei auswählen"
.InitialView = msoFileDialogViewPreview
.ButtonName = "Datei wählen"
If .Show = -1 Then
Selection.InlineShapes.AddPicture FileName:= _
.SelectedItems(1), LinkToFile:=False, SaveWithDocument:=True
Set objGrafik = objDoc.InlineShapes(objDoc.InlineShapes.Count)
'Eingefügtes Bild formatieren - Zeilen mit nicht anzupassenden Formate ggf. _
auskommentieren
With objGrafik
.Fill.Visible = msoFalse
.Fill.Solid
.Fill.Transparency = 0#
.Line.Weight = 0.75
.Line.Transparency = 0#
.Line.Visible = msoFalse
.LockAspectRatio = msoFalse 'Größenverhältniss nicht sperren - verzerrt ggf die _
Bilder
.Height = Application.CentimetersToPoints(6.77) 'Höhe
.Width = Application.CentimetersToPoints(9.03) 'Breite
.PictureFormat.Brightness = 0.5
.PictureFormat.Contrast = 0.5
.PictureFormat.ColorType = msoPictureAutomatic
.PictureFormat.CropLeft = 0#
.PictureFormat.CropRight = 0#
.PictureFormat.CropTop = 0#
Set objShape = .ConvertToShape 'Umwandlung für Drehen erforderlich
End With
With objShape
Grafik_Drehen:
.WrapFormat.Type = wdWrapSquare 'für Drehen erforderlich
Auswahl = VBA.InputBox(Prompt:="Bild drehen?" & vbLf & vbLf _
& " 0 = nicht drehen" & vbLf _
& " 1 = 90 Grad nach rechts drehen" & vbLf _
& " 2 = 90 Grad nach links drehen" & vbLf _
& " 3 = 180 Grad nach rechts drehen", _
Title:="Eingefügte Grafik Drehen", _
Default:=0)
If Not Auswahl = False Then
Select Case Auswahl
Case 0
Case 1
.IncrementRotation 90#
Case 2
.IncrementRotation -90#
Case 3
.IncrementRotation -90#
.IncrementRotation -90#
Case Else
MsgBox "Unzulässige Auswahl für Drehen Grafik. Bitte Eingabe wiederholen"
GoTo Grafik_Drehen
End Select
End If
.ConvertToInlineShape 'Rückkonvertierung
End With
End If
End With
End Sub
Sub BildgroesseQuerAnpassen()
'Aktivierte Grafik im Querformat in Größe anpassen
Dim objRange As Object
On Error GoTo Fehler
Set objRange = Selection.InlineShapes(1)
With objRange
.LockAspectRatio = False
'Breite und Höhe der Grafik bitte in Klammer hier anpassen :
.Height = Application.CentimetersToPoints(6.77)
.Width = Application.CentimetersToPoints(9.03)
End With
Fehler:
With Err
Select Case .Number
Case 0 'Kein Fehler
Case Else
MsgBox "Fehler-nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub
Sub BildgroesseHochAnpassen()
'Aktivierte Grafik im Hochformat in Größe reduzieren
Dim objRange As Object
On Error GoTo Fehler
Set objRange = Selection.InlineShapes(1)
With objRange
.LockAspectRatio = False
'Breite und Höhe der Grafik bitte in Klammer hier anpassen :
.Height = Application.CentimetersToPoints(9.03)
.Width = Application.CentimetersToPoints(6.77)
End With
Fehler:
With Err
Select Case .Number
Case 0 'Kein Fehler
Case Else
MsgBox "Fehler-nr.: " & .Number & vbLf & .Description
End Select
End With
End Sub