Access Query Results To Be Sent Through Outlook VBA for each recipient (1 Viewer)

[gfranco]

Hi,

I have a request which needs to group in a single email all of records that belongs a specific customer. Each customer might have multiple contacts(emails) to be sent. All of the records needs to be categorized and group by customer.
I just found this code and works except for the following:
1. Always asked me about security stuff.
2. I just can email one record at a time and I cannot group all of records in a single email for each customer and I would like to group by first and send to pertain contact.
Would you mind to help me guys about it. Thanks.

Private Sub Command0_Click()

Dim MyDb As DAO.Database
Dim rsEmail As DAO.Recordset
Dim sToName As String
Dim sSubject As String
Dim sMessageBody As String

Set MyDb = CurrentDb()
Set rsEmail = MyDb.OpenRecordset("Query1", dbOpenSnapshot)


With rsEmail
.MoveFirst
Do Until rsEmail.EOF
If IsNull(.Fields(7)) = False Then
sToName = .Fields(7)
sSubject = "SO #: " & .Fields(1)
sMessageBody = "Estimado cliente adjunto encontrara la informacion de la orden" & vbCrLf & _
"Cliente: " & .Fields(0) & vbCrLf & _
"Numero de Orden: " & .Fields(1) & vbCrLf & _
"Numero de Ship set: " & .Fields(2) & vbCrLf & _
"Numero de Linea de Orden: " & .Fields(3) & vbCrLf & _
"Pais de origen: " & .Fields(4) & vbCrLf & _
"Lugar de embarque: " & .Fields(5)
'"Field C: " & .Fields©

DoCmd.SendObject acSendNoObject, , , _
sToName, , , sSubject, sMessageBody, False, False
End If
.MoveNext
Loop
End With

Set MyDb = Nothing
Set rsEmail = Nothing


End Sub

 

[PNGBill]

I didn't open your attached file but it appears an Array may provide a solution.

I have an email sent out with data on loans a person has.
It lists the data one loan at a time in the email body and this is done by using an Array.

Bit fiddly to get the email layout legible but it does do the job.

Your email being html or text (?) makes a difference. I understand html is easier to handle the layout.

Here is the code, if it makes sence and assists you.

