Generate tables to insert pictures from different folders

[Jeshi79]

19131

Hi Guys, :hi:

Would you please help me doing the following:

I am trying to write a macro to get photos from two different folders and insert them into a created a table with multiple cells of different sizes and multiple titles ( as in the attachment). I want to insert the two pictures in the specified cell for picture#1 and the specified cell for picture#2 into the table. This process has to be repeated for 100's of pictures contained in the two folders and generate tables as needed until finish all the pictures.

I have the same number of pictures in the two folders and I need to insert two pictures in each table as:

1. Cell Number 1 takes picture from folder 1
2. Cell number 2 takes picture from folder 2
3. Titles # 1,2,3,4, 5 and 6 are fixed for all the tables
4. There is no need to add caption for picture # 1
5. The caption for picture # 2 must be same as the file name of picture#2
6. The macro should generate only one table at each page
7. The orientation of the page must be landscape not portrait to accommodate the dimensions of the table
8. The Dimensions of the table must be same as in the attachment
9. Cells borders must appear in the table
10. The pictures size must be fixed to fit exactly in the cells and keeping the aspect ratio of the pictures to maintain picture quality

I am new to the VBA and I am seeking your kind help to do this task.

Thanks and regards, :friends:
Hussain

[macropod]

For some code to get you started, see:
http://www.vbaexpress.com/forum/showthread.php?48809-Insert-Multiple-Pictures&p=304226&viewfull=1#post304226
http://www.vbaexpress.com/forum/showthread.php?44473-Insert-Multiple-Pictures-Into-Table-Word-With-Macro&p=281157&viewfull=1#post281157
What's not clear from your post is:
• whether at least one of the required # of tables already exist or whether the macro is supposed to create them;
• how the picture pairs are determined (i.e. which two pictures go together);
• how many pairs are involved;
• whether multiple pairs (if that's what there are) all get added to the same table, or whether there is a separate table for each pair.

PS: Your post has no sample document as an attachment; just an image from which it's impossible to determine border requirements, etc.

[Jeshi79]

Hello Paul,

Thank you for your quick response...

To make myself more clear here are the answers for the questions you asked:

• whether at least one of the required # of tables already exist or whether the macro is supposed to create them;
I need the macro to create the table

• how the picture pairs are determined (i.e. which two pictures go together);
The macro should identify the paired pictures by their file names. The picture files in the two folders have the same names, but they are different type of images. The pictures in folder#1 are .TIF while the pictures in folder#2 are .emf

• how many pairs are involved;
The number of pairs is not always fixed for all the projects. In the current project I am working on, I have 301 pairs of pictures. In the next projects the number could be more or less than this number.

• whether multiple pairs (if that's what there are) all get added to the same table, or whether there is a separate table for each pair.
The pairs are added into one table that will show one pair at each page and show the all titles (title#1,2,3,4,5 & 6) plus the caption of picture#2 in every page.

PS: Your post has no sample document as an attachment; just an image from which it's impossible to determine border requirements, etc.
I attached the word file I am working on for clarification

Thank you again for all your help :help

[macropod]

If you save your attached document as a template, with the heading rows and just one empty 'image' row, there will be no need for the macro to create the table (for which a fair bit of code would be required); it can instead just create a new document from the template, then add as many rows as are needed.

[Jeshi79]

That's good. This solved the need to create the tables by macro. What about getting the images automatically into the table from the two folders to make the paired images.

Regards,
Hussain

[macropod]

Try something based on the following. You will need to update the filepaths for the image folders and both the filepath and filename for the template.

Sub Demo()
Application.ScreenUpdating = False
Dim strFldr1 As String, strFiles1 As String, wdDoc As Document
Dim strFldr2 As String, strFiles2 As String, strFile As String, r As Long
strFldr1 = "C:\Users\" & Environ("Username") & "\Pictures\Folder1\"
strFldr2 = "C:\Users\" & Environ("Username") & "\Pictures\Folder2\"
Set wdDoc = Documents.Add(Template:="C:\Users\" & Environ("Username") & "\Templates\Table.dotm")
strFiles1 = Dir(strFldr1 & "*.tif", vbNormal)
strFiles2 = Dir(strFldr2 & "*.emf", vbNormal)
With wdDoc.Tables(1)
While strFiles1 <> ""
.Rows.Add
r = .Rows.Count: strFile = Split(strFiles1, ".tif")(0)
.Range.InlineShapes.AddPicture FileName:=strFldr1 & strFiles1, _
LinkToFile:=False, Range:=.Cell(r, 1).Range
If InStr(strFiles2, strFile) > 0 Then
.Range.InlineShapes.AddPicture FileName:=strFldr2 & strFile & ".emf", _
LinkToFile:=False, Range:=.Cell(r, 2).Range
.Cell(r, 2).Range.Characters.Last.InsertBefore vbCr & strFile
End If
strFiles1 = Dir()
Wend
.Rows(3).Delete
End With
Application.ScreenUpdating = True
End Sub

[Jeshi79]

Hi Paul,

I would like to thank you first for all your help. I have tried the code you sent to me after updating the filepaths for the image folders and both the filepath and filename for the template as you instructed me. However, I faced several problems and here what I got when I tried to run the code:

1.If I run the code as it is, It will not insert any image from Folder2(.emf). I think because of line specifying the directory of files form folder 2.

Sub Demo()
Application.ScreenUpdating = False
Dim strFldr1 As String, strFiles1 As String, wdDoc As Document
Dim strFldr2 As String, strFiles2 As String, strFile As String, r As Long
strFldr1 = "C:\Users\" & Environ("Username") & "\Pictures\Folder1\"
strFldr2 = "C:\Users\" & Environ("Username") & "\Pictures\Folder2\"
Set wdDoc = Documents.Add(Template:="C:\Users\" & Environ("Username") & "\Templates\Table.dotm")
strFiles1 = Dir(strFldr1 & "*.tif", vbNormal)

strFiles2 = Dir(strFldr1 & "*.emf", vbNormal)
With wdDoc.Tables(1)
While strFiles1 <> ""
.Rows.Add
r = .Rows.Count: strFile = Split(strFiles1, ".tif")(0)
.Range.InlineShapes.AddPicture FileName:=strFldr1 & strFiles1, _
LinkToFile:=False, Range:=.Cell(r, 1).Range
If InStr(strFiles2, strFile) > 0 Then
.Range.InlineShapes.AddPicture FileName:=strFldr2 & strFile & ".emf", _
LinkToFile:=False, Range:=.Cell(r, 2).Range
.Cell(r, 2).Range.Characters.Last.InsertBefore vbCr & strFile
End If
strFiles1 = Dir()
Wend
.Rows(3).Delete
End With
Application.ScreenUpdating = True
End Sub


2. After I change that line to:
strFiles2 = Dir(strFldr2 & "*.emf", vbNormal)
The code worked and brought only the first pair correctly (.tif + .emf) and stopped with an error message (attached with the Debug) :banghead:

Cheers,
Hussian

[macropod]

OK, the reference to:
strFiles2 = Dir(strFldr1 & "*.emf", vbNormal)
should have been to:
strFiles2 = Dir(strFldr2 & "*.emf", vbNormal)
which I've fixed. Regardless, the code needed further tweaking. Try something based on:

Sub Demo()
Application.ScreenUpdating = False
Dim strFldr1 As String, strFiles1 As String, strTmp As String, wdDoc As Document
Dim strFldr2 As String, strFiles2 As String, strFile As String, r As Long
strFldr1 = "C:\Users\" & Environ("Username") & "\Pictures\Folder1\"
strFldr2 = "C:\Users\" & Environ("Username") & "\Pictures\Folder2\"
strFiles2 = Dir(strFldr2 & "*.emf", vbNormal): strTmp = "|"
While strFiles2 <> ""
strTmp = strTmp & "|" & Split(strFiles2, ".emf")(0)
strFiles2 = Dir()
Wend
strFiles1 = Dir(strFldr1 & "*.tif", vbNormal)
Set wdDoc = Documents.Add(Template:="C:\Users\" & Environ("Username") & "\Templates\Table.dotm")
With wdDoc.Tables(1)
While strFiles1 <> ""
.Rows.Add
r = .Rows.Count: strFile = Split(strFiles1, ".tif")(0)
.Range.InlineShapes.AddPicture FileName:=strFldr1 & strFiles1, _
LinkToFile:=False, Range:=.Cell(r, 1).Range
If InStr(strTmp, "|" & strFile & "|") > 0 Then
.Range.InlineShapes.AddPicture FileName:=strFldr2 & strFile & ".emf", _
LinkToFile:=False, Range:=.Cell(r, 2).Range
.Cell(r, 2).Range.Characters.Last.InsertBefore vbCr & strFile
End If
strFiles1 = Dir()
Wend
.Rows(3).Delete
End With
Application.ScreenUpdating = True
End Sub

[Jeshi79]

I have tried the last code you sent to me and the result was getting only the template as it is without adding any extra cells or images at all. Also, if I wrote the path of the template as:


Set wdDoc = Documents.Add(Template:="C:\Users\" & Environ("Username") & "\Templates\Table.dot")
I get an error message .

To let it work I had to write the path in the following way:

Set wdDoc = Documents.Add(Template:="C:\Users\Test\Templates\Table5.dot")

Please, see the error message and debug attached


Cheers,
Hussain

[macropod]

As I said in my last reply, your implementation of the macro should be 'based on' the code I posted, just as I said in my previous reply. And, as in my previous reply, you need to update the paths & filenames to suit your setup. Although I could have written the code to use:
Set wdDoc = Documents.Add(Template:="C:\Users\Test\Templates\Table5.dot")
I did not do so, because that seemed to omit the username. Apparently, you're using an account whose username is 'Test'. Hard-coding the macro that way might be fine for the 'Test' user, but it won't work for any other user. Regardless, changing:
Environ("Username")
to:
Environ("Test")
is bound to cause an error - you've replaced the 'UserName' environment variable for one named 'Test' - and I don't even know whether such a variable exists on your system. At most, all you needed to change on this line was the filename:

Set wdDoc = Documents.Add(Template:="C:\Users\" & Environ("Username") & "\Templates\Table5.dot")
Even so, once we have the code working, I'll be providing you with a revised version to add to the template itself and we won't need that line...

[Jeshi79]

Thank you Paul for explaining Environ function use. Now it is clear for me. I rewrote the paths for the folders and the templates in the code as you instructed me to be:


strFldr1 = "C:\Users\" & Environ("Username") & "\Pictures\Folder1\"
strFldr2 = "C:\Users\" & Environ("Username") & "\Pictures\Folder2\"

Set wdDoc = Documents.Add(Template:="C:\Users\" & Environ("Username") & "\Templates\Table.dot")

Now the code return no error, but at the same time it is not working as it supposed to be. Here is the result after rewriting the paths:

I got all the pictures from folder#1 in tables as it should be. However, no pictures from Folder#2 or file names were added to the tables.
The good thing is that it seems we are much closer now to the right code.

Best regards,
Hussain

[macropod]

OK, try adding the following to your Table template's 'ThisDocument' code module:

Sub Document_New()
Application.ScreenUpdating = False
Dim strFldr1 As String, strFiles1 As String, strTmp As String
Dim strFldr2 As String, strFiles2 As String, strFile As String, r As Long
strFldr1 = "C:\Users\" & Environ("Username") & "\Pictures\Folder1\"
strFldr2 = "C:\Users\" & Environ("Username") & "\Pictures\Folder2\"
strFiles2 = Dir(strFldr2 & "*.emf", vbNormal): strTmp = "|": r = 2
While strFiles2 <> ""
strTmp = strTmp & Split(UCase(strFiles2), ".EMF")(0) & "|"
strFiles2 = Dir()
Wend
strFiles1 = Dir(strFldr1 & "*.tif", vbNormal)
With ActiveDocument.Tables(1)
While strFiles1 <> ""
If r = 2 Then
r = 3
Else
.Rows.Add
End If
r = .Rows.Count: strFile = Left(strFiles1, Len(Split(UCase(strFiles1), ".TIF")(0)))
.Range.InlineShapes.AddPicture FileName:=strFldr1 & strFiles1, _
LinkToFile:=False, Range:=.Cell(r, 1).Range
If InStr(strTmp, "|" & UCase(strFile) & "|") > 0 Then
.Range.InlineShapes.AddPicture FileName:=strFldr2 & strFile & ".emf", _
LinkToFile:=False, Range:=.Cell(r, 2).Range
.Cell(r, 2).Range.Characters.Last.InsertBefore vbCr & strFile
End If
strFiles1 = Dir()
Wend
End With
Application.ScreenUpdating = True
End Sub
Double-clicking on the template or using File|New with it from Word should create and populate a new document with your pics.

[Jeshi79]

That was awesome Paul, :clap:
I faced some issues with the codes that I had to work around them and here what I did.
To get what I wanted I had to run the macro#2 you sent to me (in post#8) and that generated an empty table with no pictures in the first page. In the second page, only pictures from Folder#1 started to be added into the second table and continued to the last page. I could not delete the empty table in the first page because all the headers of the rest of the tables will go with it. To solve that, I added the pictures of the first pair (file#1/folder#1 + file#1/folder#2) manually into the template and saved it. Then, I deleted the picture of file#1 from folder#1 and picture of files#1 from folder#2 to avoid getting them again when run the macro to generate the tables.

I re-run the same macro with the new template and this time I got the pictures of the first pair in the first table and only pictures from Folder#1 in the rest of the tables. In the same document I run macro#3 you sent to me (in post#12). In addition to the tables from macro#2, macro#3 generated new tables containing all the pairs of pictures as required. Now, I had to delete the tables generated from macro#2 and keep the tables generated from macro#3.

Although I can live with that since it will do the work for me, it will be a great help from you if you can combine the two macro (#2 and #3) in one macro to make the job easier. I tried to do that myself, but my poor VBA skills did not help me:(

Your help is always highly appreciated.:)
Cheers,
Hussain

[macropod]

All you really needed to do was add the macro to the template containing the table. None of what you did should have been necessary.

[Jeshi79]

Dear Paul,
The macro is working really good and doing the job exactly as expected :thumb. I can't be thankful enough for all your time and efforts you spent to help me. Your patient with me and your clarifications made my life much easier and saved me a lot of time I was spending to do this work manually. :yes:clap:

Cheers,
Hussain