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.




Opening all selected images
Resizing images
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]

20360 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-vba/36782-opening-all-selected-images-resizing-images-placing.html
Please read VBA Express' policy on Cross-Posting in item 3 of the rules: http://www.vbaexpress.com/forum/faq.php?faq=new_faq_item#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! :content:
This saves me a lot of work!
I will be sure to follow your guidelines.