Help me with my piecemeal VBA

myusersname · #1 01-24-2024, 04:09 PM

So after thinking about it for a while, I'm not sure how I can narrow down the filter more. I have multiple emails to send based on a date and a file. Some persons have multiple files on the same date. Any ideas on what to do?

Quote:

Originally Posted by myusersname

I know just enough to mess things up.

What this code should do is"

ask for the index number to "lookup" info from SettlementList spreadsheet (which does have multiple rows with the same index)
print a copy of each record
create a pdf of each record saved into the file folder
email each pdf to the email associated with the record.

Everything works ALMOST correct except:

The printout as well as the created pdf has all records with the input index number, so instead of just one page with Mary's row of data, it has a second page with Mark's data.

The hard copy printout prints multiple copies.

My apologies for the hack-job of code below, but any direction would be greatly appreciated. I'm guessing it's the multiple indexes, as I used most of the code from another macro that works fine and purpose is to do nearly the same thing but with single instances of the index. The difference is that I need the multiple instances to be utilized in the emails and pdf creations.

Code:

Sub SettlementLetter()

Dim MainDoc As Document, TargetDoc As Document

Dim dbPath As String

Dim recordNumber As Long, totalRecord As Long

Dim strCLMNUM As String

Dim PdfPath As String

 

 

       

 

Set MainDoc = ActiveDocument

With MainDoc.Mailmerge

   

        strCLMNUM = InputBox("What is the claim number we are saving as a PDF?", "CLAIM QUERY", "Type the EXACT Claim Number here.")
        
If strCLMNUM = Null Then

   Exit Sub
ElseIf strCLMNUM = "" Then
Exit Sub
    
'ElseIf strCLMNUM = "" Then

Else: Dim QryStrg As String

        QryStrg = "SELECT * FROM [SettlementList$] WHERE Claim_Number = " & "'" & strCLMNUM & "'"

             

        '// if you want to specify your data, insert a WHERE clause in the SQL statement

        .OpenDataSource Name:=SOURCE_FILE_PATH, sqlstatement:="SELECT * FROM [SettlementList$]"

        .DataSource.QueryString = QryStrg

       

        totalRecord = .DataSource.RecordCount

 

        'For recordNumber = 1 To totalRecord
        For recordNumber = 1 To 1

       

            With .DataSource

                .ActiveRecord = recordNumber

                .FirstRecord = wdDefaultFirstRecord

                .LastRecord = wdDefaultLastRecord

            End With

           

            .Destination = wdSendToNewDocument

            .Execute False

           

            Set TargetDoc = ActiveDocument

 

       

                                 

            

            PdfPath = FOLDER_SAVED & .DataSource.DataFields("FILE_Name").Value & " " & .DataSource.DataFields("FILE_ID").Value & "\" & .DataSource.DataFields("Claim_Number").Value & "\" & .DataSource.DataFields("Claim_Number").Value & .DataSource.DataFields("First_Name").Value & .DataSource.DataFields("Last_Name").Value & "Settlement Letter.pdf"

           

            TargetDoc.ExportAsFixedFormat PdfPath, exportformat:=wdExportFormatPDF

            TargetDoc.PrintOut Copies:=1

            Application.Dialogs(wdDialogFilePrint).Show

           

            

Dim edress As String

Dim subj As String

Dim message As String

Dim filename As String

Dim outlookapp As Object

Dim outlookmailitem As Object

Dim myAttachments As Object

Dim path As String

Dim lastrow As Integer

Dim attachment As String

Dim x As Integer

 

 

 

 

'x = 2

 

''Do While Sheet1.Cells(x, 1) (the symbol for not equal to) ""

  

    Set outlookapp = CreateObject("Outlook.Application")

    Set outlookmailitem = outlookapp.createitem(0)

    Set myAttachments = outlookmailitem.Attachments

    path = "PdfPath"

    'edress = L@.com

    edress = .DataSource.DataFields("Email").Value

    subj = .DataSource.DataFields("Last_Name").Value & " " & .DataSource.DataFields("Claimant_ID_Number").Value & " " & .DataSource.DataFields("Claim_Number").Value & "SETTLEMENT"

    filename = .DataSource.DataFields("Claim_Number").Value & .DataSource.DataFields("First_Name").Value & .DataSource.DataFields("Last_Name").Value & "Settlement Letter.pdf"

    attachment = PdfPath

 

 

   

        outlookmailitem.To = edress

        outlookmailitem.cc = ""

        outlookmailitem.bcc = ""

        outlookmailitem.Subject = subj

        'outlookmailitem.body = .DataSource.DataFields("First_Name").Value & "," & vbCrLf & vbCrLf & "Your claim has been settled with the Carrier." & vbCrLf & vbCrLf & "Please keep the attached copy of the settlement for your records and do not hesitate to contact me at my number below."

                   

        myAttachments.Add (attachment)

        outlookmailitem.Display

        '''outlookmailitem.send

           

        '''lastrow = lastrow + 1

        '''edress = ""

    'x = x + 1

 

 

 

 

Set outlookapp = Nothing

Set outlookmailitem = Nothing

Set outlookapp = CreateObject("Outlook.Application")

Set outlookmailitem = outlookapp.createitem(0)

Set myAttachments = outlookmailitem.Attachments

   

    'edress = L@.com

    'edress = .DataSource.DataFields("Email_Address").Value

    ''subj = .DataSource.DataFields("Name").Value & " " & .DataSource.DataFields("Claimant_ID_Number").Value & " " & .DataSource.DataFields("Claim_Number").Value

    ''filename = .DataSource.DataFields("Claim_Number").Value & ".pdf"

    ''attachment = PdfPath

 

 

   

        ''outlookmailitem.To = "L@.com"

        ''outlookmailitem.cc = ""

        ''outlookmailitem.bcc = "t@.com"

        ''outlookmailitem.Subject = subj

        ''outlookmailitem.body = "The attached claim is hereby submitted." & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & "Best Regards," & vbCrLf & vbCrLf & "Tr" & vbCrLf & "Vi" & vbCrLf & "AlT" & vbCrLf & "618"

                   

        ''myAttachments.Add (attachment)

        ''outlookmailitem.Display

        '''outlookmailitem.send

           

        lastrow = lastrow + 1

        edress = ""

    'x = x + 1

 

           

            TargetDoc.Close False

           

            Set TargetDoc = Nothing

            'Stop

        Next recordNumber

'Stop


End If
End With

Set MainDoc = Nothing

 

 

   

End Sub