Word Vorlage: Foto einfügen, automatisch drehen und in Breite und Höhe anpassen
Das folgende Word Code Beispiel zeigt in einer Word Vorlage, wie man ein Foto automatisch auswählen und in das Word Dokument einfügen kann.
Dabei wird das Foto in der Größe angepasst und automatisch gedreht.
Zum Drehen und Rotieren eines Bildes in Word muss man das Bild in ein Shape umwandeln und anschliessend drehen
objShape.IncrementRotation 90
|
Die Breite und Höhe wird direkt im Bild-Objekt per ZentimeterToPoints angewendet
'< not rotated >
objShape.Width = CentimetersToPoints(intWidth) 'size Width
'size Heigth optional if oversize
If objShape.Height > CentimetersToPoints(intHeight) Then
objShape.Height = CentimetersToPoints(intHeight)
End If
'</ not rotated >
|
Notiz: Fotos werden normalerweise als Inline-Shapes eingefügt. Diese muss man zum Bearbeiten kurz in ein freistehendes Shape umwandeln, die Korrekturen anwenden und anschliessend zurück umwandeln
'< insert picture from Link >
Set objInlineShape = ActiveDocument.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=False, SaveWithDocument:=True, Range:=act_Image_Range)
'</ insert picture from Link >
'--< Scale and Rotate >--
Dim objShape As Shape
Set objShape = objInlineShape.ConvertToShape
'< Rotate and Scale >
Set objInlineShape = objShape.ConvertToInlineShape
'--</ Scale and Rotate >--
|
'----< Insert Image >----
'< insert picture from Link >
Set objInlineShape = ActiveDocument.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=False, SaveWithDocument:=True, Range:=act_Image_Range)
'</ insert picture from Link >
'--< Scale and Rotate >--
Dim objShape As Shape
Set objShape = objInlineShape.ConvertToShape
' '< Rotate >
' If objShape.Height < objShape.Width Then
' objShape.IncrementRotation 90
' End If
' '</ Rotate >
'-< scale >-
objShape.LockAspectRatio = msoTrue
If objShape.Rotation = 0 Then
'< not rotated >
objShape.Width = CentimetersToPoints(intWidth) 'size Width
'size Heigth optional if oversize
If objShape.Height > CentimetersToPoints(intHeight) Then
objShape.Height = CentimetersToPoints(intHeight)
End If
'</ not rotated >
Else
'< is rotated >
objShape.Height = CentimetersToPoints(intWidth) 'size Width
'size width optional if oversize
If objShape.Width > CentimetersToPoints(intHeight) Then
objShape.Width = CentimetersToPoints(intHeight)
End If
'</ is rotated >
End If
'-</ scale >-
Set objInlineShape = objShape.ConvertToInlineShape
'--</ Scale and Rotate >--
|
Kompletter vba Code zum Download oder verwenden
Option Explicit On
'----< Setup Parameters >----
Const const_sting_Path_Photos_Default = "C:\_Daten\Desktop\#ANDRO\100ANDRO 2016-10-06\2016-10-09 Ciabatta Brot" 'C:\_Daten\Desktop\Uni\Fotos"
Const const_int_Width_Foto_01 = 13
Const const_int_Height_Foto_01 = 18
'----</ Setup Parameters >----
'============< Buttons >============
Private Sub btnFoto1_Click()
a00_Insert_1_Photo_by_Selection_InLINE const_int_Height_Foto_01, const_int_Width_Foto_01
End Sub
Private Sub btnEinfuegen_Click()
a01_Insert_Photos_by_Selection_InLINE 12
End Sub
'============</ Buttons >============
Public Sub a00_Insert_1_Photo_by_Selection_InLINE(ByVal intHeight As Integer, ByVal intWidth As Integer)
'-----------------< a00_Insert_1_Photo_by_Selection_InLINE() >-----------------
'--< Import-Dialog >--
Dim objFiledialog As FileDialog
Set objFiledialog = Application.FileDialog(msoFileDialogFilePicker)
objFiledialog.AllowMultiSelect = True
objFiledialog.ButtonName = "Import Images"
objFiledialog.Filters.Add "Images Photos", "*.jpg;*.tiff;*.gif"
objFiledialog.Title = "Select the photos.."
objFiledialog.InitialView = msoFileDialogViewTiles
objFiledialog.InitialFileName = const_sting_Path_Photos_Default
objFiledialog.AllowMultiSelect = False
If Not objFiledialog.Show() = True Then
Exit Sub
End If
'--< Import-Dialog >--
'--< Check >--
'< check Selection >
If Not objFiledialog.SelectedItems().Count = 1 Then
Exit Sub
End If
'</ check Selection >
'--</ Check >--
Selection.MoveDown ' .TypeText Text:=Chr(11)
On Error Resume Next
'-------< @Loop: Insert all Images >--------
Dim objInlineShape As inlineShape
Dim sFilename As String
'------< Loop.Item >------
Dim act_Image_Range As Range
Set act_Image_Range = Selection.Range
'< get selection >
sFilename = objFiledialog.SelectedItems(1)
'</ get selection >
'----< Insert Image >----
'< insert picture from Link >
Set objInlineShape = ActiveDocument.InlineShapes.AddPicture(FileName:=sFilename, LinkToFile:=False, SaveWithDocument:=True, Range:=act_Image_Range)
'</ insert picture from Link >
'--< Scale and Rotate >--
Dim objShape As Shape
Set objShape = objInlineShape.ConvertToShape
' '< Rotate >
' If objShape.Height < objShape.Width Then
' objShape.IncrementRotation 90
' End If
' '</ Rotate >
'-< scale >-
objShape.LockAspectRatio = msoTrue
If objShape.Rotation = 0 Then
'< not rotated >
objShape.Width = CentimetersToPoints(intWidth) 'size Width
'size Heigth optional if oversize
If objShape.Height > CentimetersToPoints(intHeight) Then
objShape.Height = CentimetersToPoints(intHeight)
End If
'</ not rotated >
Else
'< is rotated >
objShape.Height = CentimetersToPoints(intWidth) 'size Width
'size width optional if oversize
If objShape.Width > CentimetersToPoints(intHeight) Then
objShape.Width = CentimetersToPoints(intHeight)
End If
'</ is rotated >
End If
'-</ scale >-
Set objInlineShape = objShape.ConvertToInlineShape
'--</ Scale and Rotate >--
'--< replace as png >--
'*reduce memory 1 MB to 1kb
'< cut >
objInlineShape.Select
Selection.Cut
'</ cut >
'*pasteBitmap is much smaller
act_Image_Range.PasteSpecial link:=False, DataType:=wdPasteBitmap, Placement:=wdInLine, DisplayAsIcon:=False
act_Image_Range.Select
Dim inlineShape As inlineShape
Set inlineShape = ActiveDocument.InlineShapes(ActiveDocument.InlineShapes.Count)
'--</ replace as png >--
'< add spacer >
'Selection.MoveRight
Selection.TypeText Text:=Chr(13) '11 or 13 newline
Selection.TypeText Text:="Bild 1: Übersicht"
Selection.TypeText Text:=Chr(13) 'newline
Selection.InsertBreak wdPageBreak 'or wdNext-page section break
'</ add spacer >
If Err.Number <> 0 Then
MsgBox Err.Description
Err.Clear
End If
'----</ Insert Image >----
'------</ Loop.Item >------
'-------</ @Loop: Insert all Images >--------
'-------< @Loop: create all JPG Thumbnails >--------
'*create png Bitmaps and jpg thumbnails when saved as website
For Each objInlineShape In ActiveDocument.InlineShapes
objInlineShape.Line.Style = msoLineSingle
objInlineShape.Line.Weight = 1
Next
'-------</ @Loop: create all JPG Thumbnails >--------
'-----------------</ a0_Insert_Photos_by_Selection() >-----------------
End Sub
|