Private Sub CmdEmailMembBal_Click()
On Error GoTo Err_CmdEmailMembBal_Click
     
    Dim dbs As DAO.Database, rst As DAO.Recordset
    Dim varTo As Variant                    'Email Address
    Dim stText As String                    'Email Text
    Dim stSubject As String                 'Email Subject Line
    Dim stSubjectWeight As String           'Email Subject Weight Variable - Reminder etc
    Dim stEmailOpen As String               'Email Open Variable
    Dim stEmailClose As String              'Email Close Message Variable
    Dim EmailText As String                 'String to hold each loan details
    Dim EmailBody As String                 'String to accumulate the Loan Details
    Dim strSQL As String                    'SQL String
    Dim PointsAvailable As Integer          'Available Club Points
    Dim MembID As Integer                   'Member ID
    Dim FirstName As String                 'Club Member First Name as Variable
    Dim FullName As String                  'Club Member full Name as Variable
    Dim TeamID As String                    'Club Group Team Member ID as Variable
    Dim LastLoanID As String                'Last Loan Number held as variable
    Dim LastRepayDate As Date               'Last Repayment Date Variable
    Dim LastRepayAmt As Currency            'Last Repay Amount Variable
    Dim TeamMember As String                'variable to hold Team Member Full Name
              
    MembID = Me.txtADPK                        'set forms current Member ID to be variable value
    TeamID = UCase(TeamMemberLogin())           'set TeamID as Current User
    TeamMember = fncTeamMemberName()           'put result of function as Team member Full Name
    Set dbs = DBEngine(0)(0)
    
           'SQL String to Collect Member Name, Email Address and Last Loan Number Data
    strSQL = "SELECT TBLACCDET.ADPK, TBLACCDET.ADFirstname AS FirstName, [ADFirstname] & "" "" & [ADSurname] AS FullName, " & _
            "TBLACCDET.ADEmail AS varTo, Max(TBLLOAN.LDPK) AS MaxOfLDPK " & _
        "FROM TBLACCDET INNER JOIN TBLLOAN ON TBLACCDET.ADPK = TBLLOAN.ADPK " & _
        "GROUP BY TBLACCDET.ADPK, TBLACCDET.ADFirstname, [ADFirstname] & "" "" & [ADSurname], TBLACCDET.ADEmail " & _
        "HAVING (((TBLACCDET.ADPK)=" & MembID & "));"
            'Open Recordset
    Set rst = dbs.OpenRecordset(strSQL)
    FirstName = rst!FirstName                   'Put Result of sql as Variable First Name
    FullName = rst!FullName                     'Put Result of sql as Variable Full Name
    varTo = rst!varTo                           'Put Result of sql as Variable Email Address
    LastLoanID = rst!MaxOfLDPK                  'Put reult of SQL as Variable Last Loan Number
    
    If VarType(varTo) = 1 Then      'Check if Null Value for Email Address and if so, Exit Sub
        MsgBox "No Email Address Evident. Check your Data and update Email Address"
            'Close database variables
        rst.Close
        dbs.Close
        Exit Sub
    End If
    LastRepayDate = fncLastMembRepayDate(CStr(MembID))      'Set Variable to be Result of Function
    LastRepayAmt = fncLastMembRepayAmt(CStr(MembID))        'Set Variable to be Result of Function
    
            'SQL to Collect Loan Data for All Current Loans - Issued but not completed
    strSQL = "SELECT TBLACCDET.ADPK, TBLLOAN.LDPK AS LoanID, TBLLOAN.LDTerm, TBLAPPLOAN.APLSTAT, " & _
            "tblLoanIssueStatus.IssueDate AS DateLoanIssued, TBLLOAN.LDPrin AS LoanPrincipal, TBLLOAN.LDPayK AS LoanRepayAmt, " & _
            "fncLastLoanRepayAmt(CStr([LoanID])) AS LastRepayAmt, fncLastLoanRepayDate(CStr([LoanID])) AS LastRepayDate, " & _
            "QryLoanCurrentBalanceResult.LoanCurrentBalance AS LoanOverdueAmt, QryLoanTotalToPayResult.SumOfLoanTotalToPay AS LoanTotalToPay " & _
        "FROM tblLoanIssueStatus INNER JOIN (TBLAPPLOAN INNER JOIN (((TBLACCDET INNER JOIN TBLLOAN ON TBLACCDET.ADPK = TBLLOAN.ADPK) " & _
            "INNER JOIN QryLoanTotalToPayResult ON TBLLOAN.LDPK = QryLoanTotalToPayResult.LoanID) " & _
            "INNER JOIN QryLoanCurrentBalanceResult ON TBLLOAN.LDPK = QryLoanCurrentBalanceResult.LoanID) ON " & _
            "TBLAPPLOAN.APLPK = TBLLOAN.LoanAppID) ON tblLoanIssueStatus.LoanID = TBLLOAN.LDPK " & _
        "WHERE (((TBLACCDET.ADPK)=" & MembID & ") AND ((TBLLOAN.LDTerm)=1) AND ((TBLAPPLOAN.APLSTAT)=3));"
                    'Open Recordset
    Set rst = dbs.OpenRecordset(strSQL)
    
    EmailBody = "Loan               Principal           Date               Agreed             Last               Repay           Overdue          Total" & Chr(13) & Chr(10)
    EmailBody = EmailBody & "Number          Amount           Issued            Repayment     Repayment        Date              Amount          Amount" & Chr(13) & Chr(10)
   
    Do Until rst.EOF
    
    EmailText = fncLoanNumberFormat(rst!LoanID) & Space(15 - Len(fncLoanNumberFormat(rst!LoanID))) & Format(rst!LoanPrincipal, "Currency") & Space(15 - Len(Format(rst!LoanPrincipal, "Currency"))) & rst!DateLoanIssued & Space(15 - Len(rst!DateLoanIssued)) & Format(rst!LoanRepayAmt, "Currency") & Space(15 - Len(Format(rst!LoanRepayAmt, "Currency"))) & Format(rst!LastRepayAmt, "Currency") & Space(15 - Len(Format(rst!LastRepayAmt, "Currency"))) & rst!LastRepayDate & Space(15 - Len(rst!LastRepayDate)) & Format(rst!LoanOverdueAmt, "Currency") & Space(15 - Len(Format(rst!LoanOverdueAmt, "Currency"))) & Format(rst!LoanTotalToPay, "Currency") & Chr(13) & Chr(10)
    EmailBody = EmailBody & EmailText
    
    rst.MoveNext
    
    Loop
    If LastRepayDate > Date - 15 Then
        stSubjectWeight = "Friendly Reminder"
        stEmailOpen = "Dear "
        stEmailClose = "Kind Regards,"
    ElseIf LastRepayDate < Date - 45 Then
        stSubjectWeight = "Promised Repayment Overdue"
        stEmailOpen = ""
        stEmailClose = "Please Respond Urgently,"
    Else
        stSubjectWeight = "Reminder"
        stEmailOpen = ""
        stEmailClose = "Regards,"
    End If
    
    PointsAvailable = GetMemClubPointsAvailable(CLng(MembID))   'Set Function Result as variable value
        
    stSubject = stSubjectWeight & " - Member Loan Balances Details for " & FullName & " - Member Number " & fncMemberIDFormat(CStr(MembID))
    stText = stEmailOpen & FirstName & "," & Chr(10) & Chr(10) & _
             "Our Records show your Current Loan Details with Club Group Limited are as follows:" & Chr(13) & Chr(10) & Chr(10) & _
             EmailBody & Chr(13) & Chr(10) & Chr(10) & _
             "Your Club Points Balance is " & PointsAvailable & Chr(13) & Chr(10) & Chr(10) & _
             stEmailClose & Chr(13) & Chr(10) & _
             TeamMember & Chr(10) & Chr(10) & _
             ContactDetailBasic & Chr(10) & Chr(10) & _
             fncSeasonMessage
     
            'Write the e-mail content for sending to assignee
    DoCmd.SendObject , , acFormatTXT, varTo, , , stSubject, stText, -1
    
        'Sql to add a Loan Communication record regarding Loan Balances Email Just Sent
    DoCmd.SetWarnings False         'Turn Warnings Off
    strSQL = "INSERT INTO tblCommunication ( RecordRef, OperatorID, RecordType, CommNotes ) " & _
        "SELECT " & LastLoanID & " AS RecordRef, " & Chr(34) & TeamID & Chr(34) & " AS OperatorID, ""Loan"" As RecordType, ""Emailed Member All Loans Balance Advice."" AS CommNotes " & _
        "FROM TBLLOAN " & _
        "WHERE (((TBLLOAN.LDPK)=" & LastLoanID & "));"
    DoCmd.RunSQL strSQL      'Run SQL
    DoCmd.SetWarnings True          'Turn Warnings On
    
   'Close database variables
    rst.Close
    dbs.Close
Exit_CmdEmailMembBal_Click:
    Exit Sub
Err_CmdEmailMembBal_Click:
    MsgBox Err.Description
    Resume Exit_CmdEmailMembBal_Click
    
End Sub