VB 6 failed send to email server

Question

I am trying to write a program that will send email with an attachment in VB6. I'm using winsock and smtp.gmail.com as my mail server but it doesn't work. Failed to connect to mail server.The code works fine. My only problem is when I try to send message it doesn't connect please help me thanks in advance.

Here's the code

Dim objBase64 As New Base64

Dim bTrans As Boolean
Dim m_iStage As Integer
Dim Sock As Integer
Dim RC As Integer
Dim Bytes As Integer
Dim ResponseCode As Integer
Dim path As String


Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Const OFN_READONLY = &H1
Const OFN_OVERWRITEPROMPT = &H2
Const OFN_HIDEREADONLY = &H4
Const OFN_NOCHANGEDIR = &H8
Const OFN_SHOWHELP = &H10
Const OFN_ENABLEHOOK = &H20
Const OFN_ENABLETEMPLATE = &H40
Const OFN_ENABLETEMPLATEHANDLE = &H80
Const OFN_NOVALIDATE = &H100
Const OFN_ALLOWMULTISELECT = &H200
Const OFN_EXTENSIONDIFFERENT = &H400
Const OFN_PATHMUSTEXIST = &H800
Const OFN_FILEMUSTEXIST = &H1000
Const OFN_CREATEPROMPT = &H2000
Const OFN_SHAREAWARE = &H4000
Const OFN_NOREADONLYRETURN = &H8000
Const OFN_NOTESTFILECREATE = &H10000
Const OFN_NONETWORKBUTTON = &H20000
Const OFN_NOLONGNAMES = &H40000
Const OFN_EXPLORER = &H80000
Const OFN_NODEREFERENCELINKS = &H100000
Const OFN_LONGNAMES = &H200000
Const OFN_SHAREFALLTHROUGH = 2
Const OFN_SHARENOWARN = 1
Const OFN_SHAREWARN = 0

Private Declare Function GetSaveFileName Lib "comdlg32" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As Long


Private Declare Function timeGetTime Lib "winmm.dll" () As Long



Private Declare Function GetSystemMenu Lib "user32" (ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hWnd As Long) As Long

Const MF_BYPOSITION = &H400&
Const MF_REMOVE = &H1000&


Dim Mime As Boolean

Dim arrRecipients As Variant
Dim CurrentE As Integer


Private Sub Attachment_Click()

path = SaveDialog(Me, "*.*", "Attach File", App.path)
If path = "" Then Exit Sub
AttachmentList.AddItem path
Mime = True
AttachmentList.ListIndex = AttachmentList.ListCount - 1

End Sub

Private Sub AttachmentList_Click()

fSize = Int((FileLen(AttachmentList) / 1024) * 100 + 0.5) / 100
AttachmentList.ToolTipText = AttachmentList & " (" & fSize & " KB)"

End Sub

Private Sub AttachmentList_OLEDragDrop(Data As DataObject, Effect As Long, Button As Integer, Shift As Integer, X As Single, Y As Single)

For I = 1 To Data.Files.Count
If (GetAttr(Data.Files.Item(I)) And vbDirectory) = 0 Then AttachmentList.AddItem Data.Files.Item(I): Mime = True: AttachmentList.ListIndex = AttachmentList.ListCount - 1
Next I

End Sub

Private Sub DataArrival_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

Dim MsgBuffer As String * 2048

On Error Resume Next


If Sock > 0 Then

Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)
If Bytes > 0 Then
ServerResponse = Mid$(MsgBuffer, 1, Bytes)

DataArrival = DataArrival & ServerResponse & vbCrLf


DataArrival.SelStart = Len(DataArrival)

If bTrans Then

If ResponseCode = Left$(MsgBuffer, 3) Then
m_iStage = m_iStage + 1
Transmit m_iStage
Else

closesocket (Sock)
Call EndWinsock
Sock = 0
Process = "The Server responds with an unexpected Response Code!"
Exit Sub
End If
End If

ElseIf WSAGetLastError() <> WSAEWOULDBLOCK Then
closesocket (Sock)
Call EndWinsock
Sock = 0
End If
End If
Refresh

End Sub

Private Sub delattach_Click()

If AttachmentList.ListCount = 0 Or AttachmentList.ListIndex = -1 Then Exit Sub

tmpIndex = AttachmentList.ListIndex
AttachmentList.RemoveItem (AttachmentList.ListIndex)

