Organize shapes

eduzs · #1 04-30-2019, 05:00 PM

Hi!

I need to arrange shapes so that each figure is on a document page.
The shapes are from JPG which I drag and drop into the document (as inlineshapes).
I started with this code:

Code:

Sub ResizePic()

Dim x As Integer

With ActiveDocument.PageSetup
    .LeftMargin = CentimetersToPoints(1)
    .RightMargin = CentimetersToPoints(1)
    .TopMargin = CentimetersToPoints(1)
    .BottomMargin = CentimetersToPoints(1)
    sWidth = .PageWidth - .LeftMargin - .RightMargin
End With

For x = 1 To ActiveDocument.InlineShapes.Count
    ActiveDocument.InlineShapes(1).Width = sWidth
    ActiveDocument.InlineShapes(1).ConvertToShape
Next x

For x = 1 To ActiveDocument.Shapes.Count
    ActiveDocument.Shapes(x).WrapFormat.Type = wdWrapSquare
Next x

End Sub

After running the macro, I got all the stacked pictures remain in a single-page document, instead of 1 shape per page. I also need that the shapes fit to the document width (resize shape).

Thanks!

gmayor · #2 04-30-2019, 09:14 PM

The images will adapt to the document width if the images are larger than the page width to start with, however smaller images will not.

The reason your code stacks the images is that you are converting them to shapes and adding a wrap option, for some reason which is not entirely clear, and then you are not repositioning the shapes. I see no reason to change them to shapes. The following will set your margins (though you could have done that before inserting the pictures) and will set the width to the width between the margins. As it is almost inevitable that there will be room for only one image on a page they will then be on separate pages.

Code:

Sub ResizePic()
Dim x As Integer
Dim lngWidth As Long
    With ActiveDocument.PageSetup
        .LeftMargin = CentimetersToPoints(1)
        .RightMargin = CentimetersToPoints(1)
        .TopMargin = CentimetersToPoints(1)
        .BottomMargin = CentimetersToPoints(1)
        lngWidth = .PageWidth - .LeftMargin - .RightMargin
    End With
    For x = 1 To ActiveDocument.InlineShapes.Count
        ActiveDocument.InlineShapes(x).Width = lngWidth
    Next x
End Sub

eduzs · #3 05-01-2019, 03:48 AM

Quote:

Originally Posted by gmayor

The images will adapt to the document width if the images are larger than the page width to start with, however smaller images will not.

The reason your code stacks the images is that you are converting them to shapes and adding a wrap option, for some reason which is not entirely clear, and then you are not repositioning the shapes. I see no reason to change them to shapes. The following will set your margins (though you could have done that before inserting the pictures) and will set the width to the width between the margins. As it is almost inevitable that there will be room for only one image on a page they will then be on separate pages.

Thanks gmayor!

I did some improvements, the code below will proportionally scale the shape to fit page margins (width and height) and apply a rotation (only available in shapes).

Have any optimization suggestions? Thanks!

Code:

 Code under construction

eduzs · #4 05-03-2019, 04:31 PM

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

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Filter or Lookup Formula to Organize Keywords	MKTGCLOUD	Excel	8	11-28-2018 07:35 PM
Best way to organize resources	Steve.	Project	3	05-17-2014 07:07 AM
Organize a shared mailbox with categories	remmyMartin	Outlook	0	04-03-2013 01:40 PM
Organize Sent mail/items	outlookissues	Outlook	0	05-13-2012 08:55 AM
organize files	userman	Excel	13	05-04-2012 03:49 PM