PDA

View Full Version : [SOLVED:] INSERT PICTURE IN WORD VIA EXCEL VBA


PeterKom
04-30-2020, 01:14 PM
Attached an example of the script copying data from excel to word.
Please copy both files in one folder, open the excel file and under Templates sheet browse and insert the test.docx file.
Then choose it on the Ponudbe Sheet and press the green button.
The Word templates opens and all the tags are being replaced by the actual data (stored in the row after the company data in the main table, this is normaly hidden for the user).

My wish is to add a picture in each of the 4 tables in the Word Template. Each tabel represents on position (one product).
I have made only table 1 so you can see where I wish the picture to be.
If the user makes a configuration with only one product in Excel (this part is not visible in excel) the other 3 tables are being deleted.
I solved this with help of the user macropod! Thanks again.

So what would be the best way to add a picture.
Is it possible excel just provedes the link (path) to the image file and word shows it instead of the <<Picture>> tag or does the image needs to be copied
from Excel to Word to replace the <<Picture>> tag.

Becasue at the moment all data in Excel that is beeing copied sits in one row adding some pictures there would not be OK.
Maybe i can make a Sheet with all the pictures that i will use, name them and then the user configures the product on a separate sheet (not visible in the test file)
and based on this configuration the correct picture is selected automaticaly. The data from the configuratior is then being copied to the one row in sheet Ponudbe,
where the data is ready to creat the actual offer.


Any help would be appreciated.

Below the code form the attached excel file:


Option Explicit

Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim VarFormat As String
Dim VarValue As String
Dim WordContent As Word.Range
Dim date_example As String
date_example = Now()
Dim SaveNr As String
Dim str As String
Dim fol As String
With Sheet1

