Emailing through VB

[xstopx81]

I have used emailing codes for VB and whenver i try to send emails, outlook gives me this error statement:

"No transport provider was available for delivery to this recipient."

I do not know how to fix this problem and it would be very helpful if someone can show me why I'm getting this error.
Additionally, I was wondering if anyone knows how to send emails directly, because most of the codes for emailing I think only puts the letters in the outbox of outlook


[Edited by xstopx81 on 07-28-2000 at 07:11 PM]

[msdnexpert]

Hi xstopx81,
This is the code for a mailing Activex component. Create a new ActiveX DLL project. Paste the code below in the Class module.Add a reference to MSWinsockLib. Compile the code. To send a mail call the function PleaseSendEmail with the requisite parameters. This mailing component allows you to send one attachment with the mail. However you need to specify the IP address of your mail server as the first parameter of the function PleaseSendEmail.


Private WithEvents MySock As Winsock
Dim Response As String, Reply As Integer, DateNow As String
Dim First As String, Second As String, Third As String
Dim Fourth As String, Fifth As String, Sixth As String
Dim Seventh As String, Eighth As String
Dim Start As Single, Tmr As Single
Dim EncodeStr As String


Public Function PleaseSendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String, strAttachFile As String) As Integer
If SendEmail(MailServerName, FromName, FromEmailAddress, ToName, ToEmailAddress, EmailSubject, EmailBodyOfMessage, strAttachFile) Then
PleaseSendEmail = 1
Else
PleaseSendEmail = 0
End If
End Function

Private Sub Class_Initialize()
Set MySock = New Winsock
End Sub

Private Sub Class_Terminate()
Set MySock = Nothing
End Sub

Function SendEmail(MailServerName As String, FromName As String, FromEmailAddress As String, ToName As String, ToEmailAddress As String, EmailSubject As String, EmailBodyOfMessage As String, strAttachFile As String) As Boolean
SendEmail = True
MySock.LocalPort = 0 ' Must set local port to 0 (Zero) or you can only send 1 e-mail pre program start
If MySock.State = sckClosed Then ' Check to see if socet is closed
DateNow = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"

MySock.Protocol = sckTCPProtocol ' Set protocol for sending
MySock.RemoteHost = MailServerName ' Set the server address
MySock.RemotePort = 25 ' Set the SMTP Port
MySock.Connect ' Start connection

'Establish a connection
If Not WaitFor("220") Then
SendEmail = False
Exit Function
End If

'Say Hello to the SMTP server
MySock.SendData ("HELO" + vbCrLf)
If Not WaitFor("250") Then
SendEmail = False
Exit Function
End If

'Send from address
MySock.SendData ("MAIL FROM:" + Chr(32) + FromEmailAddress + vbCrLf)
If Not WaitFor("250") Then
SendEmail = False
Exit Function
End If

'Send to address
MySock.SendData ("RCPT TO:" + Chr(32) + ToEmailAddress + vbCrLf)
If Not WaitFor("250") Then
SendEmail = False
Exit Function
End If

'Indicate that data is being sent
MySock.SendData ("DATA" + vbCrLf)
If Not WaitFor("354") Then
SendEmail = False
Exit Function
End If

'Start sending the data

MySock.SendData "MIME-Version: 1.0" & vbCrLf
MySock.SendData ("FROM:" + Chr(32) + FromName + " < " + FromEmailAddress + " > " + vbCrLf)
'mysock.SendData ("Boshu E-Mailer version 1.0x" + vbCrLf)
MySock.SendData ("TO:" & ToEmailAddress & vbCrLf)
MySock.SendData ("SUBJECT:" & EmailSubject & vbCrLf)
MySock.SendData ("DATE:" & DateNow & vbCrLf)

MySock.SendData ("Content-Type: Multipart/Mixed;" & vbCrLf)
MySock.SendData (" boundary=Unique-Boundary" & vbCrLf & vbCrLf)

