Images and Mailmerge

[Remou]

I am not quite sure if this is a question, in that someone may well suggest something much better, or a helpful hint, in that it seems to work.

Option Compare Database
Option Explicit

'The problem with putting images in a mailmerge from Access is that you
'have to update each image after the mailmerge has run, which is tedious.
'I needed to include pictures in textboxes for identity cards, which
'was even more tedious to update, so I found some code in various
'places in Tek-Tips. In addition, I used:
'Mail merge includepicture doesn't work!
'thread68-1275181
'when setting up the document.

Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function ShowWindow Lib "user32" _
    (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
Public Declare Function GetWindow Lib "user32" _
    (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
    (ByVal hWnd As Long, ByVal lpString As String, ByVal cch As Long) As Long

Public Const SW_SHOW = 5
Public Const GW_HWNDNEXT = 2

Sub TestIt()
Dim strPath As String
Dim strDataFile  As String
Dim strWordFile  As String
    strPath = "C:\CertTemplates\"
    strDataFile = "Data.txt"
    strWordFile = "Doc.doc"
    RunMailmerge strPath, strDataFile, strWordFile
End Sub

Public Sub RunMailmerge(MergePath As String, MergeDataFile As String, MergeDocFile As String)
'This is a very much cut down version of PSeale's code, which can be found in full
'here:
'Native' mailmerge reports - as painless as possible
'faq181-5088
'I hope I will be forgiven.

On Error GoTo Sub_Error
    Dim objWordDoc As Object
    Dim objWordDocX As Object
    Dim strDir As String

    Set objWordDoc = GetObject(MergePath & MergeDocFile, "Word.Document")
    
    objWordDoc.Application.Visible = True
    
    'Format:=0 '0 = wdOpenFormatAuto
    objWordDoc.MailMerge.OpenDataSource _
        Name:=MergePath & MergeDataFile, ConfirmConversions:=False, _
        ReadOnly:=False, LinkToSource:=True, AddToRecentFiles:=False, _
        PasswordDocument:="", PasswordTemplate:="", WritePasswordDocument:="", _
        WritePasswordTemplate:="", Revert:=False, Format:=0, _
        Connection:="", SQLStatement:="", SQLStatement1:=""

    With objWordDoc
        .MailMerge.Destination = 0 '0 = wdSendToNewDocument
        .MailMerge.Execute
        FindFormLetters
    End With

Sub_Exit:
On Error Resume Next
    'Word pops up a messagebox to confirm saving the document,
    'even if specifically set it to "wdDoNotSaveChanges".
    'Therefore first save the document, then close it.
    objWordDoc.Save
    objWordDoc.Close SaveChanges:=-1 '-1 = wdSaveChanges
    
    Set objWordDoc = Nothing
    'attempt to delete file, silently fail on errors.
    'FileSystem.Kill strMailmergeDataFilename
    
    Exit Sub
    
Sub_Error:
    If Err.Number = 432 Then
        MsgBox "ERROR: Invalid filename provided: '" & MergeDataFile & "' or " & _
        "'" & MergePath & MergeDocFile & "'."
    Else
        MsgBox Err.Description
    End If
    Resume Sub_Exit
End Sub

Sub FindFormLetters()
Dim WinHandle As Long
Dim astrWindows As Variant
Dim varLetterNo
Dim i, j
Dim objWordDoc As Object
Dim SH

'This is all a bit shaky
'First, how many letters have been run
astrWindows = Split(FindWindowPartial("Form Letters"), "|")

'Get the most recent (this will only work up to 9)
varLetterNo = 0
For i = 0 To UBound(astrWindows)
    If Mid(astrWindows(i), 13, 1) > varLetterNo Then
        varLetterNo = Mid(astrWindows(i), 13, 1)
        j = 1
    End If
Next

'I am sure this could be tidied up
'Return the handle ...
WinHandle = FindWindow(vbNullString, astrWindows(j))
    
'and use it ...
ShowWindow WinHandle, SW_SHOW

'to get the word document.
Set objWordDoc = GetObject(, "Word.Application")

With objWordDoc
'Print View
    If .ActiveWindow.View.SplitSpecial = 0 Then '0=wdPaneNone
        .ActiveWindow.ActivePane.View.Type = 3 '3=wdPrintView
    Else
        .ActiveWindow.View.Type = 3 '3=wdPrintView
    End If

'The code is modified fro SkipVought's post in:
'Replace not working in VBA - Word 2000
'thread68-794360
'Search though the textboxes in the document updating the pictures
   For Each SH In .ActiveDocument.Shapes
        SH.Select
        With .Selection.Find
            .Text = "^g"
            .Forward = True
            .Wrap = 1 '1=wdFindContinue
            .Format = False
            .MatchCase = False
            .MatchWholeWord = False
            .MatchWildcards = False
            .MatchSoundsLike = False
            .MatchAllWordForms = False
        End With
        .Selection.Find.Execute 'Replace:=wdReplaceAll
        .Selection.Fields.Update
    Next
End With

Set objWordDoc = Nothing
End Sub

Function FindWindowPartial(ByVal Title As String) As String
'The code is modified from Hypetia's post in:
'Find Handle - Class/Window Name Changes
'thread711-710383

    Dim hWndThis As Long
    hWndThis = FindWindow(vbNullString, vbNullString)
    While hWndThis
        Dim sTitle As String, sClass As String
        sTitle = Space$(255)
        sTitle = Left$(sTitle, GetWindowText(hWndThis, sTitle, Len(sTitle)))
        If InStr(sTitle, Title) > 0 Then
            FindWindowPartial = sTitle & "|" & FindWindowPartial
        End If
        hWndThis = GetWindow(hWndThis, GW_HWNDNEXT)
    Wend
End Function