turloughm
asked on
Sending an email from vb
I want to send an email from within vb,I have never done this before,Does anybody have a sample of how this is done.
Regards T
Regards T
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
It won't work,
I have other code at work.
I will post it tomorrow
I have other code at work.
I will post it tomorrow
ASKER
I'm trying to cover all angles
Cheers T
Cheers T
I have a sample project which I can send you. This application uses Winsock so all you need is an Internet connection.
Here is the form:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC- 0080C7E7B7 8D}#1.0#0" ; "MSWINSCK.OCX"
Begin VB.Form Form2
Caption = "Form2"
ClientHeight = 6045
ClientLeft = 60
ClientTop = 345
ClientWidth = 5985
LinkTopic = "Form2"
ScaleHeight = 6045
ScaleWidth = 5985
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtCC
Height = 285
Left = 1320
TabIndex = 13
Text = "<emoreau@s2i.com>"
Top = 1560
Width = 4455
End
Begin VB.TextBox txtEmailBodyOfMessage
Height = 2445
Left = 1320
MultiLine = -1 'True
TabIndex = 11
Text = "Form2.frx":0000
Top = 2280
Width = 4455
End
Begin VB.TextBox txtEmailSubject
Height = 285
Left = 1320
TabIndex = 9
Text = "Test PSP"
Top = 1920
Width = 2655
End
Begin VB.TextBox txtToEmailAddress
Height = 285
Left = 1320
TabIndex = 7
Text = "<emoreau@s2i.com>"
Top = 1200
Width = 4455
End
Begin VB.TextBox txtFromEmailAddress
Height = 285
Left = 1320
TabIndex = 5
Text = "emoreau@s2i.com"
Top = 840
Width = 2655
End
Begin VB.TextBox txtEmailServer
Height = 285
Left = 1320
TabIndex = 4
Text = "mail.s2i.com"
Top = 120
Width = 2655
End
Begin VB.CommandButton Command2
Caption = "Quit"
Height = 495
Left = 3360
TabIndex = 1
Top = 5400
Width = 1215
End
Begin VB.CommandButton Command1
Caption = "Send"
Height = 495
Left = 2040
TabIndex = 0
Top = 5400
Width = 1215
End
Begin MSWinsockLib.Winsock Winsock1
Left = 4200
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 327681
End
Begin VB.Label Label1
Caption = "CC (address)"
Height = 255
Index = 1
Left = 0
TabIndex = 14
Top = 1560
Width = 1335
End
Begin VB.Label Label1
Caption = "Message"
Height = 255
Index = 6
Left = 0
TabIndex = 12
Top = 2280
Width = 1335
End
Begin VB.Label Label1
Caption = "Subject"
Height = 255
Index = 5
Left = 0
TabIndex = 10
Top = 1920
Width = 1335
End
Begin VB.Label Label1
Caption = "To (address)"
Height = 255
Index = 4
Left = 0
TabIndex = 8
Top = 1200
Width = 1335
End
Begin VB.Label Label1
Caption = "From (address)"
Height = 255
Index = 3
Left = 0
TabIndex = 6
Top = 840
Width = 1215
End
Begin VB.Label lblStatus
BorderStyle = 1 'Fixed Single
Height = 375
Left = 120
TabIndex = 3
Top = 4920
Width = 5775
End
Begin VB.Label Label1
Caption = "E-Mail server"
Height = 255
Index = 0
Left = 0
TabIndex = 2
Top = 120
Width = 1215
End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Description:Allows sending of e-mail (SMTP) directly from
'VB app using Winsock, WITH OUT having to buy an expensive
'on component
'//Input Requirements: Server Address (Name or IP), Senders & //Recipeient's Names, Sender & Recipient E-Mail address, Body of //message
Private mstrResponse As String
Private Sub SendEmail(ByVal pstrMailServerName As String, _
ByVal pstrFromEmailAddress As String, _
ByVal pstrToEmailAddress1 As String, _
ByVal pstrToEmailAddress2 As String, _
ByVal pstrToEmailAddress3 As String, _
ByVal pstrToEmailAddress4 As String, _
ByVal pstrToEmailAddress5 As String, _
ByVal pstrEmailSubject As String, _
ByVal pstrEmailBodyOfMessage As String)
Dim strDateNow As String
Dim strFirst As String
Dim strThird As String
Dim strFourth As String
Dim strFifth As String
Dim strSixth As String
Dim strSeventh As String
Dim strEighth As String
Dim strNinth As String
Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail per program start
strDateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0500"
strFirst = "mail from:" + Chr(32) + pstrFromEmailAddress + vbCrLf ' Get who's sending E-Mail address
strThird = "Date:" + Chr(32) + strDateNow + vbCrLf ' Date when being sent
strFourth = "From:" + Chr(32) + pstrFromEmailAddress + vbCrLf ' Who's Sending
strFifth = "To:" + Chr(32) + _
IIf(Len(pstrToEmailAddress 1) > 0, pstrToEmailAddress1 + "; ", "") + _
IIf(Len(pstrToEmailAddress 2) > 0, pstrToEmailAddress2 + "; ", "") + _
IIf(Len(pstrToEmailAddress 3) > 0, pstrToEmailAddress3 + "; ", "") + _
IIf(Len(pstrToEmailAddress 4) > 0, pstrToEmailAddress4 + "; ", "") + _
IIf(Len(pstrToEmailAddress 5) > 0, pstrToEmailAddress5 + "; ", "") + _
vbCrLf ' Who it going to
strSixth = "Subject:" + Chr(32) + pstrEmailSubject + vbCrLf ' Subject of E-Mail
strSeventh = pstrEmailBodyOfMessage + vbCrLf ' E-mail message body
strNinth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' What program sent the e-mail, customize this
strEighth = strFourth + strThird + strNinth + strFifth + strSixth ' Combine for proper SMTP sending
With Winsock1
If .State = sckClosed Then ' Check to see if socet is closed
.Protocol = sckTCPProtocol ' Set protocol for sending
.RemoteHost = pstrMailServerName ' Set the server address
.RemotePort = 25 ' Set the SMTP Port
.Connect ' Start connection
WaitFor ("220")
lblStatus.Caption = "Connecting...."
lblStatus.Refresh
.SendData ("HELO worldcomputers.com" + vbCrLf)
WaitFor ("250")
lblStatus.Caption = "Connected"
lblStatus.Refresh
.SendData (strFirst)
lblStatus.Caption = "Sending Message"
lblStatus.Refresh
WaitFor ("250")
' .SendData (strEmailTo1)
' WaitFor ("250")
If Len(pstrToEmailAddress1) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress1 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress2) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress2 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress3) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress3 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress4) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress4 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress5) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress5 + vbCrLf)
WaitFor ("250")
End If
.SendData ("data" + vbCrLf)
WaitFor ("354")
.SendData (strEighth + vbCrLf)
.SendData (strSeventh + vbCrLf)
.SendData ("." + vbCrLf)
WaitFor ("250")
.SendData ("quit" + vbCrLf)
lblStatus.Caption = "Disconnecting"
lblStatus.Refresh
WaitFor ("221")
.Close
Else
MsgBox (Str(.State))
End If
End With
End Sub
Sub WaitFor(strResponseCode As String)
Dim sngStart As Single
Dim sngTmr As Single
sngStart = Timer ' Time event so won't get stuck in loop
While Len(mstrResponse) = 0
sngTmr = sngStart - Timer
DoEvents ' Let System keep checking for incoming response **IMPORTANT**
If sngTmr > 50 Then ' Time in seconds to wait
MsgBox "SMTP service error, timed out while waiting for response", 64
Exit Sub
End If
Wend
sngStart = Timer ' Time event so won't get stuck in loop
While Left$(mstrResponse, 3) <> strResponseCode
sngTmr = Timer - sngStart
DoEvents
If sngTmr > 50 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + strResponseCode + " Code recieved: " + mstrResponse, 64
Exit Sub
End If
Wend
mstrResponse = "" ' Sent response code to blank **IMPORTANT**
End Sub
Private Sub Command1_Click()
lblStatus.Caption = ""
lblStatus.Refresh
SendEmail txtEmailServer.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtCC.Text, "", "", "", txtEmailSubject.Text, txtEmailBodyOfMessage.Text
lblStatus.Caption = "Mail Sent"
lblStatus.Refresh
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Winsock1.GetData mstrResponse ' Check for incoming response *IMPORTANT*
End Sub
Here is the form:
VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-
Begin VB.Form Form2
Caption = "Form2"
ClientHeight = 6045
ClientLeft = 60
ClientTop = 345
ClientWidth = 5985
LinkTopic = "Form2"
ScaleHeight = 6045
ScaleWidth = 5985
StartUpPosition = 3 'Windows Default
Begin VB.TextBox txtCC
Height = 285
Left = 1320
TabIndex = 13
Text = "<emoreau@s2i.com>"
Top = 1560
Width = 4455
End
Begin VB.TextBox txtEmailBodyOfMessage
Height = 2445
Left = 1320
MultiLine = -1 'True
TabIndex = 11
Text = "Form2.frx":0000
Top = 2280
Width = 4455
End
Begin VB.TextBox txtEmailSubject
Height = 285
Left = 1320
TabIndex = 9
Text = "Test PSP"
Top = 1920
Width = 2655
End
Begin VB.TextBox txtToEmailAddress
Height = 285
Left = 1320
TabIndex = 7
Text = "<emoreau@s2i.com>"
Top = 1200
Width = 4455
End
Begin VB.TextBox txtFromEmailAddress
Height = 285
Left = 1320
TabIndex = 5
Text = "emoreau@s2i.com"
Top = 840
Width = 2655
End
Begin VB.TextBox txtEmailServer
Height = 285
Left = 1320
TabIndex = 4
Text = "mail.s2i.com"
Top = 120
Width = 2655
End
Begin VB.CommandButton Command2
Caption = "Quit"
Height = 495
Left = 3360
TabIndex = 1
Top = 5400
Width = 1215
End
Begin VB.CommandButton Command1
Caption = "Send"
Height = 495
Left = 2040
TabIndex = 0
Top = 5400
Width = 1215
End
Begin MSWinsockLib.Winsock Winsock1
Left = 4200
Top = 0
_ExtentX = 741
_ExtentY = 741
_Version = 327681
End
Begin VB.Label Label1
Caption = "CC (address)"
Height = 255
Index = 1
Left = 0
TabIndex = 14
Top = 1560
Width = 1335
End
Begin VB.Label Label1
Caption = "Message"
Height = 255
Index = 6
Left = 0
TabIndex = 12
Top = 2280
Width = 1335
End
Begin VB.Label Label1
Caption = "Subject"
Height = 255
Index = 5
Left = 0
TabIndex = 10
Top = 1920
Width = 1335
End
Begin VB.Label Label1
Caption = "To (address)"
Height = 255
Index = 4
Left = 0
TabIndex = 8
Top = 1200
Width = 1335
End
Begin VB.Label Label1
Caption = "From (address)"
Height = 255
Index = 3
Left = 0
TabIndex = 6
Top = 840
Width = 1215
End
Begin VB.Label lblStatus
BorderStyle = 1 'Fixed Single
Height = 375
Left = 120
TabIndex = 3
Top = 4920
Width = 5775
End
Begin VB.Label Label1
Caption = "E-Mail server"
Height = 255
Index = 0
Left = 0
TabIndex = 2
Top = 120
Width = 1215
End
End
Attribute VB_Name = "Form2"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'Description:Allows sending of e-mail (SMTP) directly from
'VB app using Winsock, WITH OUT having to buy an expensive
'on component
'//Input Requirements: Server Address (Name or IP), Senders & //Recipeient's Names, Sender & Recipient E-Mail address, Body of //message
Private mstrResponse As String
Private Sub SendEmail(ByVal pstrMailServerName As String, _
ByVal pstrFromEmailAddress As String, _
ByVal pstrToEmailAddress1 As String, _
ByVal pstrToEmailAddress2 As String, _
ByVal pstrToEmailAddress3 As String, _
ByVal pstrToEmailAddress4 As String, _
ByVal pstrToEmailAddress5 As String, _
ByVal pstrEmailSubject As String, _
ByVal pstrEmailBodyOfMessage As String)
Dim strDateNow As String
Dim strFirst As String
Dim strThird As String
Dim strFourth As String
Dim strFifth As String
Dim strSixth As String
Dim strSeventh As String
Dim strEighth As String
Dim strNinth As String
Winsock1.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail per program start
strDateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0500"
strFirst = "mail from:" + Chr(32) + pstrFromEmailAddress + vbCrLf ' Get who's sending E-Mail address
strThird = "Date:" + Chr(32) + strDateNow + vbCrLf ' Date when being sent
strFourth = "From:" + Chr(32) + pstrFromEmailAddress + vbCrLf ' Who's Sending
strFifth = "To:" + Chr(32) + _
IIf(Len(pstrToEmailAddress
IIf(Len(pstrToEmailAddress
IIf(Len(pstrToEmailAddress
IIf(Len(pstrToEmailAddress
IIf(Len(pstrToEmailAddress
vbCrLf ' Who it going to
strSixth = "Subject:" + Chr(32) + pstrEmailSubject + vbCrLf ' Subject of E-Mail
strSeventh = pstrEmailBodyOfMessage + vbCrLf ' E-mail message body
strNinth = "X-Mailer: EBT Reporter v 2.x" + vbCrLf ' What program sent the e-mail, customize this
strEighth = strFourth + strThird + strNinth + strFifth + strSixth ' Combine for proper SMTP sending
With Winsock1
If .State = sckClosed Then ' Check to see if socet is closed
.Protocol = sckTCPProtocol ' Set protocol for sending
.RemoteHost = pstrMailServerName ' Set the server address
.RemotePort = 25 ' Set the SMTP Port
.Connect ' Start connection
WaitFor ("220")
lblStatus.Caption = "Connecting...."
lblStatus.Refresh
.SendData ("HELO worldcomputers.com" + vbCrLf)
WaitFor ("250")
lblStatus.Caption = "Connected"
lblStatus.Refresh
.SendData (strFirst)
lblStatus.Caption = "Sending Message"
lblStatus.Refresh
WaitFor ("250")
' .SendData (strEmailTo1)
' WaitFor ("250")
If Len(pstrToEmailAddress1) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress1 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress2) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress2 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress3) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress3 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress4) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress4 + vbCrLf)
WaitFor ("250")
End If
If Len(pstrToEmailAddress5) > 0 Then
.SendData ("rcpt to:" + Chr(32) + pstrToEmailAddress5 + vbCrLf)
WaitFor ("250")
End If
.SendData ("data" + vbCrLf)
WaitFor ("354")
.SendData (strEighth + vbCrLf)
.SendData (strSeventh + vbCrLf)
.SendData ("." + vbCrLf)
WaitFor ("250")
.SendData ("quit" + vbCrLf)
lblStatus.Caption = "Disconnecting"
lblStatus.Refresh
WaitFor ("221")
.Close
Else
MsgBox (Str(.State))
End If
End With
End Sub
Sub WaitFor(strResponseCode As String)
Dim sngStart As Single
Dim sngTmr As Single
sngStart = Timer ' Time event so won't get stuck in loop
While Len(mstrResponse) = 0
sngTmr = sngStart - Timer
DoEvents ' Let System keep checking for incoming response **IMPORTANT**
If sngTmr > 50 Then ' Time in seconds to wait
MsgBox "SMTP service error, timed out while waiting for response", 64
Exit Sub
End If
Wend
sngStart = Timer ' Time event so won't get stuck in loop
While Left$(mstrResponse, 3) <> strResponseCode
sngTmr = Timer - sngStart
DoEvents
If sngTmr > 50 Then
MsgBox "SMTP service error, impromper response code. Code should have been: " + strResponseCode + " Code recieved: " + mstrResponse, 64
Exit Sub
End If
Wend
mstrResponse = "" ' Sent response code to blank **IMPORTANT**
End Sub
Private Sub Command1_Click()
lblStatus.Caption = ""
lblStatus.Refresh
SendEmail txtEmailServer.Text, txtFromEmailAddress.Text, txtToEmailAddress.Text, txtCC.Text, "", "", "", txtEmailSubject.Text, txtEmailBodyOfMessage.Text
lblStatus.Caption = "Mail Sent"
lblStatus.Refresh
End Sub
Private Sub Command2_Click()
End
End Sub
Private Sub Winsock1_DataArrival(ByVal
Winsock1.GetData mstrResponse ' Check for incoming response *IMPORTANT*
End Sub
ASKER
Thanks a million Waty
ASKER