Untitled
unknown
plain_text
a year ago
5.8 kB
4
Indexable
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
Editor is loading...
Leave a Comment