VB Mass Email Problem RRS feed

  • Question

  • Hey,

    I've got this code:

    Sub SendEmailFromQuery()

    'On Error GoTo errorhandler

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String
    Dim stremail As String
    Dim strsubject As String
    Dim strsql As String
    Dim strFP As String
    Dim strFN As String
    Dim workupdate As String
    Dim sigstring As String
    Dim signature, signature2 As String
    Dim signame As String
    Dim setEmailMe As String
    Dim fName As String
    Dim lName As String
    Dim Company As String
    Dim cNoEmail As String
    Dim i As Integer
    Dim db As DAO.Database
    Set db = CurrentDb

    ' checks if signature name box is empty before sending mass email
        If IsBlank(Forms![Dashboard].[dshMyName]) = True Or Forms![Dashboard].dshMyName = "Your name here" Then
         MsgBox "missing name for update! - no email sent; please enter your name on the dashboard"
         GoTo theEnd
         workupdate = "INSERT INTO Worked ( [First], [Last], Financer, Mining, Supplier, [Company], [Last Contact], Type, Notes, Who ) VALUES ('" & fName & "','" & lName & "',Forms![Dashboard].[Financer], Forms![Dashboard].[Mining], Forms![Dashboard].[Supplier], '" & Company & "', date(), 'Mass eMail', Forms![Dashboard].[Manage Company Emails]![mceSubject], Forms![Dashboard].[dshMyName]);"
        End If
     If IsBlank(Me.mceTxtSigName.Value) = True Then

        Const cstrPrompt As String = _
            "No signature found with this name - continue?"
        If MsgBox(cstrPrompt, vbQuestion + vbYesNo) = vbNo Then
            Cancel = True
            Exit Sub
        signame = ""
        End If
    signame = Me.mceTxtSigName.Value
    End If

    cNoEmail = ""
    i = 0

    'Code here

    setEmailMe = "UPDATE Contacts Set [EmailMe] = 0"

    StrSQL2 = "INSERT INTO Worked ( [First], [Last], Company, [Last Contact], Type, Notes ) VALUES ('MASS', 'EMAIL', Forms![Dashboard].[dshCompany1], date(), 'Mass eMail', Forms![Dashboard].[dshNotes]);"

     If Me.mceCBoxAttachFiles = True Then
        With Application.FileDialog(msoFileDialogFilePicker)
        .Title = "Choose your attachments (ctrl+click or shift+click to select multiple attachments)"
        .AllowMultiSelect = True
        End With
        On Error Resume Next
        strFP = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1) '& "\"
        strFP = ""
     End If

    strsql = "SELECT Contacts.[Email1], Contacts.[Company1], Contacts.[Country1], Contacts.[First name], Contacts.[Last Name] INTO massMail From Contacts WHERE (((Contacts.EmailMe)=-1) AND (Contacts.Email1 <> '') AND (Contacts.Unsubscribe <> -1));"
    'strsql = "SELECT Contacts.[Email1], Contacts.[Company1], Contacts.[Country1], Contacts.[First name], Contacts.[Last Name] INTO massMail;"
    Set OutApp = CreateObject("Outlook.Application")

    DoCmd.SetWarnings False
    DoCmd.RunSQL strsql
    DoCmd.SetWarnings True

    Dim rs As DAO.Recordset

    Set qdf = CurrentDb.QueryDefs(strsql)
    qdf.Parameters("Some param").Value = "whatever"

    Set rs = qdf.OpenRecordset(dbOpenDynaset)

    'Set rs = db.OpenRecordset(strsql)

    ''add your query here

    With rs

    If rs.EOF And rs.BOF Then
    MsgBox "No emails will be sent becuase there are no records assigned from the list", vbInformation

    Do Until rs.EOF

        If IsNull(![First Name]) = True Then
          fName = ""
          fName = ![First Name]
        End If
        If IsNull(![Last Name]) = True Then
          lName = ""
          lName = ![Last Name]
        End If
        If IsNull(![Company1]) = True Then
          Company = ""
          Company = ![Company1]
        End If
        If IsNull(![Subject]) = True Then
          strsubject = ""
        End If
        If IsNull(![Email1]) = True Then
          stremail = ""
          cNoEmail = cNoEmail & " " & fName & " " & lName
          stremail = ![Email1] ''Query2 Fields [email];  [Address];  [Name]
        End If
        If IsNull(Me.mceSubject) = True Then
         MsgBox "Please fill out Subject before sending"
         Exit Sub
        End If
        strsubject = Me.mceSubject
        If IsNull(Me.mceContents) = True Then
         MsgBox "Please fill out the body before sending"
         Exit Sub
        End If
         strbody = "Dear " & fName & ",<br><br>" & Me.mceContents
        Debug.Print (strbody)

        DoCmd.SetWarnings False
        DoCmd.RunSQL workupdate
        DoCmd.SetWarnings True


    'On Error Resume Next

    Set OutMail = OutApp.CreateItem(olMailItem)
    With OutMail
        .BodyFormat = olFormatRichText
        .To = stremail
        .CC = ""
        .BCC = ""
        .Subject = strsubject
        .HTMLBody = strbody & "<br><br>" & signature
        If Forms![Dashboard].[Manage Company Emails]![mceCBoxAttachFiles] = True Then
        .Attachments.Add (strFP)
        End If

        .SendUsingAccount = OutApp.Session.Accounts.Item(2)
    End With


    End If

    DoCmd.SetWarnings False
    DoCmd.RunSQL setEmailMe
    DoCmd.SetWarnings True

    'On Error GoTo 0

    If Not rs Is Nothing Then
    Set rs = Nothing
    End If

    Set OutMail = Nothing
    Set OutApp = Nothing

    End With

     If Err.Number <> 0 Then
       MsgBox "Please check your inputs and try again"
       MsgBox Err.Number & " - " & Err.Description
       Exit Sub
     End If
    MsgBox "Done sending mass messages"
    End Sub

    When i try to send email, error pops up : No item found in this collection.

    Can someone help me, what is the problem?

    Tuesday, February 26, 2019 3:04 PM

All replies

  • On what line does the error stop on? And with the pseudo code line that says ''add your query here, the code is incomplete and is bound to fail.

    This is what happens when you copy & paste code without understanding how it works.

    Bill Mosca

    Tuesday, February 26, 2019 6:45 PM