none
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
        Else
         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
        Else
        signame = ""
        End If
    Else
    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)"
        .Filters.Clear
        .AllowMultiSelect = True
        .Show
        End With
        On Error Resume Next
        strFP = Application.FileDialog(msoFileDialogFilePicker).SelectedItems(1) '& "\"
     Else
        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
    Else




    Do Until rs.EOF

        If IsNull(![First Name]) = True Then
          fName = ""
          Else
          fName = ![First Name]
        End If
        If IsNull(![Last Name]) = True Then
          lName = ""
          Else
          lName = ![Last Name]
        End If
        If IsNull(![Company1]) = True Then
          Company = ""
          Else
          Company = ![Company1]
        End If
        
        
        If IsNull(![Subject]) = True Then
          strsubject = ""
        End If
        
        
        
        If IsNull(![Email1]) = True Then
          stremail = ""
          
          
          
          cNoEmail = cNoEmail & " " & fName & " " & lName
          
          Else
          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
        .Display
        If Forms![Dashboard].[Manage Company Emails]![mceCBoxAttachFiles] = True Then
        .Attachments.Add (strFP)
        End If
        

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

    Loop


    End If

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

    'On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing

    End With





    errorhandler:
     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"
     
    theEnd:
    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
    www.thatlldoit.com
    http://tech.groups.yahoo.com/group/MS_Access_Professionals

    Tuesday, February 26, 2019 6:45 PM