E-mail code doesn't work

[Fire_Chief]

I have tried for 3 days to get this to work.
PLEASE HELP ME



Sub SendEmailUsingYahoo()

On Error GoTo Err

Dim NewMail As Object
Dim mailConfig As Object
Dim fields As Variant
Dim msConfigURL As String

Set NewMail = CreateObject("CDO.Message")
Set mailConfig = CreateObject("CDO.Configuration")

' load all default configurations
mailConfig.Load -1

Set fields = mailConfig.fields

'Set All Email Properties

With NewMail
.Subject = "Test Mail from LearnExcelMacro"
.From = "ncaatest@yahoo.co.in"
.To = "D1C@comcast.net.com;D1C@comcast.net"
.CC = ""
.BCC = ""
.TextBody = "TEST"
End With

msConfigURL = "http://schemas.microsoft.com/cdo/configuration"

With fields
'Enable SSL Authentication
.Item(msConfigURL & "/smtpusessl") = True

'Make SMTP authentication Enabled=true (1)
.Item(msConfigURL & "/smtpauthenticate") = 1

'Set the SMTP server and port Details
'To get these details you can get on Settings Page of your yahoo Account
.Item(msConfigURL & "/smtpserver") = "smtp.mail.yahoo.com"
.Item(msConfigURL & "/smtpserverport") = 465
.Item(msConfigURL & "/sendusing") = 2

'Set your credentials of your yahoo Account
.Item(msConfigURL & "/sendusername") = "ncaatest@yahoo.com.in"
.Item(msConfigURL & "/sendpassword") = "mypassword"

'Update the configuration fields
.Update

End With
NewMail.Configuration = mailConfig
NewMail.Send
MsgBox ("Mail has been Sent")

Exit_Err:

Set NewMail = Nothing
Set mailConfig = Nothing
End

Err:
Select Case Err.NUMBER

Case -2147220973 'Could be because of Internet Connection
MsgBox " Could be no Internet Connection !! -- " & Err.Description

Case -2147220975 'Incorrect credentials User ID or password
MsgBox "Incorrect Credentials !! -- " & Err.Description

Case Else 'Rest other errors
MsgBox "Error occured while sending the email !! -- " & Err.Description
End Select

Resume Exit_Err

End Sub

 

[Logit]

.
Ask away !

 

[Fire_Chief]

This works fine for using Outlook but he does not use outlook. That must be why CDO works well if I (or you more likely) can make it work for yahoo. Thanks again

 

[Fire_Chief]

Maybe this will help explain:

I have an excel program that completely keeps track of the NCAA basketball tournament. (its a POOL)
It sends out the spreads for games and the winners. It will send a PDF of the page that has all the games on it and the teams they are playing.
I need a PDF because everyone I send it to does not have excel.

It works great for anyone that has a comcast e-mail ask I know how to set that up.

I have two friends that want to use the program themselves and send out their own emails but they do not use Comcast or Outlook.

One uses gmail and the other uses yahoo.
I tried to modify the CDO I use.
I changed the SMTP to yahoo or gmail but it doesn't work. I changed everything that needed changing and no luck.

Thanks again

 

[Logit]

.
I've never tried this workbook. Picked it up somewhere a couple of years ago.
How about giving it a try and see what happens ?

'*******************************************************************
'  Macro written by Vish Mishra - http://www.learnexcelmacro.com
'  This macro helps you to send many more emails individually.
'  It supports GMAIL, YAHOO, NETSCAPE, AOL, HOTMAIL, REDIFFMAIL
'  and OUTLOOK.
'  For any other SMTP Server, if you want to send email, then
'  you need to enter SMTP Server Name and port in the Popup
'  and it will work for that as well.
'
'  For any other clarification ot issues, mail me
'  Info@learnexcelmacro.com


'********************************************************************








Public smtpServer As String, smtpServerPort As String, sendUserName As String, sendPassword As String


'*********************************************************************


'   This module for all the Non-Outlook Mails.
'   It requires SMTP details to connect and send emails


'*********************************************************************


Sub SendEmail(smtpServer As String, smtpServerPort As String, sendUserName As String, sendPassword As String)
    
    Dim NewMail As CDO.Message
    Set NewMail = New CDO.Message
    Dim i, j, tCount, iValue, iCaption
    
