Thread: [Solved] Organize shapes
View Single Post
 
Old 05-03-2019, 04:31 PM
eduzs eduzs is offline Windows 10 Office 2010 32bit
Expert
 
Join Date: May 2017
Posts: 260
eduzs is on a distinguished road
Default

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
Reply With Quote