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)

Thread: INSERT PICTURE IN WORD VIA EXCEL VBA

Thread Tools

Display

INSERT PICTURE IN WORD VIA EXCEL VBA

Posting Permissions