If AttachmentList.ListCount = 0 Then Mime = False: Attachment.ToolTipText = "Drag & Drop your attachments here" Else If AttachmentList.ListIndex = 0 Then AttachmentList.ListIndex = tmpIndex Else AttachmentList.ListIndex = tmpIndex - 1

End Sub

Sub DisableX(frm As Form)

Dim hMenu As Long
Dim nCount As Long

hMenu = GetSystemMenu(frm.hWnd, 0)
nCount = GetMenuItemCount(hMenu)

Call RemoveMenu(hMenu, nCount - 1, MF_REMOVE Or MF_BYPOSITION)
Call RemoveMenu(hMenu, nCount - 2, MF_REMOVE Or MF_BYPOSITION)

DrawMenuBar frm.hWnd

End Sub

Private Sub Exit_Click()

On Error Resume Next
Call Startrek

closesocket Sock
Call EndWinsock
End

End Sub

Private Sub Form_Load()

Call DisableX(Me)

End Sub

Function IsConnected2Internet() As Boolean

On Error Resume Next


If MyIP = "127.0.0.1" Or MyIP = "" Then IsConnected2Internet = False Else IsConnected2Internet = True

End Function

Function SaveDialog(Form1 As Form, Filter As String, Title As String, InitDir As String) As String

Dim ofn As OPENFILENAME
Dim A As Long

ofn.lStructSize = Len(ofn)
ofn.hwndOwner = Form1.hWnd
ofn.hInstance = App.hInstance
If Right$(Filter, 1) <> "|" Then Filter = Filter & "|"
For A = 1 To Len(Filter)
If Mid$(Filter, A, 1) = "|" Then Mid$(Filter, A, 1) = Chr$(0)
Next A
ofn.lpstrFilter = Filter
ofn.lpstrFile = Space$(254)
ofn.nMaxFile = 255
ofn.lpstrFileTitle = Space$(254)
ofn.nMaxFileTitle = 255
ofn.lpstrInitialDir = InitDir
ofn.lpstrTitle = Title
ofn.flags = OFN_HIDEREADONLY Or OFN_CREATEPROMPT
A = GetSaveFileName(ofn)
If (A) Then
SaveDialog = Left$(Trim$(ofn.lpstrFile), Len(Trim$(ofn.lpstrFile)) - 1)
Else
SaveDialog = ""
End If

End Function


Private Sub SendMimeAttachment()

Dim FileIn As Long
Dim temp As Variant
Dim s As Variant

Dim TempArray() As Byte
Dim Encoded() As Byte
Dim strFile As String
Dim strFile1 As String * 32768

For IAT = 0 To AttachmentList.ListCount - 1
path = AttachmentList.List(IAT)

