Hi all,

I am trying to create a macro to automate sending fax requests related to data on a report, and have found the following code online which I tried to modify to meet my need. However, it is not working. It opens the Word template but gives Run-time error'438' Object doesn't support this property or method.

This is my first attempt at Mail Merge, in general, so I am practically clueless at what I am doing and will appreciate it if someone could help me, please.

Here is the code:

Sub AuditFaxRequest()
Dim bCreatedWordInstance As Boolean
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
Dim objMMMD As Object
Set objMMMD = CreateObject("Word.Document")
Dim ProviderNo As String, rng1 As Range
Dim cDir As String
Dim r As Long
Dim lastRow As Long
Dim ThisFileName As String
Dim NewFileName As String
' Setup filenames
Const WTempName = "FaxRequest.docx" 'This is the Fax Word template name,

' Setup directories

cDir = ActiveWorkbook.Path + "\" 'Change if appropriate
ThisFileName = ThisWorkbook.Name
lastRow = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row

Set rng1 = ActiveSheet.Range(Cells(1, 1), Cells(lastRow, 9))
ActiveWorkbook.Names.Add Name:="FaxInfo", RefersTo:=rng1

On Error Resume Next

' Create a Word Application instance
bCreatedWordInstance = False
Set objWord = GetObject(, "Word.Application")

If objWord Is Nothing Then
  Err.Clear
  Set objWord = CreateObject("Word.Application")
  bCreatedWordInstance = True
End If

If objWord Is Nothing Then
    MsgBox "Could not start Word"
    Err.Clear
    On Error GoTo 0
    Exit Sub
End If

' Let Word trap the errors
On Error GoTo 0

' Set to True if you want to see the Word Doc flash past during construction
objWord.Visible = False

'Open Word Template
                        Set objMMMD = objWord.Documents.Open(cDir + WTempName)
objMMMD.Activate

'Merge the data
With objMMMD
    .MailMerge.OpenDataSource Name:=cDir + ThisFileName, _
    ReadOnly:=True, _
    Connection:="FaxInfo"

'        sqlstatement:="SELECT *  FROM 'FaxData'"   ' Set this as required
    
    For r = 2 To lastRow
        If Cells(r, 9).Value = "Fax sent" Then GoTo nextrow
    'rest of code goes here
    
    With objMMMD.MailMerge  'With ActiveDocument.MailMerge
    
    
        .Destination = wdSendToEmail
    .MailAddressFieldName = "email"
    .MailAsAttachment = True
'    .MailFormat = wdMailFormatHTML
    .MailSubject = "Prescription Audit"
    .SuppressBlankLines = True
'    With .DataSource
'        .FirstRecord = wdDefaultFirstRecord
'        .LastRecord = wdDefaultLastRecord
'    End With
    .Execute Pause:=False
      
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
     End With
        
            With .DataSource
            .FirstRecord = r - 1
            .LastRecord = r - 1
            .ActiveRecord = r - 1
            End With
            
    .Execute Pause:=False

 ' Save new file
NewFileName = "FaxRequest - " & ProviderNo & ".docx"
objWord.ActiveDocument.SaveAs cDir + NewFileName

' Close the Mail Merge Main Document
objMMMD.Close savechanges:=wdDoNotSaveChanges
Set objMMMD = Nothing

' Close the New Mail Merged Document
If bCreatedWordInstance Then
objWord.Quit
End If

0:
Set objWord = Nothing
Cells(r, 9).Value = "Fax sent"
nextrow:

Next r
End With
End Sub
Thank you,
Gos-C