Opening all selected images, resizing images and placing them into a table

[JohnLivewire]

Hi,
I need your help to solve a little challenge I have. I repeat at these tasks everyday for hours on end and need a way to automate these tasks.

1. Opening all selected images
2. Resizing images
3. Placing them into a table

My question is in the youtube video:

youtube.com/watch?v=Kj2VuqXn7Fk&feature=youtu.be

Your help is greatly appreciated! Thanks!

[macropod]

What are the resizing parameters?

[JohnLivewire]

Screenshot (27).jpg Aspect ratio locked and two inches in height.

[macropod]

The following macro embeds all Shapes & InlineShapes in a document in tables as InlineShapes with a row for Captions. Whatever positioning applied to the original Shape object will apply to the table also.

As specified, the macro sets the inserted image heights to 2in.

Sub MakeImageTables()
Dim iShp As InlineShape, Rng As Range, Tbl As Table
Dim i As Long, PicWdth As Single, PicHght As Single, VPos As Single
Dim HPos As Single, VRel As Long, HRel As Long, BShp As Boolean
PicHght = InchesToPoints(2)
With ActiveDocument
  For i = 1 To .InlineShapes.Count
    If .InlineShapes(i).Range.Information(wdWithInTable) = False Then
      With .InlineShapes(i)
        .LockAspectRatio = True
        .Height = PicHght
        PicWdth = .Width
        Set Rng = .Range
      End With
      With Rng
        If .Characters.Last.Next.Text = vbCr Then .Characters.Last.Next.Text = vbNullString
        .InlineShapes(1).Range.Cut
      End With
      BShp = False: VRel = 0: HRel = 0: VPos = 0: HPos = 0
      Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
    End If
  Next
  While .Shapes.Count > 0
    BShp = True
    With .Shapes(1)
      .LockAspectRatio = True
      .Height = PicHght
      PicWdth = .Width
      VRel = .RelativeVerticalPosition
      HRel = .RelativeHorizontalPosition
      VPos = .Top
      HPos = .Left
      Set iShp = .ConvertToInlineShape
    End With
    With iShp
      Set Rng = .Range
      .Range.Cut
    End With
    Call MakeImageTable(Rng, PicWdth, PicHght, BShp, VRel, HRel, VPos, HPos)
  Wend
End With
End Sub
 
Sub MakeImageTable(Rng As Range, PicWdth As Single, PicHght As Single, BShp As Boolean, _
  VRel As Long, HRel As Long, VPos As Single, HPos As Single)
Dim Tbl As Table, sngScl As Single, iShp As InlineShape
'Create & format the table
Set Tbl = Rng.Tables.Add(Range:=Rng, Numrows:=1, NumColumns:=1)
With Tbl
  .Borders.Enable = True
  .Columns.Width = PicWdth
  .TopPadding = 0
  .BottomPadding = 0
  .LeftPadding = 0
  .RightPadding = 0
  .Spacing = 0
  .Rows(1).HeightRule = wdRowHeightExactly
  .Rows(1).Height = PicHght
  With .Rows
    .LeftIndent = 0
    If BShp = True Then
      .WrapAroundText = True
      .HorizontalPosition = HPos
      .RelativeHorizontalPosition = HRel
      .VerticalPosition = VPos
      .RelativeVerticalPosition = VRel
      .AllowOverlap = False
    End If
  End With
  With .Cell(1, 1).Range
    With .ParagraphFormat
      .SpaceBefore = 0
      .SpaceAfter = 0
      .LeftIndent = 0
      .RightIndent = 0
      .FirstLineIndent = 0
      .KeepWithNext = True
    End With
    .Paste
  End With
End With
End Sub

As coded, the macro will reformat all extra-table images in the document. To work with just the selected image (or multiple images in a selected range), change:
With ActiveDocument
to:
With Selection
and change:
While .Shapes.Count > 0
With .Shapes(1)
to:
While .ShapeRange.Count > 0
With .ShapeRange(1)

[macropod]

Cross-posted at: http://www.msofficeforums.com/word-v...s-placing.html
Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq...._new_faq_item3

[JohnLivewire]

Thanks for your help macropod. I'm sorry for cross-posting. I'm new to a VBA forum site.

There is an error with your code.
Please take a look at my video reply at youtube.com/watch?v=bl--AWcVMEw

[JohnLivewire]

This is an example of the project I'm doing for school. Check out attachment.

