Please Help - Mailing VBA Listbox Items using SMTP

[Mahantesh]

Hi Team,

I have userform where i populate data in 4 columns using VBA Listbox (Columncount=4)

Now, i want to send these listbox items in an email using SMTP in tabular formati dont have installed EMail program on Server)

Please can anyone help!
--------------------------------------------------
Private Sub CommandButton2_Click()
Dim iMsg As Object
Dim iConf As Object
Dim Flds As Variant, i As Integer
Dim strbody As String, tlr As Integer, rng As Range, mess As Range
'rng = ""
tlr = ThisWorkbook.Sheets("temp").Range("A" & Rows.Count).End(xlUp).Row

'Range("A2:G26").Select
'Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
'Range("A2").Select

'------mailing Listitems

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")

iConf.Load -1 ' CDO Source Defaults
Set Flds = iConf.Fields

With Flds
.item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "SMTP.pfsweb.com"
.item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Update
End With

strbody = "Hello All, " & vbNewLine & vbNewLine & _
"Below are the details of recovered Items : "
'mess = ""
Set mess = ThisWorkbook.Sheets("temp").Range("A1 :E" & tlr).Select

'For i = 1 To tlr
'For Each rng In mess
' rng.Value = rng.Value & mess
'Next rng
'Next i



'vbNewLine & vbNewLine & Me.List22.Column(1) & ", " & Me.List22.Column(2) & ", " & Me.List22.Column(3) & ", " & Me.List22.Column(4) & ", " & Me.List22.Column(5)
For i = 0 To UserForm20.ListBox1.ListCount - 1
With iMsg

Set .Configuration = iConf

'UserForm20.ListBox1.Selected(i) = True
.To = "mtoragall@pfsweb.com"
'.CC = ""
'.BCC = ""
.From = "easyasset@pfsweb.com"
.Subject = "EasyAsset Recovered Assets"
.Textbody = mess
'.Textbody = strbody & vbNewLine & vbNewLine & UserForm20.ListBox1.Column(1) & ", " & UserForm20.ListBox1.Column(2) & ", " & UserForm20.ListBox1.Column(3) & ", " & UserForm20.ListBox1.Column(4)
'Application.SendKeys "%s"
iMsg.Send
End With

Next i

End Sub

----------------------------
Regards,
Mahantesh

 

[Chihiro]

I'd use Blat instead of VBA to send via SMTP.
https://sourceforge.net/projects/blat/

If you are married to VBA to send email via SMTP. Use CDO.Message. Read article in the link carefully as there are preliminary setup that you must do before code can be used.

http://www.rondebruin.nl/win/s1/cdo.htm

 

[Kenneth Hobson]

You should probably create another account if you are using Gmail and have to lower security.

Here is my cdo example. Note that you will want to use Ron's RangeToHTML() and .HTMLbody in the cdo. You can add an input as a Range for that if you want to use it as a function as I did.

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

'CDO to gmail requires lowering your security:
'https://myaccount.google.com/security#connectedapps
'at the end set, Allow less secure apps: ON

Function Gmail(sendUsername As String, sendPassword As String, subject As String, _
  textBody As String, sendTo As String, sendFrom As String, _
  Optional sAttachment As String = "")
  Dim cdomsg As New CDO.Message  'early binding method
  'set cdomsg=new CDO.Message 'early binding only
  'Dim cdomsg As Object 'late binding method
  Set cdomsg = CreateObject("CDO.message")  'late binding method or early binding

  With cdomsg.Configuration.Fields
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'NTLM method
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
    .Item("http://schemas.microsoft.com/cdo/configuration/smptserverport") = 25  '25 or 587
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
    .Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
    .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = sendUsername
    .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = sendPassword
    .Update
  End With
  ' build email parts
  With cdomsg
    .To = sendTo
    .From = sendFrom
    .subject = subject
    .textBody = textBody
    '.BCC
    '.CC
    '.ReplyTo = sendFrom
    '.HTMLBody
    '.HTMLBodyPart
    If Dir(sAttachment) = "" Then sAttachment = ""
    If sAttachment <> "" Then .AddAttachment (sAttachment)
    .Send
  End With
  Set cdomsg = Nothing
End Function