sending gmail via excel vba

[MrCaptain]

Hi all,

Just following up on an earlier post with a different question. I have managed to get excel to send an e-mail via gmail thanks to some great advice from Redbeard. I think a new post may now be more appropriate.

My other questions associated with this process are:

1. Is it possible to 'Display' instead of 'Send' a Gmail?
2. Is it possible to attach a file with vba code to open a search on my pc then click and select a file to attach?
3. To select and paste e-mail addresses from a list that meet certain criteria (the criteria might be a 1 or 0 in an adjacent column to signify selection of qualifying recipients) and place them in the bcc field?
4. Is it possible to use a vba reference to get information or a different message based on criteria into the vba below?
e.g. message 1 might say 'Please contact us', message 2 'You are already registered'. The users will be filling in a form to register, and their responses will determine the message to use.

Sorry its 4 questions, if anyone wants to just answer one of them that's fine.

Here's the code I currently have (below this message).

Thanks for any help or suggestions,

Regards,

Vern

Private Sub cmdSendEmail_Click()
Dim Mail As New message
Dim Config As Configuration
Set Config = Mail.Configuration
'Set Mail = server.CreateObject("CDO.Message")
Config(cdoSendUsingMethod) = cdoSendUsingPort
Config(cdoSMTPServer) = "smtp.gmail.com"
Config(cdoSMTPAuthenticate) = 25
Config(cdoSMTPAuthenticate) = cdoBasic
Config(cdoSMTPUseSSL) = True
Config(cdoSendUserName) = "myusername"
Config(cdoSendPassword) = "mypassword"
Config.Fields.Update
Mail.To = "recipient e-mail"
Mail.From = Config(cdoSendUserName)
Mail.Subject = "Email Subject"
Mail.HTMLBody = "[B]EmailBody here[/B]"
On Error Resume Next
Mail.Send    ' Tried Draft, Open, Display, all failed
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "There was an error"
Exit Sub
End If
MsgBox "Your e-mail has been sent!", vbInformation, "Sent"
End Sub

 

[Perpa]

Vern,
The two code snipets (between the rows of asterisks) added to your code should allow you to select and attach a file from your PC (Question 2).
Perpa

Private Sub cmdSendEmail_Click()
Dim Mail As New message
Dim Config As Configuration
'***************************************
'This will allow for selection of a file to attach to your email
    FileToOpen = Application.GetOpenFilename _
    (Title:="Please choose a file to import", _
    FileFilter:="")
    
    If FileToOpen = False Then
    MsgBox "No file specified.", vbExclamation, "Try Again"
    Exit Sub
'The next 3 lines are commented out, but show show 2 options if you wanted to see the 'FileToOpen' complete path and filename
    'Else
    'MsgBox "The File Selected was " & FileToOpen
    'cells(2,"D").value = FileToOpen     'Change 'cells(2,"D")' to the cell you want to save the complete path and filename to
   End if
'***************************************
Set Config = Mail.Configuration
'Set Mail = server.CreateObject("CDO.Message")
Config(cdoSendUsingMethod) = cdoSendUsingPort
Config(cdoSMTPServer) = "smtp.gmail.com"
Config(cdoSMTPAuthenticate) = 25
Config(cdoSMTPAuthenticate) = cdoBasic
Config(cdoSMTPUseSSL) = True
Config(cdoSendUserName) = "myusername"
Config(cdoSendPassword) = "mypassword"
Config.Fields.Update
Mail.To = "recipient e-mail"
Mail.From = Config(cdoSendUserName)
Mail.Subject = "Email Subject"
Mail.HTMLBody = "EmailBody here"
'***************************************
Mail.AddAttachment FileToOpen
'***************************************
On Error Resume Next
Mail.Send    ' Tried Draft, Open, Display, all failed
If Err.Number <> 0 Then
MsgBox Err.Description, vbCritical, "There was an error"
Exit Sub
End If
MsgBox "Your e-mail has been sent!", vbInformation, "Sent"
End Sub

 

[MrCaptain]

Thanks Perpa,
I'll try it out.
Regards,
Vern

 

[Perpa]

Vern,
I hadn't seen any other responses to your other questions, so I went ahead and worked on a response to your question 3. Assuming you have each email address listed separately on Sheet1 in column D beginning in row 2, then continuing down to the last used row in column D. And you have placed a '1' in column E for the email addresses you want to include, the 2 macros below will make a composite list of email addresses.

You can change the column and row as indicated to fit your data. Then you could then add

'Mail.BCC = Sheets("Sheets2")!Range("A1").value'

to your previous CDO code.
Perpa

Sub MakeBccList()
'Find all the rows  that have a "1" in column "E" on Sheet1
'copy email address in column "D" Sheet1  to the next blank row on  sheet2, column "A".
Dim myEmailCol, OneCol, rw2 As Integer

myEmailCol = 4            'Column with list of email addresses, D = 4, change to suit
OneCol = 5                'Column where you enter '1', E = 5, change to suit

Worksheets("Sheet2").UsedRange.ClearContents
Worksheets("Sheet1").Activate
rw2 = 2

For Each r In Worksheets("Sheet1").UsedRange.Rows
   n = r.Row
       If Worksheets("Sheet1").Cells(n, OneCol).Value = 1 Then
           Sheets("Sheet1").Cells(n, myEmailCol).Copy Sheets("Sheet2").Range("A" & rw2)
           rw2 = rw2 + 1
       End If
Next r

Call ListInOneCell
End Sub

Sub ListInOneCell()
'Make  a composite List in cell A1 of All Email Addresses on Sheet2, Column A, row 2 and below
    Dim w As Long
    Dim LR As Long
    Dim t As String
    Dim Rng As Range, c As Range
    
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Sheets("Sheet2").Activate
    LR = Range("A2").End(xlDown).Offset(1, 0).Row    'Change A2 to your beginning cell
 
    Set Rng = Range("A2:A" & LR)
    
    'Trim - replaces all multiple spaces with a single one,
    'as well as removes spaces from the left & right of the cell value
        With Rng
            .Value = Application.Trim(.Value)
        End With
    
        For Each c In Rng
            If c <> "" Then
                t = t & c & ";"                    'Note: To add a space after each semicolon use "; "
            Else
                t = Left(t, Len(t) - 1)            'Removes the last semicolon, change the '1' to '2' if the separator is a semicolon and a space
                c.Value = t
                t = ""
            End If
        Next c
    Cells(1, "A") = Cells(LR, "A")  'This is where I put the composite list of email addresses in A1, change to suit
    Cells(LR, "A").ClearContents   
    Sheets("Sheet1").Activate
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

 

[MrCaptain]

Wow, thanks Perpa, really appreciate your time with this, I have to get back into it in a few days but once again thank you very much.
I have dabbled with vba but never seem to really master any of it.
Regards,
Vern