Email query - FROM

S

scubadiver007

Registered User.
Local time
Today, 14:49
Joined
Nov 30, 2010
Messages
317
How do I change the account from which to send the email if I have multiple accounts, or can I?

Thanks in advance
 
I recently managed to find the piece of code to select the account from the available accounts..
Code: 
Public Sub sendEmail(eMailStr As String, subjectLine As String, bodyStr As String, _
                     fileToSend As String, [B]Optional fromStr As String = "someone@somedomain.co.uk"[/B])
[COLOR=Green]' Code Courtesy of
'    Paul Eugin
' Working in Office 2000-2013[/COLOR]

    Dim OutApp As Outlook.Application
    Dim OutMail As Outlook.MailItem
    Dim strbody As String
    
[COLOR=Blue]    Dim OutAccounts As Outlook.Accounts
    Dim OutAccount As Outlook.Account
    Dim OutAccountTemp As Outlook.Account[/COLOR]
    
    Set OutApp = New Outlook.Application
    Set OutMail = OutApp.CreateItem(0)

    [COLOR=Blue]Set OutAccounts = OutApp.Application.Session.Accounts
    For Each OutAccountTemp In OutAccounts
        If (OutAccountTemp.SmtpAddress = fromStr) Then
            Set OutAccount = OutAccountTemp
            Exit For
        End If
    Next[/COLOR]

    On Error Resume Next

    With OutMail
        [COLOR=Blue].SendUsingAccount = OutAccount[/COLOR]
        .Display
        .To = eMailStr
        .Subject = subjectLine
        .HTMLBody = bodyStr & .HTMLBody
        .Attachments.Add fileToSend
        '.Send
    End With

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
Hope this helps.. :)
 
I get a 424 run-time error at the line in red. Can you spot what might be wrong?


Code: 
Dim email As String
Dim Kcode As String
 
Dim OutAccounts As Outlook.Accounts
Dim OutAccount As Outlook.Account
Dim OutAccountTemp As Outlook.Account

    strsql = "Select * from Qry_reminderemail"
    
    Set db = CurrentDb()
    Set rs = db.OpenRecordset(strsql)
    rs.MoveFirst
    
    Do While Not rs.EOF
        
    email = rs!email
    Kcode = rs!Kcode
    
    
    Set objOutlook = CreateObject("Outlook.application")
    Set objEmail = objOutlook.CreateItem(olMailItem)

    [B][COLOR=red]Set OutAccounts = OutApp.Application.Session.Accounts
[/COLOR][/B]    For Each OutAccountTemp In OutAccounts
        If (OutAccountTemp.SmtpAddress = "[EMAIL="sendfrom@email.com"]sendfrom@email.com[/EMAIL]") Then
            Set OutAccount = OutAccountTemp
            Exit For
        End If
    Next

    With objEmail
        .SendUsingAccount = OutAccount
        .To = email
        .CC = "[EMAIL="ccemail@email.net"]ccemail@email.net[/EMAIL]"
        .Subject = Kcode & " - Submission reminder"
        .Body = "Hello," & vbCrLf & vbCrLf & "Please be aware that you still have outstanding submissions." & vbCrLf & vbCrLf & "Regards," & vbCrLf & vbCrLf & "Sarah"
        On Error Resume Next
        .send
    End With

    'objOutlook.Quit
    'Set objEmail = Nothing
    
    
    rs.MoveNext
    Loop
 
Where have you declared OutApp? If you are adapting the code I gave to the way you want it, make sure you map all objects..
Code: 
Set OutAccounts = [COLOR=Red][B]objOutlook.[/B][/COLOR]Application.Session.Accounts
 
I've changed it but the message is still being sent from my old account.

I presume the following code is correct (apart from the email of course)

Code: 
If (OutAccountTemp.SmtpAddress = "[EMAIL="sendfrom@email.com"][COLOR=#0066cc]sendfrom@email.com[/COLOR][/EMAIL]") Then
 
Suggests that it is picking up the Default email or it cannot find the Address you are trying to use.. Try debugging, Print off all emails, see if you have access to the Email account you are trying to use..
 
I have two outlook accounts (this is at work btw) and it is using my default which I no longer use as opposed to the account which I currently use.
 
Did you try debugging the code - Printing off all emails? Or adding Code breakpoints?
 
I'm not sure how to properly debug code. There are no errors so I don't know what to look for.
 
To know more about Debugging.. Check out How to Use immediate window.. Print off all emails..

To know how to add Breakpoints, check the image below..

attachment.php


Provide the code you have managed to adapt...
 
