View Full Version : [SOLVED:] Insert images, from 3 different folders, into to specific locations of same document
Tahmz
04-12-2017, 02:13 AM
18912
Hi Guys, I am new to VBA and i am trying to:
Write a macro to do a photo report on ms word.
I wish to batch insert photos into location A,B and C from the folders A,B and C respectively.
The macro should be able to:
- Add the first picture in folder A to Area A in page 1, then add the second picture in folder A to Area A in page 2....till the last picture in folder A has been added.
- Repeat this process for adding first picture in folder B to Area B in Page 1...
- Repeat this process for C
- Add a caption line under each picture
- If any picture is deleted, for example, page 2B is deleted, page 3B moves up to fill up the black space for 2B.
- The size of B and C is same. A is smaller (refer to attached image)
This is a rather complicated process for me. So far, through the help of other questions in this forum, i am able to insert pictures via macro from 1 folder only. I am also able to add captions. But i am unable to access more than 1 folder. I am trying to add over 200 pages at a time per document.
Do i need to use bookmarks?
Any help would be appreciated.
Tahmz:crying:
gmaxey
04-12-2017, 04:30 AM
Where is the code you have managed so far?
macropod
04-12-2017, 06:29 AM
Do all the required pages & tables (assuming that's what your 'areas' are) already exist, or is the code supposed to add them as it goes? Does each table (again, assuming that's what your 'areas' are) have two rows - one for the picture and one for the caption? Assuming the answers to both questions are yes, the following macro could be used:
Sub AddPicsFromFolders()
Application.ScreenUpdating = False
Dim ArrFldr(), ArrHght(), oTbl As Table, i As Long, j As Long
Dim strFolder As String, strFile As String
ArrFldr() = Array("Folder1", "Folder2", "Folder3")
ArrHght() = Array(2, 3, 3)
CaptionLabels.Add Name:="Picture"
For i = 0 To UBound(ArrFldr())
strFolder = "C:\Users\" & Environ("Username") & "\Pictures\" & ArrFldr(i) & "\"
strFile = Dir(strFolder & "*.jpg", vbNormal)
j = 0
While strFile <> ""
j = j + 1
Set oTbl = ActiveDocument.Tables(j * (UBound(ArrFldr()) + 1) - UBound(ArrFldr()) + i)
With oTbl
.AllowAutoFit = False
'Format the rows
Call FormatRows(oTbl, CSng(ArrHght(i)))
'Insert & size the Picture
.Range.InlineShapes.AddPicture FileName:=strFolder & strFile, LinkToFile:=False, _
SaveWithDocument:=True, Range:=.Cell(1, 1).Range
With .Range.InlineShapes(1)
.LockAspectRatio = True
.Height = InchesToPoints(CSng(ArrHght(i)))
End With
'Insert the Caption on the row below the picture
With .Cell(.Rows.Count, 1).Range
.InsertBefore vbCr
.Characters.First.InsertCaption Label:="Picture", _
Title:=Split(strFile, ".")(0), _
Position:=wdCaptionPositionBelow, ExcludeLabel:=False
.Characters.First = vbNullString
.Characters.Last.Previous = vbNullString
End With
End With
If j Mod 10 = 0 Then DoEvents
strFile = Dir()
Wend
Next
Application.ScreenUpdating = True
End Sub
'
Sub FormatRows(oTbl As Table, Hght As Single)
With oTbl
With .Rows(1)
.Height = InchesToPoints(Hght)
.HeightRule = wdRowHeightExactly
.Range.Style = "Normal"
End With
With .Rows(2)
.Height = InchesToPoints(0.25)
.HeightRule = wdRowHeightExactly
.Range.Style = "Caption"
End With
End With
End Sub
As coded, the macro :
• assumes the pictures to be inserted are in folders named Folder1, Folder2, & Folder3, respectively, in your Pictures folder. Change the filepaths to suit.
• doesn't require you to have the table row-height pre-set; it does that for itself using the heights (in inches) specified in 'ArrHght() = Array(2, 3, 3)', which presently applies 2, 3, & 3 inch heights, respectively.
• uses the "Normal" and "Caption" Styles for the image and caption rows, respectively. These both left-align the content, but you can change that and/or which Styles get used. Whichever Style you use for the image row, it should have 0 space before & after; otherwise the image won't fit properly.
If you'd rather the macro did no table formatting, you could comment-out 'Call FormatRows(oTbl, CSng(ArrHght(i)))'
Tahmz
04-16-2017, 10:37 PM
Hi Greg
Hi Paul
Thank you for the very quick response. I have tried the code that you have provided. When i run the code, nothing happens. But at the same time, there are no errors.
I have changed the file path like you mentioned but it did not run. Were you able to run this on your system?
For the most part, i understand what you are trying to do using arrays.
This is what i compiled previously in order to add pictures from a folder(found this somewhere online):
Sub InsertImage()
Dim fd As FileDialog
Dim oTable As Table
Dim iRow As Integer
Dim iCol As Integer
Dim oCell As Range
Dim i As Long
Dim sNoDoc As String
Dim picName As String
Dim scaleFactor As Long
Dim max_height As Single
'define resize constraints
max_height = 275
'add a 1 row 2 column table to take the images
Set oTable = Selection.Tables.Add(Selection.Range, 1, 1)
'+++++++++++++++++++++++++++++++++++++++++++++
'oTable.AutoFitBehavior (wdAutoFitFixed)
oTable.Rows.Height = CentimetersToPoints(4)
oTable.Range.Cells.VerticalAlignment = wdCellAlignVerticalCenter
'++++++++++++++++++++++++++++++++++++++++++++++
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Title = "Select image files and click OK"
.Filters.Add "Images", "*.gif; *.jpg; *.jpeg; *.bmp; *.tif; *.png; *.wmf"
.FilterIndex = 2
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
iCol = 1
iRow = i
'get filename
picName = Right(.SelectedItems(i), Len(.SelectedItems(i)) - InStrRev(.SelectedItems(i), "\"))
'remove extension from filename ****
picName = Left(picName, InStrRev(picName, ".") - 1)
'select cell
Set oCell = ActiveDocument.Tables(1).Cell(iRow, iCol).Range
'insert image
oCell.InlineShapes.AddPicture FileName:= _
.SelectedItems(i), LinkToFile:=False, _
SaveWithDocument:=True, Range:=oCell
'resize image
If oCell.InlineShapes(1).Height > max_height Then
scale_factor = oCell.InlineShapes(1).ScaleHeight * (max_height / oCell.InlineShapes(1).Height)
oCell.InlineShapes(1).ScaleHeight = scale_factor
oCell.InlineShapes(1).ScaleWidth = scale_factor
End If
'center content
oCell.ParagraphFormat.Alignment = wdAlignParagraphCenter
'insert caption below image
oCell.InlineShapes(1).Range.InsertCaption Label:="Figure", TitleAutoText:="", _
Title:=": " & picName
If i < .SelectedItems.Count And i Mod 2 = 0 Then 'add another row, more to go
oTable.Rows.Add
End If
Next i
End If
End With
Set fd = Nothing
End Sub
macropod
04-17-2017, 12:17 AM
I have tried the code that you have provided. When i run the code, nothing happens. But at the same time, there are no errors.
I have changed the file path like you mentioned but it did not run.
That's most likely because your document doesn't satisfy the conditions stipulated in my post about the macro - three tables per page; one for each image.
Tahmz
04-17-2017, 12:48 AM
Hi Paul
Thanks for the reply. I added in the 3 tables ( with 2 rows each, 1 for pic 1 for caption). But still i do not see anything happening. 18950
My original intention was not to use tables though using tables is fine as well. But i do not see any errors when i run the code either. Any idea what could be wrong?
Tahmz
04-17-2017, 12:52 AM
Okay i managed to get something. I realized that the file path had an issue. Thanks so much paul
Powered by vBulletin® Version 4.2.5 Copyright © 2025 vBulletin Solutions Inc. All rights reserved.