If .Range("B3").Value = Empty Then
MsgBox "Prosim izberi pravo podlogo iz seznama podlog"
.Range("H3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("H3").Value 'Set Template Name
FrDays = .Range("M3").Value 'Set From Days
ToDays = .Range("O3").Value 'Set To Days
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename


'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If


LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 8 To LastRow 'ROČNA PONDUBA
If .Range("O" & CustRow).Value = "" And TemplName <> "ROČNA PONUDBA" Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 4 To 200 'Move Through Columns
If .Cells(4, CustCol).Value = "Splosno" Then VarFormat = "General" Else: VarFormat = .Cells(5, CustCol).Value 'Determine Variable Format
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = Application.WorksheetFunction.Text(TagValue, VarFormat)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol

Dim Tbl As Long, Rw As Long, StrData As String
With WordDoc
For Tbl = 4 To 2 Step -1
With .Tables(Tbl)
StrData = ""
For Rw = 3 To 12
StrData = StrData & Split(.Cell(Rw, 2).Range.Text, vbCr)(0) '.Bookmarks("Schedule_of_Payments").Range.Tables(1).Delete
Next
If StrData = "" Then .Range.Bookmarks(1).Range.Delete 'If StrData = "" Then .Range.Bookmarks(1).Range.Tables(1).Delete
End With
Next
End With

If TemplName <> "ROČNA PONUDBA" Then
SaveNr = .Range("D" & CustRow).Text
str = "FOR TEST INSERT PATH TO FOLDER WHERE TEMPALTE IS STORED" & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & "\"
fol = Dir(str, vbDirectory)
If fol = "" Then MkDir str
FileName = str & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName 'Saves Word document
FileName = str & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
On Error Resume Next
Kill (FileName) 'Delete filename with the same name if it exists
On Error GoTo 0
On Error Resume Next
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF 'Exports Word document as PDF in and saves in same folder as Word document
'WordDoc.Close False
End If
.Range("O" & CustRow).Value = "DA" 'pre je bilo to' TemplName 'Template Name
.Range("P" & CustRow).Value = Format(date_example, "dd.mm.yyyy hh:nn")
'.Range("R" & CustRow) = Format(date_example, "yyyy")' 'SEM ODRSTRANIL KER NI POTREBNO, IMAM FORMULO ZA TO, KER JE PODATEK POTREBEN PREJ'
'WordDoc.Close
End If '3 condition met
Next CustRow
'WordApp.Quit 'WordApp.Quit Does not quit Word when testing templates
End With
End Sub
gmayor
04-30-2020, 08:48 PM
You can supply the image from a path stored in the worksheet. You would need to add code like the following to locate the tag and replace it with the image


Dim WordDoc As Word.Document 'already in your code
Dim oTable As Word.Table
Dim oRng As Word.Range
Dim oShape As Word.InlineShape
Set WordDoc = ActiveDocument
Set oTable = WordDoc.Tables(1)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "D:\path\filename.jpg" 'the path from the worksheet
Exit Do
Loop
End With
PeterKom
05-01-2020, 01:28 AM
Thanks, I have checked and it works for one picture.
But I can have 4 tables this means 4 different products so also 4 different picture.
Please check attached updated Word Template.

Now my code checks row 7 from column 4 to 200 (but this might easily get bigge rduring time) where the tags are written.
Then it replaces the same tags in the Word template accordingly to the value under those tage in Excel for all rows that meet condition

If .Range("O" & CustRow).Value = "" And TemplName <> "ROČNA PONUDBA" Then

So would it be possible to do the same for the pictures to have Picture tags, <<Piciture>>, <<Piciture2>>, <<Piciture3>>, <<Piciture4>>, .... and so on in that same row from column 4-200, because i also want to add other configurators
for other products that also will add a Picture. It may also be the possible to have mixed offers with a template for product like attached and some additionl product si I dont want to mix those tags. Lets say tag <<Piciture>> - <<Piciture4>> should only be for this particular product RWM and so on.

The whole code now look like this. For he testing purpose I now just added a path inside the code to see how it works.



Sub CreateWordDocuments()
Dim CustRow, CustCol, LastRow, TemplRow, DaysSince, FrDays, ToDays As Long
Dim DocLoc, TagName, TagValue, TemplName, FileName As String
Dim CurDt, LastAppDt As Date
Dim WordDoc, WordApp, OutApp, OutMail As Object
Dim VarFormat As String
Dim VarValue As String
Dim WordContent As Word.Range
Dim date_example As String
date_example = Now()
Dim SaveNr As String
Dim str As String
Dim fol As String
Dim oTable As Word.Table
Dim oRng As Word.Range
Dim oShape As Word.InlineShape
With Sheet1

If .Range("B3").Value = Empty Then
MsgBox "Prosim izberi pravo podlogo iz seznama podlog"
.Range("H3").Select
Exit Sub
End If
TemplRow = .Range("B3").Value 'Set Template Row
TemplName = .Range("H3").Value 'Set Template Name
FrDays = .Range("M3").Value 'Set From Days
ToDays = .Range("O3").Value 'Set To Days
DocLoc = Sheet2.Range("F" & TemplRow).Value 'Word Document Filename


'Open Word Template
On Error Resume Next 'If Word is already running
Set WordApp = GetObject("Word.Application")
If Err.Number <> 0 Then
'Launch a new instance of Word
Err.Clear
'On Error GoTo Error_Handler
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = True 'Make the application visible to the user
End If


LastRow = .Range("E9999").End(xlUp).Row 'Determine Last Row in Table
For CustRow = 8 To LastRow 'ROČNA PONDUBA
If .Range("O" & CustRow).Value = "" And TemplName <> "ROČNA PONUDBA" Then
Set WordDoc = WordApp.Documents.Open(FileName:=DocLoc, ReadOnly:=False) 'Open Template
For CustCol = 4 To 200 'Move Through Columns
If .Cells(4, CustCol).Value = "Splosno" Then VarFormat = "General" Else: VarFormat = .Cells(5, CustCol).Value 'Determine Variable Format
TagName = .Cells(7, CustCol).Value 'Tag Name
TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
With WordDoc.Content.Find
.Text = TagName
.Replacement.Text = Application.WorksheetFunction.Text(TagValue, VarFormat)
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll 'Find & Replace all instances
End With
Next CustCol

Set WordDoc = ActiveDocument
Set oTable = WordDoc.Tables(1)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CE.jpg" 'the path from the worksheet
Exit Do
Loop
End With

Dim Tbl As Long, Rw As Long, StrData As String
With WordDoc
For Tbl = 4 To 2 Step -1
With .Tables(Tbl)
StrData = ""
For Rw = 3 To 12
StrData = StrData & Split(.Cell(Rw, 2).Range.Text, vbCr)(0) '.Bookmarks("Schedule_of_Payments").Range.Tables(1).Delete
Next
If StrData = "" Then .Range.Bookmarks(1).Range.Delete 'If StrData = "" Then .Range.Bookmarks(1).Range.Tables(1).Delete
End With
Next
End With

If TemplName <> "ROČNA PONUDBA" Then
SaveNr = .Range("D" & CustRow).Text
str = "C:\Users\Peter\Desktop\kalk\2020\" & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & "\"
fol = Dir(str, vbDirectory)
If fol = "" Then MkDir str
FileName = str & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".docx"
WordDoc.SaveAs FileName 'Saves Word document
FileName = str & .Range("H" & CustRow).Value & " " & SaveNr & "-" & .Range("U" & CustRow).Value & "-" & .Range("R" & CustRow).Value & ".pdf" 'Create full filename & Path with current workbook location, Last Name & First Name
On Error Resume Next
Kill (FileName) 'Delete filename with the same name if it exists
On Error GoTo 0
On Error Resume Next
WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF 'Exports Word document as PDF in and saves in same folder as Word document
'WordDoc.Close False
End If
.Range("O" & CustRow).Value = "DA" 'pre je bilo to' TemplName 'Template Name
.Range("P" & CustRow).Value = Format(date_example, "dd.mm.yyyy hh:nn")
'.Range("R" & CustRow) = Format(date_example, "yyyy")' 'SEM ODRSTRANIL KER NI POTREBNO, IMAM FORMULO ZA TO, KER JE PODATEK POTREBEN PREJ'
'WordDoc.Close
End If '3 condition met
Next CustRow
'WordApp.Quit 'WordApp.Quit Does not quit Word when testing templates
End With
End Sub

Peter
gmayor
05-01-2020, 05:16 AM
If you set the value of oTable correctly for each table and search for the tag name in that table, as in my example code,you can insert as many images as you require.
PeterKom
05-01-2020, 05:54 AM
So you think like following:


Set WordDoc = ActiveDocument
Set oTable = WordDoc.Tables(1)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CE.jpg" 'the path from the worksheet
Exit Do
Set WordDoc = ActiveDocument
Set oTable = WordDoc.Tables(2)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture2>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CS.jpg" 'the path from the worksheet
Exit Do
...
Loop
End With

But can I refer to a particular cell (range) instead of the direct path. Because the path will be different according to the configuration of the product.
For Table1 the path will always be written in the same cell and for Table2 always on the same cell, and so on for all the trables for all the templates.

Peter
gmayor
05-01-2020, 06:22 AM
Not quite, but close, and you don't need to set WordDoc twice. It is still WordDoc after the first insertion.
If you have the image path data in the worksheet then replace
"C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CE.jpg"
with the cell.value that contains it etc.


Set WordDoc = ActiveDocument

Set oTable = WordDoc.Tables(1)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CE.jpg" 'the path from the worksheet
Exit Do
Loop
End With

Set oTable = WordDoc.Tables(2)
oTable.AutoFitBehavior (wdAutoFitFixed)
Set oRng = oTable.Range
With oRng.Find
Do While .Execute(findText:="<<Picture2>>")
oRng.Text = ""
oRng.InlineShapes.AddPicture "C:\Users\Peter\Desktop\kalk\PODLOGE PONUDB\SLIKE\RWM\W-CS.jpg" 'the path from the worksheet
Exit Do
Loop
End With
PeterKom
05-01-2020, 06:37 AM
Thanks, I figured the first part out but still struggling with the cell. value.
Lets say the Link for Table 1 is in Sheet2 in Cell C5 and for Table2 in the same Sheet2 in Cell C6.

So instead of the path I insert following into quotes for Table1.


"Sheet2.range(C5).value"
PeterKom
05-01-2020, 07:03 AM
I got it. Thanks for your help!

I made following:



Dim Path1 As String
Path1 = Sheets("SLIKE").Range("C5")
oRng.InlineShapes.AddPicture (Path1)

Dim Path2 As String
Path1 = Sheets("SLIKE").Range("C6")
oRng.InlineShapes.AddPicture (Path2)