CodeDocu.com

Word template: Add photo, Auto-rotate and adjust width and height
 
The following word example in a Word template shows how to automatically select a photo and paste it into the Word document.
In the photo in size will be adapted and automatically rotates.
Word template: Add photo, Auto-rotate and adjust width and height
To rotate, and rotate an image in Word, you must convert the image into a shape and then turn

objShape.IncrementRotation 90
 

 
 
The width and height is applied directly in the image object ZentimeterToPoints

'< 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 >
 

 
Note: Photos are usually inserted as inline shapes. This you must edit in a free standing shape short convert, apply corrections and converting then back

'< 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 >--
 

 
 
 
 
 
Complete vba code for download or use

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
 
 
 

  


Software Entwicklung Stuttgart NĂ¼rtingen
Suche Projekte C#, WPF, Windows App,ASP.Net, vb.Net, WinForms, SQL Server, Access, Excel