Mimefilename = Trim$(Right$(path, Len(path) - InStrRev(path, "\")))


FileIn = FreeFile

r
temp = vbCrLf & "--NextMimePart" & vbCrLf
temp = temp & "Content-Type: application/octet-stream; name=Mimefilename" & vbCrLf
temp = temp & "Content-Transfer-Encoding: base64" & vbCrLf
temp = temp & "Content-Disposition: attachment; filename=" & Chr$(34) & Mimefilename & Chr$(34) & vbCrLf

WinsockSendData (temp & vbCrLf)


Open path For Binary Access Read As FileIn
If GetSetting(App.Title, "Settings", "Too big", "") <> "True" Then
If LOF(FileIn) > 2097152 Then
fSize = Int((LOF(FileIn) / 1048576) * 100 + 0.5) / 100
Setu = MsgBox("The current file is " & fSize & " MB of size, extracting from it could take a few minutes, Click Yes to go ahead, No to skip it or Cancel if you don't want to get this message again", vbYesNoCancel)
If Setu = vbYes Then GoTo Cont
If Setu = vbNo Then Close (FileIn): GoTo Anoth Else SaveSetting App.Title, "Settings", "Too big", "True"
End If
End If

Cont:

frm2.Visible = True
Process = "Loading """ & AttachmentList.List(IAT) & """"
Do While Not EOF(FileIn)
If LOF(FileIn) = 0 Then GoTo Anoth
Get FileIn, , strFile1
strFile = strFile & Mid$(strFile1, 1, Len(strFile1) - (Loc(FileIn) - LOF(FileIn)))
strFile1 = ""
DoEvents

frm2.Width = (3300 / 100) * (Len(strFile) * 50 / LOF(FileIn))
lblpcent = Int(Len(strFile) * 50 / LOF(FileIn)) & "%"

If Cancelflag Then Close FileIn: Exit Sub
Loop
Close FileIn

If strFile = "" Then Exit Sub

objBase64.Str2ByteArray strFile, TempArray
objBase64.EncodeB64 TempArray, Encoded
objBase64.Span 76, Encoded, TempArray

strFile = ""

s = StrConv(TempArray, vbUnicode)

For I = 1 To Len(s) Step 8192
ss = Trim$(Mid$(s, I, 8192))

tmpServerSpeed = 150
Start = timeGetTime
Do
DoEvents
Loop Until timeGetTime >= Start + tmpServerSpeed * 20

WinsockSendData (ss)

frm2.Width = 1650 + (3300 / 100) * ((I + Len(ss)) * 50 / Len(s))
lblpcent = 50 + Int((I + Len(ss)) * 50 / Len(s)) & "%"

Process = "Sending " & Mimefilename & "... " & I + Len(ss) & " Bytes from " & Len(s)
DoEvents
Next I


Anoth:
s = ""
Next IAT
WinsockSendData (vbCrLf & "--NextMimePart--" & vbCrLf)
WinsockSendData (vbCrLf & "." & vbCrLf)

End Sub


Private Sub SendMimeConnect_Click()



If Tobox = "" Or InStr(Tobox, "@") = 0 Then
MsgBox "To: Is not correct!"
Exit Sub
End If


If IsConnected = False Then
If MsgBox("No Internet connection has been detected, check for Update anyway?", vbYesNo) = vbNo Then Exit Sub
End If

Sock = ConnectSock(MailServer, 25, DataArrival.hWnd)


If Sock = SOCKET_ERROR Then
Process = "Cannot Connect to " & MailServer & GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If

Process = "Connected to " & MailServer

bTrans = True
m_iStage = 0
DataArrival = ""

ResponseCode = 220
Call WaitForResponse

End Sub


Sub SendMimetxt(txtFrom, txtTo, txtSubjekt, txtMail)

Dim strToSend As String
Dim strDataToSend As String

If Mime Then

strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf


strDataToSend = strDataToSend & "Mime-Version: 1.0" & vbCrLf
strDataToSend = strDataToSend & "Content-Type: multipart/mixed; boundary=NextMimePart" & vbCrLf
strDataToSend = strDataToSend & "Content-Transfer-Encoding: 7bit" & vbCrLf
strDataToSend = strDataToSend & "This is a multi-part message in MIME format." & vbCrLf & vbCrLf
strDataToSend = strDataToSend & "--NextMimePart" & vbCrLf & vbCrLf


strDataToSend = strDataToSend & Trim$(Mailtxt)


strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)


For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)

frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I


SendMimeAttachment

Else

strDataToSend = "From: " & txtFrom & vbCrLf
strDataToSend = strDataToSend & "To: " & txtTo & vbCrLf
strDataToSend = strDataToSend & "Date: " & Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") & vbCrLf
strDataToSend = strDataToSend & "Subject: " & txtSubjekt & vbCrLf
strDataToSend = strDataToSend & "X-Mailer: " & App.CompanyName & " - " & App.Title & vbCrLf & vbCrLf
strDataToSend = strDataToSend & Trim$(txtMail)


strDataToSend = Replace$(strDataToSend, vbCrLf & "." & vbCrLf, vbCrLf & "." & Chr$(0) & vbCrLf)


For I = 1 To Len(strDataToSend) Step 8192
strToSend = Trim$(Mid$(strDataToSend, I, 8192))
WinsockSendData (strToSend)

frm2.Width = (2400 / 100) * ((I + Len(strToSend)) * 100 / Len(strDataToSend))
lblpcent = Int((I + Len(strToSend)) * 100 / Len(strDataToSend)) & "%"
If Cancelflag Then Exit For
Process = "Sending message body... " & I + Len(strToSend) & " Bytes from " & Len(strDataToSend)
DoEvents
Next I


WinsockSendData (vbCrLf & "." & vbCrLf)
End If

End Sub

Sub Startrek()

On Error Resume Next
Dim Rate As Integer
Dim Rate2 As Integer
If WindowState <> 0 Then Exit Sub
Caption = "End Transmission"
GotoVal = (Height / 12)
Rate = 50
For Gointo = 1 To GotoVal
Spd = Timer
Rate2 = Rate / 2
Height = Height - Rate
Top = Top + Rate2
DoEvents
Width = Width - Rate
Left = Left + Rate2
DoEvents
If Width <= 2000 Then Exit For
Rate = (Timer - Spd) * 10000
Next Gointo
WindowState = 1

End Sub

Private Sub Tobox_Change()

arrRecipients = Split(Tobox, ",")

End Sub


Private Sub Transmit(iStage As Integer)

Dim Helo As String
Dim pos As Integer

Select Case m_iStage

Case 1

Helo = Frombox
pos = Len(Helo) - InStr(Helo, "@")
Helo = Right$(Helo, pos)

ResponseCode = 250
WinsockSendData ("HELO " & Helo & vbCrLf)

Call WaitForResponse

Case 2

ResponseCode = 250
WinsockSendData ("MAIL FROM: <" & Trim$(Frombox) & ">" & vbCrLf)

Call WaitForResponse

Case 3

ResponseCode = 250
WinsockSendData ("RCPT TO: <" & Trim$(arrRecipients(CurrentE)) & ">" & vbCrLf)

Call WaitForResponse

Case 4

ResponseCode = 354
WinsockSendData ("DATA" & vbCrLf)

Call WaitForResponse

Case 5


ResponseCode = 250
Call SendMimetxt(Frombox, Trim$(arrRecipients(CurrentE)), Subjekt, Mailtxt)

Call WaitForResponse


Case 6

ResponseCode = 221
WinsockSendData ("QUIT" & vbCrLf)
Call WaitForResponse

Process = "Email has been sent!"
frm2.Width = 3300
lblpcent = "100%"

DataArrival = ""

m_iStage = 0
If arrRecipients(CurrentE + 1) <> "" Then
CurrentE = CurrentE + 1
SendMimeConnect_Click
Else
bTrans = False
CurrentE = 0
End If
End Select

End Sub


Private Sub WaitForResponse()

Dim Start As Long
Dim Tmr As Long



Start = timeGetTime
While Bytes > 0
Tmr = timeGetTime - Start

DoEvents '


If Tmr > 20000 Then
Process = "SMTP service error, timed out while waiting for response"

End If
Wend

End Sub

Private Sub WinsockSendData(DatatoSend As String)

Dim RC As Integer
Dim MsgBuffer As String * 8192

MsgBuffer = DatatoSend


RC = send(Sock, ByVal MsgBuffer, Len(DatatoSend), 0)

If RC = SOCKET_ERROR Then
Process = "Cannot Send Request." & Str$(WSAGetLastError()) & _
GetWSAErrorString(WSAGetLastError())
closesocket Sock
Call EndWinsock
Exit Sub
End If

End Sub

Answer 1

I didn't bother to read your code. Too hard. Here's how to do it easily.

Set emailObj      = CreateObject("CDO.Message")
emailObj.From     = "dc@gail.com"

emailObj.To       = "dc@gail.com"

emailObj.Subject  = "Test CDO"
emailObj.TextBody = "Test CDO"

emailObj.AddAttachment "c:\windows\win.ini"

Set emailConfig = emailObj.Configuration
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing")    = 2  
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1  
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl")      = true 
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername")    = "YourUserName"
emailConfig.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword")    = "Password1"
emailConfig.Fields.Update

emailObj.Send

If err.number = 0 then Msgbox "Done"

Here's how to get files from internet with a high level object. You must use the exact name with http:// as there no helper for incorrect addresses.

Set File = WScript.CreateObject("Microsoft.XMLHTTP")
File.Open "GET", "http://www.microsoft.com", False
File.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 6.0; Trident/4.0; SLCC1; .NET CLR 2.0.50727; Media Center PC 5.0; .NET CLR 1.1.4322; .NET CLR 3.5.30729; .NET CLR 3.0.30618; .NET4.0C; .NET4.0E; BCD2000; BCD2000)"
File.Send
txt=File.ResponseText

Also for binary files use ado stream. To create a database in memory use adodb recordset (better than a dictionary, array, or a collection), makes sorting a one line command.