Mail Merge and Send Fax via Email

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

instead of:

Set objWord = GetObject(, "Word.Application")

try:

Set objWord = CreateObject("Word.Application")

Wonderful! Big improvement. Thank you very much for spotting that and pointing it out, JoeFoot. However, it still gave the same error message, "Object doesn't support this property or method."

It fails here:

[CODE][/With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
End WithCODE]

It looks like it's the code to have Outlook send all the documents (faxes) as an attachment that is not correct/needed. Can some help me, please?

Thank you,
Gos-C

remove this:

With .DataSource
.FirstRecord = r - 1
.LastRecord = r - 1
.ActiveRecord = r - 1
End With