MySock.SendData ("This is a multi-part message in MIME format." & vbCrLf)
MySock.SendData ("--Unique-Boundary" & vbCrLf)

MySock.SendData ("Content-Type: Text/Plain; charset=US-ASCII" & vbCrLf & vbCrLf)

'Send the email message body
MySock.SendData (EmailBodyOfMessage & vbCrLf & vbCrLf)

If strAttachFile <> "" Then
SendAttachment (strAttachFile)
End If

MySock.SendData "--Unique-Boundary--"

MySock.SendData (vbCrLf + "." + vbCrLf)

If Not WaitFor("250") Then
SendEmail = False
Exit Function
End If

'Finish sending data
MySock.SendData ("QUIT" + vbCrLf)

If Not WaitFor("221") Then
SendEmail = False
Exit Function
End If


MySock.Close
Else
MsgBox (Str(MySock.State))
End If

End Function

Sub SendAttachment(strAttachName As String)
Base64EncodeFile (strAttachName)
For intCount = Len(strAttachName) To 1 Step -1

If Mid(strAttachName, intCount, 1) = "\" Then
strAttachName = Mid(strAttachName, intCount + 1)
GoTo lala
End If

Next intCount
lala:
MySock.SendData "--Unique-Boundary" & vbCrLf

MySock.SendData "Content-Type: Application/Octet-Stream; Charset=ISO-8859-1; Name=" + """" & strAttachName + """" & vbCrLf
MySock.SendData "Content-Transfer-Encoding: base64" & vbCrLf & vbCrLf

MySock.SendData EncodeStr & vbCrLf & vbCrLf

End Sub

Function WaitFor(ResponseCode As String) As Boolean
WaitFor = True
Start = Timer ' Time event so won't get stuck in loop
While Len(Response) = 0
Tmr = Timer - Start
DoEvents ' Let System keep checking for incoming response **IMPORTANT**
If Tmr > 50 Then ' Time in seconds to wait
MsgBox "SMTP service error, timed out while waiting for response", 64, MsgTitle
WaitFor = False
Exit Function
End If
Wend

'Check if proper response code has been received
While Left(Response, 3) <> ResponseCode
DoEvents
If Tmr > 50 Then
MsgBox "SMTP service error, improper response code. Code should have been: " + ResponseCode + " Code recieved: " + Response, 64, MsgTitle
WaitFor = False
Exit Function
End If
Wend
Response = "" ' Sent response code to blank **IMPORTANT**
End Function

Private Sub MySock_DataArrival(ByVal bytesTotal As Long)
MySock.GetData Response ' Check for incoming response *IMPORTANT*
End Sub

' Base64Encode(strOriginal)
' Base64Encode("the") would return "dGjl"
' You can only pass three letters as the arguement

Public Function Base64Encode(strOriginal As String)
Dim intCount As Integer
Dim strBinary As String
Dim intDecimal As Integer
Dim strTemp As String

intDecimal = Asc(Left$(strOriginal, 1))

For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next

If Len(strOriginal) < 3 Then GoTo unfpassone

intDecimal = Asc(Mid$(strOriginal, 2, 1))

For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next

If Len(strOriginal) < 3 Then GoTo unfpassone

intDecimal = Asc(Right$(strOriginal, 1))

For intCount = 7 To 0 Step -1
If (2 ^ intCount) <= intDecimal Then
strBinary = strBinary & "1"
intDecimal = intDecimal - (2 ^ intCount)
Else
strBinary = strBinary & "0"
End If
Next