This is the code as it currently stands including saving and adding the attachment:

Code: 
Private Sub Emails_Click()
Dim email As String
Dim Kcode As String
 
Dim OutAccounts As Outlook.Accounts
Dim OutAccount As Outlook.Account
Dim OutAccountTemp As Outlook.Account
 
 
    StrSql = "Select * from Qry_reminderemail"
 
    Set db = CurrentDb()
    Set rs = db.OpenRecordset(StrSql)
    rs.MoveFirst
 
    Do While Not rs.EOF
 
        mySQL = "SELECT Tble_Remainingsubmissions.Service FROM tble_practice " & _
                "INNER JOIN Tble_Remainingsubmissions ON tble_practice.KCode = Tble_Remainingsubmissions.KCode " & _
                "WHERE Tble_Remainingsubmissions.KCode= '" & rs("KCode") & "' ;"
        db.QueryDefs("SUBMISSION_Reminder").SQL = mySQL
    Kcodestr = rs!Kcode
 
    DoCmd.OutputTo acOutputQuery, "submission_reminder", acFormatXLS, "I:\Medical\Enhanced Services\ENHANCED SERVICES\2013-2014\reminders\" & Kcodestr & " - unsubmitted services.xls"
 
 
 
    email = rs!email
    Kcode = rs!Kcode
 
 
    Set objOutlook = CreateObject("Outlook.application")
    Set objEmail = objOutlook.CreateItem(olMailItem)
 
[COLOR=red] Set OutAccounts = objOutlook.Application.Session.Accounts[/COLOR]
[COLOR=red] For Each OutAccountTemp In OutAccounts[/COLOR]
 
[COLOR=red]     If (OutAccountTemp.SmtpAddress = "[/COLOR][EMAIL="email@email.com"][COLOR=red]email@email.com[/COLOR][/EMAIL][COLOR=red]") Then[/COLOR]
[COLOR=red]         Set OutAccount = OutAccountTemp           [/COLOR]
[COLOR=red]         Exit For[/COLOR]
[COLOR=red]     End If[/COLOR]
 
[COLOR=red] Next[/COLOR]
 
 
    With objEmail
        .Importance = olImportanceHigh
[COLOR=red]       .SendUsingAccount = OutAccount[/COLOR]
        .To = email
        .Subject = Kcode & " - Submission reminder"
        .Body = Me!bodytxt
        .Attachments.Add "I:\Medical\Enhanced Services\ENHANCED SERVICES\2013-2014\reminders\" & Kcodestr & " - unsubmitted services.xls"
        On Error Resume Next
        .send
    End With
 
    'objOutlook.Quit
    'Set objEmail = Nothing
 
 
    rs.MoveNext
    Loop
End Sub
 
I see there are several.. like a lot of variable not declared.. Just Add this line to the very start of the module.. Under Option Compare Database.. like
Code: 
Option Compare Database
[COLOR=Red][B]Option Explicit [/B][/COLOR]
Click Compile, it will show all the objects that need to be Declared.. Declare them then you will be narrowing down your problem..
 
Yippee, its now working.

Most of the code is above so I have just included the declarations and code again. This should make some sense

Declarations:

Code: 
Dim objOutlook As Outlook.Application
Dim objEmail As Outlook.MailItem
 
Dim OutAccounts As Outlook.Accounts
Dim OutAccount As Outlook.Account
Dim OutAccountTemp As Outlook.Account

Code: 
    Set objOutlook = CreateObject("Outlook.application")
    Set objEmail = objOutlook.CreateItem(olMailItem)
 
 
    Set OutAccounts = objOutlook.Application.Session.Accounts
    For Each OutAccountTemp In OutAccounts
        If (OutAccountTemp.SmtpAddress = "email@address.net") Then
            Set OutAccount = OutAccountTemp
 
            Exit For
 
        End If
    Next

Code: 
    With objEmail
 
        .SendUsingAccount = OutAccount
 
You must log in or register to reply here.

Similar threads

N
Solved Receiving Emails in Access Database using CDO 2000 library
Replies
10
Views
352
sonic8
S
H
Code for sending email 'transport' error
Replies
11
Views
675
isladogs
isladogs
N
Solved I want to be able to send a few emails in access 2016 using gmail but am having challenges
Replies
7
Views
407
nector
N
N
Solved How to add an attachment in Gmail managed in MS Access VBA
Replies
7
Views
306
nector
N
Jason Lee Hayes
Solved Open Outlook & check for new mail where search criteria is applied to the email subject line
Replies
19
Views
660
Jason Lee Hayes
Jason Lee Hayes

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom