Untitled

Option Explicit
''
Public Sub SubCreatePDFs()
    Dim lngX As Long, lngBM As Long
    Dim strAgent As String, strTemplate As String
    Dim objWapp As Word.Application
    Dim objDoc As Word.Document
    Dim objShp As Word.Shape
    Dim WordRange As Word.Range
    Dim WordTable As Word.Table
    Dim WordPara As Word.Paragraph
    '''
    If VBA.Dir(ThisWorkbook.Path & "\Output", vbDirectory) = "" Then
        VBA.MkDir ThisWorkbook.Path & "\Output"
    End If
    '''
    Set objWapp = New Word.Application
    objWapp.Application.Visible = True
    '''
    lngX = 2
    Do While shtMain.Cells(lngX, 1) <> vbNullString
        'recipientName Leader Settlement Option Letter.pdf
        strTemplate = shtMain.Cells(lngX, 1) & " Leader Settlement Option Letter.pdf"
        If VBA.Dir(ThisWorkbook.Path & "\TempletterNP.docx", vbNormal) <> "" Then 'if template exists proceed generating
            If VBA.Dir(ThisWorkbook.Path & "\Output\" & strTemplate, vbDirectory) = "" Then
'                VBA.MkDir ThisWorkbook.Path & "\Output\" & strTemplate
            
                'PROCESS IF LOOKUP WORKING
                Set objDoc = objWapp.Documents.Open(ThisWorkbook.Path & "\TempletterNP.docx", , False)
                lngBM = 2
                Do While shtBookMark.Cells(lngBM, 1) <> vbNullString
                    If VBA.UCase(shtBookMark.Cells(lngBM, 1)) Like "*TABLE*" Then
                        objDoc.Bookmarks(shtBookMark.Cells(lngBM, 1)).Range.PasteAndFormat wdFormatOriginalFormatting
                        Application.CutCopyMode = False
                    Else
                        'Debug.Print objDoc.Bookmarks(shtBookMark.Cells(lngBM, 1)).Range.Text
                        'Debug.Print VBA.Format(shtMain.Cells(lngX, shtMain.Range(shtBookMark.Cells(lngBM, 2)).Column).Value, shtBookMark.Cells(lngBM, 3))
                        If VBA.IsNumeric(shtMain.Cells(lngX, shtMain.Range(shtBookMark.Cells(lngBM, 2)).Column).Value) And VBA.UCase(shtBookMark.Cells(lngBM, 3)) = VBA.UCase("General") Then
                            objDoc.Bookmarks(shtBookMark.Cells(lngBM, 1)).Range.Text = shtMain.Cells(lngX, shtMain.Range(shtBookMark.Cells(lngBM, 2)).Column).Value
                        Else
                            objDoc.Bookmarks(shtBookMark.Cells(lngBM, 1)).Range.Text = VBA.Format(shtMain.Cells(lngX, shtMain.Range(shtBookMark.Cells(lngBM, 2)).Column).Value, shtBookMark.Cells(lngBM, 3))
                        End If
                    End If
                    lngBM = lngBM + 1
                Loop
                '''table center
                For Each WordTable In objDoc.Tables
                    WordTable.Rows.Alignment = wdAlignRowCenter
                    WordTable.Rows.HeadingFormat = True
                    WordTable.Rows.AllowBreakAcrossPages = False
                Next
                '''
                'objDoc.SaveAs2 ThisWorkbook.Path & "\Output\" & strAgent & ".pdf", wdFormatPDF
                    objDoc.ExportAsFixedFormat OutputFileName:= _
                                       ThisWorkbook.Path & "\Output\" & strTemplate, _
                                       ExportFormat:=wdExportFormatPDF, _
                                       OpenAfterExport:=False, _
                                       OptimizeFor:=wdExportOptimizeForPrint, _
                                       Range:=wdExportAllDocument, _
                                       IncludeDocProps:=True, _
                                       CreateBookmarks:=wdExportCreateWordBookmarks, _
                                       BitmapMissingFonts:=True
                objDoc.Close False
            End If
        Else
            VBA.MsgBox "Check Template " & ThisWorkbook.Path & "\TempletterNP.docx", vbCritical
        End If
        lngX = lngX + 1
    Loop
    objWapp.Quit False
    '''
    VBA.MsgBox "Done Generating " & lngX - 1, vbInformation
End Sub
'''
Public Sub SubCreateEmailBasedonList()
    Dim lngX As Long
    Dim strFilePath As String
    lngX = 2
    Do While shtMain.Cells(lngX, 1) <> vbNullString
        strFilePath = ThisWorkbook.Path & "\Output\" & shtMain.Cells(lngX, 1) & " Leader Settlement Option Letter.pdf"
        CreateEmailOutContract shtMain.Cells(lngX, 13), shtMain.Cells(lngX, 14), shtMain.Cells(lngX, 15), shtMain.Cells(lngX, 1), strFilePath
        lngX = lngX + 1
    Loop
End Sub
'''
Private Sub CreateEmailOutContract(ByVal strTO As String, ByVal strCC As String, ByVal strBCC As String, ByVal strName As String, ByVal sFile As String)
    Dim objOutlook As Outlook.Application
    Dim objMail As Outlook.MailItem
    Dim Signature As String
    Dim sBody As String
    '''
    Set objOutlook = New Outlook.Application
    Set objMail = objOutlook.CreateItem(0)
    objMail.Display
    Signature = objMail.HTMLBody
    With objMail
        'Debug.Print sFile
            .Attachments.Add sFile
            '.Body = ""
            sBody = "<HTML><BODY><P>Dear <B>" & strName & ",</B></P>" & _
            "<P>As part of the process related to your DOU clawback, we are sending you a letter outlining the details.  Please take the time to review the letter thoroughly and provide and feedback within the specified timeframe.<br><br>Thank you for your cooperation.</P>" & _
            "</BODY></HTML>"
        .subject = "Leader Settlement Option " & strName
        .To = strTO
        .CC = strCC
        .BCC = strBCC
        '.SentOnBehalfOfName = "distributionsupport.ph@fwd.com"
        .HTMLBody = sBody & vbNewLine & Signature
        .Save
    End With
    Set objOutlook = Nothing
    Set objMail = Nothing
    ThisWorkbook.Activate
End Sub