[macropod]

The code I posted is for creating a separate single-cell table for each image; you evidently want all images to appear in the same table - and you want a second column for the table as well. It would have been helpful had to stated clearly what you require.

[JohnLivewire]

I'm very sorry for any confusion and I wouldn't want to waste your time. I just created a step by step explanation of what I would like the code to do.


Step by step explanation:

1. I start off with a blank word document.

2. In the ribbon, I click: Developer tab > Macros.

3. I select the macro I need and click run.

4. The macros automatically opens a window prompting me to select my image files.

5. I select my images. (I could select anywhere from 1 image to 1000 images. The images I select can be of any dimension).

6. I click insert.

7. The images are inserted into my word document.

8. The macros automatically locks the aspect ratio of all images that were inserted into my word document.

9. The macros automatically changes the height of the images to 2 inches.

10. The width is automatically scaled on its own because the aspect ratio is locked.

11. The macros automatically creates a table of 2 columns by X number of rows.
The X number of rows is determined by how many images were inserted. So if 6 images were inserted then 6 rows are created. If 900 images were inserted then 900 rows are created and so on so forth.

12. The macros automatically places the images into the table. They are placed like this:
Image 1 goes into row 1 of column 1.
Image 2 goes into row 2 of column 1.
Image 3 goes into row 3 of column 1.
Image 4 goes into row 4 of column 1.
Image 5 goes into row 5 of column 1.
Image X goes into row X of column 1.


EXAMPLE IS IN THE ATTACHMENTMENT

[JohnLivewire]

Here are some more Examples:

[macropod]

Try the following macro, which you also use for the picture selection before inserting them into the document:

Sub AddPics()
Application.ScreenUpdating = False
Dim oTbl As Table, TblWdth As Single, RwHght As Single, PicWdth As Single, r As Long
RwHght = InchesToPoints(2)
On Error GoTo 0 'Select and insert the Pics
With Application.FileDialog(msoFileDialogFilePicker)
  .Title = "Select image files and click OK"
  .Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png"
  .FilterIndex = 2
  If .Show = -1 Then
    'Add a 1-row by 2-column table to take the images
    Set oTbl = Selection.Tables.Add(Range:=Selection.Range, NumRows:=1, NumColumns:=2)
    With ActiveDocument.PageSetup
      TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
    End With
    With oTbl
      .AutoFitBehavior wdAutoFitFixed
      .PreferredWidthType = wdPreferredWidthPoints
      .PreferredWidth = TblWdth
      .Borders.Enable = True
      With .Range.Cells(1).Range.ParagraphFormat
        .SpaceBefore = 0
        .SpaceAfter = 0
        .LeftIndent = 0
        .RightIndent = 0
        .FirstLineIndent = 0
        .Alignment = wdAlignParagraphCenter
      End With
    End With
    For r = 1 To .SelectedItems.Count
        'Insert the Picture
        ActiveDocument.InlineShapes.AddPicture _
          FileName:=.SelectedItems(r), LinkToFile:=False, _
          SaveWithDocument:=True, Range:=oTbl.Cell(r, 1).Range
        With oTbl.Cell(r, 1).Range.InlineShapes(1)
          .LockAspectRatio = True
          .Height = RwHght
          If .Width > PicWdth Then PicWdth = .Width
        End With
      'Add extra rows as needed
      If r < .SelectedItems.Count Then
        oTbl.Rows.Add
      End If
    Next
    With oTbl
      With .Columns(1)
        .PreferredWidthType = wdPreferredWidthPoints
        .PreferredWidth = PicWdth + .Cells(1).LeftPadding + .Cells(1).RightPadding
      End With
      With .Columns(2)
        .PreferredWidthType = wdPreferredWidthPoints
        .PreferredWidth = TblWdth - PicWdth - .Cells(1).LeftPadding - .Cells(1).RightPadding
      End With
    End With
  End If
End With
Application.ScreenUpdating = True
End Sub

For future reference, kindly post the entire problem description in the thread; don't expect people to go looking at external content to find what really should be here. Should your YouTube videos get deleted, no-one would know how they relate to any discussion in the thread. Kindly also don't go using oversized fonts, etc. for your posts; they add nothing to its readability.

[JohnLivewire]

Wow thank you so much for this code. It worked like a charm!
This saves me a lot of work!
I will be sure to follow your guidelines.