'Enable SSL Authentication
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    
'Make SMTP authentication Enabled=true (1)
    
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    
'Set the SMTP server and port Details
'To get these details you can get on Settings Page of your Gmail Account
    
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = smtpServer
    
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = smtpServerPort
    
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
    
'Set your credentials of your Gmail Account
    
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendusername") = sendUserName
    
    NewMail.Configuration.Fields.Item _
    ("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sendPassword
    
'Update the configuration fields
    NewMail.Configuration.Fields.Update
    
'Set All Email Properties
    i = 7
    j = 7
    tCount = 1
    Unload frmSendEmailOption
    DoEvents
    Sheet1.Label2.Visible = True
    Sheet1.lblProgressBar.Width = 11
    Sheet1.lblProgressBar.Caption = 31 & "%"
    
    
    If Range("B7").Value = "" Then
        
    ElseIf Range("B8").Value = "" Then
        
        tCount = 1
    Else
        Range("B7").Select
        tCount = Range(Selection, Selection.End(xlDown)).Count
    End If
    
    iValue = (320 / tCount)
    
    On Error Resume Next
    While Range("B" & i).Value <> "" Or Range("C" & i).Value <> "" Or Range("D" & i).Value <> ""
        
        With NewMail
            .Subject = Range("E" & i).Value
            .From = sendUserName
            .To = Range("B" & i).Value
            .CC = Range("C" & i).Value
            .BCC = Range("D" & i).Value
            .textbody = Range("F" & i).Value
        End With
        
        On Error GoTo err1
'On Error Resume Next
        
        NewMail.Send
        
        Range("B" & i & ":F" & i).Interior.ColorIndex = 2
        Range("G" & i).Value = ""
        j = j + 1
        
        Sheet1.lblProgressBar.Width = Sheet1.lblProgressBar.Width + iValue
        If Int(((Sheet1.lblProgressBar.Width) / 3.2)) < 100 Then
        Sheet1.lblProgressBar.Caption = Int(((Sheet1.lblProgressBar.Width) / 3.2)) & "%"
        Else
        Sheet1.lblProgressBar.Caption = "100%"
        End If
        DoEvents
        
        i = i + 1
        
        
loop1:           Wend
        
        
err1:         If err.Description Like "*The message could not be sent to the SMTP server*" Then
        
        
        MsgBox "Connection to SMTP not happening. Check your ID and Password and Try Again"
        
        Sheet1.lblProgressBar.Width = 0
        Sheet1.lblProgressBar.Visible = False
        Sheet1.Label1.Caption = ""
        Sheet1.Label1.Visible = False
        Sheet1.Label2.Visible = False
        Exit Sub
        
        
    Else
        
        If err.Number <> 0 Then
            Range("B" & i & ":F" & i).Interior.Color = 255
            Range("G" & i).Value = err.Description & "(" & err.Number & ")"
            i = i + 1
            Resume loop1
        End If
    End If
    
    Sheet1.Label2.Visible = False
    Sheet1.lblProgressBar.Visible = False
    Sheet1.Label1.Visible = True
    Sheet1.Label1.Caption = "[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Emails]#Emails[/URL]  Successfully Sent: " & j - 7 & "                                 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Emails]#Emails[/URL]  Failed: " & tCount - (j - 7)
    
End Sub




'*********************************************************************


'   This module for Outlook Mails.




'*********************************************************************




Sub SendEmailUsingOutlook()
    
    Dim OlApp As New Outlook.Application
    Dim myNameSp As Outlook.Namespace
    Dim myInbox As Outlook.MAPIFolder
    Dim myExplorer As Outlook.Explorer
    Dim NewMail As Outlook.MailItem
    Dim OutOpen As Boolean
    
' Check to see if there's an explorer window open
' If not then open up a new one
    OutOpen = True
    Set myExplorer = OlApp.ActiveExplorer
    If TypeName(myExplorer) = "Nothing" Then
        OutOpen = False
        Set myNameSp = OlApp.GetNamespace("MAPI")
        Set myInbox = myNameSp.GetDefaultFolder(olFolderInbox)
        Set myExplorer = myInbox.GetExplorer
    End If
    
' If you  don't to display your outlook while sending email then comment the below statement
'otherwise you can un-comment
    
'myExplorer.Display
    
    i = 7
    j = 7
    tCount = 1
    
    Sheet1.lblProgressBar.Width = 1
    DoEvents
    
    If Range("B7").Value = "" Then
        
    ElseIf Range("B8").Value = "" Then
        
        tCount = 1
    Else
        Range("B7").Select
        tCount = Range(Selection, Selection.End(xlDown)).Count
    End If
    
    iValue = (99 / tCount)
    On Error GoTo err1
    While Range("B" & i).Value <> "" Or Range("C" & i).Value <> "" Or Range("D" & i).Value <> ""
' Create a new mail message item.
        Set NewMail = OlApp.CreateItem(olMailItem)
        With NewMail
            .Subject = Range("E" & i).Value
            .To = Range("B" & i).Value
            .CC = Range("C" & i).Value
            .BCC = Range("D" & i).Value
            .Body = Range("F" & i).Value
        End With
        
        NewMail.Display
        
        Range("B" & i & ":F" & i).Interior.ColorIndex = 2
        Range("G" & i).Value = ""
        j = j + 1
        
        Sheet1.lblProgressBar.Width = Sheet1.lblProgressBar.Width + iValue
        DoEvents
        
        i = i + 1
        
        
loop1:                 Wend
        
        
err1:
        If err.Number <> 0 Then
            Range("B" & i & ":F" & i).Interior.Color = 255
            Range("G" & i).Value = err.Description & "(" & err.Number & ")"
            i = i + 1
            Resume loop1
        End If
        
        
        Sheet1.lblProgressBar.Visible = False
        Sheet1.Label1.Visible = True
        Sheet1.Label1.Caption = "[URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Emails]#Emails[/URL]  Successfully Sent: " & j - 7 & "                                 [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Emails]#Emails[/URL]  Failed: " & tCount - (j - 7)
        
        
        If Not OutOpen Then OlApp.Quit
        
'Release memory.
        Set OlApp = Nothing
        Set myNameSp = Nothing
        Set myInbox = Nothing
        Set myExplorer = Nothing
        Set NewMail = Nothing
        
    End Sub

Download workbook : https://www.amazon.com/clouddrive/share/lndvleku0hfpK2k9GrcbJqCz63KdC4zBC6oTPIN7FW8

 

[Fire_Chief]

will try it Thanks and will let you know in a few days

 

[Fire_Chief]

That didn't work at all but thanks for trying. I now have code that works for both gmail and comcast. I still need code for yahoo and if possible aol.

 

[Logit]

.
For Yahoo ...

Option Explicit


Sub SendWorkSheetToPDF()


Dim Wb As Workbook
Dim FileName As String
Dim OutlookApp As Object
Dim OutlookMail As Object
Dim xIndex As Integer
Dim Addresses As String
On Error Resume Next
Set Wb = Application.ActiveWorkbook


    FileName = Wb.FullName
    
    xIndex = VBA.InStrRev(FileName, ".")
    
        If xIndex > 1 Then FileName = VBA.Left(FileName, xIndex - 1)
        
        FileName = FileName & "_" + ActiveSheet.Name & ".pdf"
        ThisWorkbook.Sheets(Array("Sheet2", "Sheet3", "Sheet4", "Sheet8")).Select   '<-- change sheets to be PDF here
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=FileName
        Set OutlookApp = CreateObject("Outlook.Application")
        Set OutlookMail = OutlookApp.CreateItem(0)
        Addresses = Sheets("Sheet1").Range("A1").Value
        
            With OutlookMail
                .To = Addresses
                .CC = ""
                .BCC = ""
                .Subject = "Terminal Workload Calculator - Mobile/109"
                .Body = " "
                .Body = "Terminal Workload Calculator - Mobile/109 - Fail to plan... Plan to fail"
                .Attachments.Add FileName
                .Display
            End With
            
    Kill FileName
    Set OutlookMail = Nothing
    Set OutlookApp = Nothing
    
Sheets("Sheet1").Activate
Sheets("Sheet1").Range("A1").Select
End Sub

Download workbook : https://www.amazon.com/clouddrive/share/RtONqtiD3gBcm6b60taxAq50SZsnnh7eHF6DFG7cj8G

 

[Fire_Chief]

I cannot use outlook to send it.