Copy word document template and insert image

[YasserKhalil]

Hello everyone
I have a word document named "Template.docx" in the same path of ThisWorkbook.
In the excel file in sheet1 there are four columns: First column for naming the template. The second column will have a value that would be replaced. The third column as the second one. The fourth column will have a link to an image (full path)
Say I have these values in row1:
First Template ---- Yasser ---- Khalil ----- C:\Users\User\Desktop\Sample.jpg
Second Template --- Hans--- Tutor --- C:\Users\User\Desktop\Sample2.jpg

I have the following code that changes the Template itself and do the replacement of columns B & C and here's the code

Code: Select all

Sub Test()
    Dim objWd As Object, objDoc As Object, strName As String
    With Application.FileDialog(1)
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc*"
        .InitialFileName = ThisWorkbook.Path & "\*.doc*"
        If .Show Then strName = .SelectedItems(1) Else Exit Sub
    End With
    On Error Resume Next
        Set objWd = GetObject(Class:="Word.Application")
        If objWd Is Nothing Then Set objWd = CreateObject(Class:="Word.Application")
    On Error GoTo 0
    objWd.Visible = True
    Set objDoc = objWd.Documents.Open(strName)
    With ThisWorkbook.Worksheets("Sheet1")
        objDoc.Content.Find.Execute FindText:="XXXXX", ReplaceWith:=.Range("B1").Value, MatchWholeWord:=False, Replace:=2
        objDoc.Content.Find.Execute FindText:="YYYYY", ReplaceWith:=.Range("C1").Value, MatchWholeWord:=False, Replace:=2
    End With
    'objDoc.Close SaveChanges:=True
End Sub

I don't want to change the Template itself. I need to loop through the rows and for each row create a template with the name in column A .. and do the replacement as the code do for columns B and C
And finally and this is most important to insert the image in the word document at a specific place (not sure what's the best approach for that point .. )

[YasserKhalil]

Any help in this topic, please.

[YasserKhalil]

I just need how to create a copy from the template and enable me to edit that copy easily. I have an idea but don't know how to execure it.
The idea is to open the template .. edit some points then use SaveAs to save a copy with different name then undo what is done and edit new points and saveas again and so on.. I need your help

[YasserKhalil]

This is my try but I don't know how to save a copy without closing the template file

Code: Select all

Sub Test()
    Dim oWord As Object, oDoc As Object
    On Error Resume Next
        Set oWord = GetObject(, "Word.Application")
    On Error GoTo 0
    If oWord Is Nothing Then
        Set oWord = CreateObject("Word.Application")
    End If
    oWord.Visible = True
    Set oDoc = oWord.Documents.Add(Template:=ThisWorkbook.Path & "\Template.docx")
    SetBookmarkText oDoc, "bmYasser", "New Phrase"
    oDoc.SaveCopyAs ThisWorkbook.Path & "\New.docx"
    oDoc.Close
    Set oDoc = Nothing
    oWord.Quit
    Set oWord = Nothing
End Sub

Sub SetBookmarkText(oDoc As Object, sBookmark As String, sText As String)
    Dim BMRange As Object
    If oDoc.Range.Bookmarks.Exists(sBookmark) Then
      Set BMRange = oDoc.Range.Bookmarks(sBookmark).Range
      BMRange.Text = sText
      oDoc.Range.Bookmarks.Add sBookmark, BMRange
    Else
      Debug.Print "Bookmark '" & sBookmark & "' Not Found In '" & oDoc.Name & "'"
    End If
End Sub

My idea after saving a copy of the template with a new name, is to repeat the step of setting text to book mark and send empty string to restore it as it was. The bookmark named "bmYasser" will be empty in the original template then to be filled with the needed string ...

[YasserKhalil]

At last I have found some pieces of code that enables me to do the task
Here's the final code (but I need your review my tutor)

Code: Select all

Sub Test()
    Dim ws As Worksheet, oWord As Object, oDoc As Object, r As Long, lr As Long
    On Error Resume Next
        Set oWord = GetObject(, "Word.Application")
    On Error GoTo 0
    If oWord Is Nothing Then
        Set oWord = CreateObject("Word.Application")
    End If
    oWord.Visible = True
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    lr = ws.Cells(Rows.Count, 1).End(xlUp).Row
    For r = 2 To lr
        Set oDoc = oWord.Documents.Add(Template:=ThisWorkbook.Path & "\Template.docx")
        SetBookmarkText oDoc, "bmYasser", ws.Cells(r, 1).Value
        SetBookmarkText oDoc, "bmYear", ws.Cells(r, 2).Value
        oDoc.SaveAs ThisWorkbook.Path & "\" & ws.Cells(r, 3).Value & ".docx"
        oDoc.Close
        Set oDoc = Nothing
    Next r
    oWord.Quit
    Set oWord = Nothing
End Sub

Sub SetBookmarkText(oDoc As Object, sBookmark As String, sText As String)
    Dim BMRange As Object
    If oDoc.Range.Bookmarks.Exists(sBookmark) Then
      Set BMRange = oDoc.Range.Bookmarks(sBookmark).Range
      BMRange.Text = sText
      oDoc.Range.Bookmarks.Add sBookmark, BMRange
    Else
      Debug.Print "Bookmark '" & sBookmark & "' Not Found In '" & oDoc.Name & "'"
    End If
End Sub

Now I put the names in column A and the year in column B and the file name (the new created one in column C) and the code creates a copy of the original template and creates the new ones) ..