I use this code to insert images from a folder in a word document so I can print / read / save as a single document.
I did some adaptations, and here's the code that works to me (may not work or not suitable for everyone):
(I appreciate suggestions to optimize)
I JUST USE THIS CODE WITH A BLANK DOCUMENT.
Thanks.
Code:
Sub Add_images_from_folder()
Dim doc As Word.Document, fd As FileDialog, vItem As Variant, mg1 As Range, mg2 As Range, x As Integer
Dim sWidth As Double, sHeight As Double, sc As Double, scW As Double, scH As Double, Sca, Rot As Double
On Error Resume Next
Set fd = Application.FileDialog(msoFileDialogFilePicker)
Set doc = ActiveDocument
Application.ScreenUpdating = False
With doc.PageSetup
.LeftMargin = CentimetersToPoints(1)
.RightMargin = CentimetersToPoints(1)
.TopMargin = CentimetersToPoints(1)
.BottomMargin = CentimetersToPoints(1)
sWidth = .PageWidth - .LeftMargin - .RightMargin
sHeight = .PageHeight - .TopMargin - .BottomMargin
End With
With fd
.Filters.Add "Images", "*.bmp; *.gif; *.jpg; *.jpeg; *.pdf; *.png", 1
.FilterIndex = 1
If .Show = -1 Then
Rot = InputBox("Rotation (degress):", "Rotate the images?", 0)
If Rot = vbNull Then Exit Sub
Sca = MsgBox("Fit images to margins?", vbExclamation + vbYesNoCancel)
If Sca = vbCancel Then Exit Sub
For Each vItem In .SelectedItems
Set mg2 = doc.Range
mg2.Collapse wdCollapseEnd
doc.InlineShapes.AddPicture FileName:=vItem, LinkToFile:=False, SaveWithDocument:=True, Range:=mg2
Set mg1 = doc.Range
mg1.Collapse wdCollapseEnd
x = x + 1
If Rot <> 0 Then
doc.InlineShapes(x).ConvertToShape
With doc.Shapes(1)
.IncrementRotation (Rot)
.ConvertToInlineShape
.Select
End With
With Selection
.Copy
.Delete
.PasteSpecial DataType:=14
End With
End If
doc.InlineShapes(x).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
If Sca = vbYes Then
With doc.InlineShapes(x)
scW = 1 + (sWidth - .Width) / .Width
scH = 1 + (sHeight - .Height) / .Height
If scW < scH Then sc = scW Else sc = scH
.LockAspectRatio = msoFalse
.Width = .Width * sc
.Height = .Height * sc
End With
End If
Next vItem
End If
End With
With doc.ActivePane.View.Zoom
.PageColumns = 5
.PageRows = 2
End With
Set fd = Nothing
Selection.HomeKey Unit:=wdStory
Application.ScreenUpdating = True
End Sub