Mailmerge/PDF/Outlook VBA

owen4512

Board Regular
Joined
Dec 10, 2014
Messages
71
Hi all,

I'm relatively new to excel vba and i'm i've created a spreadsheet that allows the user to select three options. "Email as PDF", "Open Documents" and "Email as Word Document". The below VBA currently opens only one document whereas i'm looking to open three documents/PDF for all three options. The below vba works perfectly for opening just one document/pdf but i can seem to figure out how to open multiple documents.

I'd appreciate any help on this.

Here's what i've done so far;

Code:
Option Explicit


Sub CreateWordDocumentsv2()
Dim CustRow, CustCol As Long
Dim docloc, docloc2, docloc3, TagName, TagValue, FileName, FileName2, FileName3, ans As String
Dim WordDoc, WordDoc2, WordDoc3, WordApp, WordApp2, WordApp3, OutApp, OutMail As Object
Dim WordContent As Word.Range


With Sheet2
  
  If .Range("O8").Value = Empty Then
    MsgBox "Please enter a valid reference number"
    Sheets("Start").Activate
    Exit Sub
  End If
    
    
    '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")
    Set WordApp2 = CreateObject("Word.Application")
    Set WordApp3 = CreateObject("Word.Application")
    WordApp.Visible = True 'Make the application visible to the user
    End If
       
       
    'sets which documents to open
    If .Range("O10") = "Yes" And .Range("O9") = "Pack1" Then
        docloc = "D:\Users\Lee\Desktop\Test\Doc1.docx"
        docloc2 = "D:\Users\Lee\Desktop\Test\Doc2.docx"
        docloc3 = "D:\Users\Lee\Desktop\Test\Doc3.docx"
        ElseIf .Range("O10") = "No" And .Range("O9") = "Pack2" Then 'HP Template
        docloc = "D:\Users\Lee\Desktop\Test\Doc3.docx"
        docloc2 = "D:\Users\Lee\Desktop\Test\Doc4.docx"
        docloc3 = "D:\Users\Lee\Desktop\Test\Doc5.docx"
    End If
        
                                
                                
        For CustRow = 42 To 42
                                Set WordDoc = WordApp.Documents.Open(FileName:=docloc, ReadOnly:=False) 'Open Template
                                Set WordDoc2 = WordApp2.Documents.Open(FileName2:=docloc2, ReadOnly:=False) 'Open Template
                                Set WordDoc3 = WordApp3.Documents.Open(FileName3:=docloc3, ReadOnly:=False) 'Open Template
                                For CustCol = 2 To 39 'Move Through Columns
                                    TagName = .Cells(41, CustCol).Value 'Tag Name
                                    TagValue = .Cells(CustRow, CustCol).Value 'Tag Value
                                     With WordDoc.Content.Find
                                        .Text = TagName
                                        .Replacement.Text = TagValue
                                        .Wrap = wdFindContinue
                                        .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                                     End With
                                     With WordDoc2.Content.Find
                                        .Text = TagName
                                        .Replacement.Text = TagValue
                                        .Wrap = wdFindContinue
                                        .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                                     End With
                                     With WordDoc3.Content.Find
                                        .Text = TagName
                                        .Replacement.Text = TagValue
                                        .Wrap = wdFindContinue
                                        .Execute Replace:=wdReplaceAll 'Find & Replace all instances
                                     End With
                                Next CustCol
                                
                                
                                
                                
                        If .Range("N14").Value = "Email as PDF" Then
                                    ans = MsgBox("Are you sending the documents to the customer?", vbYesNo)
                                    
                                       FileName = ThisWorkbook.Path & "\" & .Range("E8").Value & "1" & ".pdf" 'Create full filename
                                       WordDoc.ExportAsFixedFormat OutputFileName:=FileName, ExportFormat:=wdExportFormatPDF
                                       WordDoc.Close False
                                       
                                       FileName2 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".pdf" 'Create full filename
                                       WordDoc2.ExportAsFixedFormat OutputFileName:=FileName2, ExportFormat:=wdExportFormatPDF
                                       WordDoc2.Close False
                                       
                                       FileName3 = ThisWorkbook.Path & "\" & .Range("E10").Value & ".pdf" 'Create full filename
                                       
                                       WordDoc3.ExportAsFixedFormat OutputFileName:=FileName3, ExportFormat:=wdExportFormatPDF
                                       WordDoc3.Close False
                                       Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
                                                  Set OutMail = OutApp.CreateItem(0) 'Create Email
                                                  With OutMail
                                                      .To = ans
                                                        If ans = vbYes Then
                                                            .To = Sheet2.Range("S8").Value
                                                        Else
                                                            .To = ""
                                                        End If
                                                      .Subject = "Test Subject"
                                                      .Body = "Hello, this is a test"
                                                      .Attachments.Add FileName
                                                      .Attachments.Add FileName2
                                                      .Attachments.Add FileName3
                                                      .Display
                                                      WordApp.Quit
                                                      WordApp2.Quit
                                                      WordApp3.Quit
                                                  End With
                                                  
                        ElseIf Range("N14").Value = "Open Documents" Then
                                       FileName = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
                                       'WordDoc.SaveAs FileName
                                       FileName2 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
                                       'WordDoc2.SaveAs FileName2
                                       FileName3 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
                                       'WordDoc3.SaveAs FileName3
                                       'WordDoc.SaveAs FileName
                                       
                        ElseIf Range("N14").Value = "Email as Word Document" Then
                                ans = MsgBox("Are you sending the documents to the customer?", vbYesNo)
                                
                                   FileName = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
                                   WordDoc.SaveAs FileName
                                   
                                   FileName2 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
                                   WordDoc.SaveAs FileName2
                                   
                                   FileName3 = ThisWorkbook.Path & "\" & .Range("E9").Value & ".docx"
                                   WordDoc.SaveAs FileName3
                                   
                                                  Set OutApp = CreateObject("Outlook.Application") 'Create Outlook Application
                                                  Set OutMail = OutApp.CreateItem(0) 'Create Email
                                                  With OutMail
                                                      .To = ans
                                                        If ans = vbYes Then
                                                            .To = Sheet2.Range("S8").Value
                                                        Else
                                                            .To = ""
                                                        End If
                                                      .Subject = "Test Subject"
                                                      .Body = "Hello, this is a test"
                                                      .Attachments.Add FileName
                                                      .Attachments.Add FileName2
                                                      .Attachments.Add FileName3
                                                      .Display 'To send without Displaying change .Display to .Send
                                                      WordApp.Quit
                                                  End With
        
                        'Else: 'Print Out
                                           'WordDoc.PrintOut
                                           'WordDoc.Close
                        End If
        Next CustRow
                        Kill (FileName) 'Deletes the PDF or Word that was just created
                        Kill (FileName2) 'Deletes the PDF or Word that was just created
                        Kill (FileName3) 'Deletes the PDF or Word that was just created


        
                             


        
End With
End Sub
 

Excel Facts

What is the last column in Excel?
Excel columns run from A to Z, AA to AZ, AAA to XFD. The last column is XFD.

Forum statistics

Threads
1,213,562
Messages
6,114,326
Members
448,564
Latest member
ED38

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top