unfpassone:
For intCount = 1 To 19 Step 6
Select Case Val(Mid$(strBinary, intCount, 6))
Case 0
strTemp = strTemp & "A"
Case 1
strTemp = strTemp & "B"
Case 10
strTemp = strTemp & "C"
Case 11
strTemp = strTemp & "D"
Case 100
strTemp = strTemp & "E"
Case 101
strTemp = strTemp & "F"
Case 110
strTemp = strTemp & "G"
Case 111
strTemp = strTemp & "H"
Case 1000
strTemp = strTemp & "I"
Case 1001
strTemp = strTemp & "J"
Case 1010
strTemp = strTemp & "K"
Case 1011
strTemp = strTemp & "L"
Case 1100
strTemp = strTemp & "M"
Case 1101
strTemp = strTemp & "N"
Case 1110
strTemp = strTemp & "O"
Case 1111
strTemp = strTemp & "P"
Case 10000
strTemp = strTemp & "Q"
Case 10001
strTemp = strTemp & "R"
Case 10010
strTemp = strTemp & "S"
Case 10011
strTemp = strTemp & "T"
Case 10100
strTemp = strTemp & "U"
Case 10101
strTemp = strTemp & "V"
Case 10110
strTemp = strTemp & "W"
Case 10111
strTemp = strTemp & "X"
Case 11000
strTemp = strTemp & "Y"
Case 11001
strTemp = strTemp & "Z"
Case 11010
strTemp = strTemp & "a"
Case 11011
strTemp = strTemp & "b"
Case 11100
strTemp = strTemp & "c"
Case 11101
strTemp = strTemp & "d"
Case 11110
strTemp = strTemp & "e"
Case 11111
strTemp = strTemp & "f"
Case 100000
strTemp = strTemp & "g"
Case 100001
strTemp = strTemp & "h"
Case 100010
strTemp = strTemp & "i"
Case 100011
strTemp = strTemp & "j"
Case 100100
strTemp = strTemp & "k"
Case 100101
strTemp = strTemp & "l"
Case 100110
strTemp = strTemp & "m"
Case 100111
strTemp = strTemp & "n"
Case 101000
strTemp = strTemp & "o"
Case 101001
strTemp = strTemp & "p"
Case 101010
strTemp = strTemp & "q"
Case 101011
strTemp = strTemp & "r"
Case 101100
strTemp = strTemp & "s"
Case 101101
strTemp = strTemp & "t"
Case 101110
strTemp = strTemp & "u"
Case 101111
strTemp = strTemp & "v"
Case 110000
strTemp = strTemp & "w"
Case 110001
strTemp = strTemp & "x"
Case 110010
strTemp = strTemp & "y"
Case 110011
strTemp = strTemp & "z"
Case 110100
strTemp = strTemp & "0"
Case 110101
strTemp = strTemp & "1"
Case 110110
strTemp = strTemp & "2"
Case 110111
strTemp = strTemp & "3"
Case 111000
strTemp = strTemp & "4"
Case 111001
strTemp = strTemp & "5"
Case 111010
strTemp = strTemp & "6"
Case 111011
strTemp = strTemp & "7"
Case 111100
strTemp = strTemp & "8"
Case 111101
strTemp = strTemp & "9"
Case 111110
strTemp = strTemp & "+"
Case 111111
strTemp = strTemp & "/"
End Select
Next

Base64Encode = strTemp
End Function

' Base64EncodeFile(strFile,rtfattach,txtOutput)
' Base64EncodeFile "c:\windows\autoexec.bat",rtfBox,txtBox
' The second parameter must be a rtf box or a control that supports the
' LoadFile command

Public Sub Base64EncodeFile(strFile As String)

Dim intCount As Long
Dim strTemp As String
Dim lngMax As Long
Dim F1 As Integer
Dim FLen As Long
Dim FileText As String

F1 = FreeFile
Open strFile For Binary As F1
FLen = FileLen(strFile)
intCount = 0
lngMax = 0

While Not EOF(F1)
FileText = FileText + Input(1, F1)
Wend
Close F1

For intCount = 1 To Len(FileText) Step 3
strTemp = Mid(FileText, intCount, 3)
EncodeStr = EncodeStr & Base64Encode(strTemp)
lngMax = lngMax + 4
If lngMax = 72 Then
lngMax = 0
EncodeStr = EncodeStr & vbCrLf
End If
DoEvents
Next

End Sub