title: VB 6 failed send to email server
body: <p>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.</p>
  
  <p>Here's the code</p>
  
  <pre><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 = &amp;H1
  Const OFN_OVERWRITEPROMPT = &amp;H2
  Const OFN_HIDEREADONLY = &amp;H4
  Const OFN_NOCHANGEDIR = &amp;H8
  Const OFN_SHOWHELP = &amp;H10
  Const OFN_ENABLEHOOK = &amp;H20
  Const OFN_ENABLETEMPLATE = &amp;H40
  Const OFN_ENABLETEMPLATEHANDLE = &amp;H80
  Const OFN_NOVALIDATE = &amp;H100
  Const OFN_ALLOWMULTISELECT = &amp;H200
  Const OFN_EXTENSIONDIFFERENT = &amp;H400
  Const OFN_PATHMUSTEXIST = &amp;H800
  Const OFN_FILEMUSTEXIST = &amp;H1000
  Const OFN_CREATEPROMPT = &amp;H2000
  Const OFN_SHAREAWARE = &amp;H4000
  Const OFN_NOREADONLYRETURN = &amp;H8000
  Const OFN_NOTESTFILECREATE = &amp;H10000
  Const OFN_NONETWORKBUTTON = &amp;H20000
  Const OFN_NOLONGNAMES = &amp;H40000
  Const OFN_EXPLORER = &amp;H80000
  Const OFN_NODEREFERENCELINKS = &amp;H100000
  Const OFN_LONGNAMES = &amp;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 = &amp;H400&amp;
  Const MF_REMOVE = &amp;H1000&amp;
  
  
  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 &amp; " (" &amp; fSize &amp; " 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 &gt; 0 Then
  
  Bytes = recv(Sock, ByVal MsgBuffer, 2048, 0)
  If Bytes &gt; 0 Then
  ServerResponse = Mid$(MsgBuffer, 1, Bytes)
  
  DataArrival = DataArrival &amp; ServerResponse &amp; 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() &lt;&gt; 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 &amp; 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) &lt;&gt; "|" Then Filter = Filter &amp; "|"
  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 &amp; "--NextMimePart" &amp; vbCrLf
  temp = temp &amp; "Content-Type: application/octet-stream; name=Mimefilename" &amp; vbCrLf
  temp = temp &amp; "Content-Transfer-Encoding: base64" &amp; vbCrLf
  temp = temp &amp; "Content-Disposition: attachment; filename=" &amp; Chr$(34) &amp; Mimefilename &amp; Chr$(34) &amp; vbCrLf
  
  WinsockSendData (temp &amp; vbCrLf)
  
  
  Open path For Binary Access Read As FileIn
  If GetSetting(App.Title, "Settings", "Too big", "") &lt;&gt; "True" Then
  If LOF(FileIn) &gt; 2097152 Then
  fSize = Int((LOF(FileIn) / 1048576) * 100 + 0.5) / 100
  Setu = MsgBox("The current file is " &amp; fSize &amp; " 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 """ &amp; AttachmentList.List(IAT) &amp; """"
  Do While Not EOF(FileIn)
  If LOF(FileIn) = 0 Then GoTo Anoth
  Get FileIn, , strFile1
  strFile = strFile &amp; 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)) &amp; "%"
  
  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 &gt;= 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)) &amp; "%"
  
  Process = "Sending " &amp; Mimefilename &amp; "... " &amp; I + Len(ss) &amp; " Bytes from " &amp; Len(s)
  DoEvents
  Next I
  
  
  Anoth:
  s = ""
  Next IAT
  WinsockSendData (vbCrLf &amp; "--NextMimePart--" &amp; vbCrLf)
  WinsockSendData (vbCrLf &amp; "." &amp; 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 " &amp; MailServer &amp; GetWSAErrorString(WSAGetLastError())
  closesocket Sock
  Call EndWinsock
  Exit Sub
  End If
  
  Process = "Connected to " &amp; 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: " &amp; txtFrom &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "To: " &amp; txtTo &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "Date: " &amp; Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "Subject: " &amp; txtSubjekt &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "X-Mailer: " &amp; App.CompanyName &amp; " - " &amp; App.Title &amp; vbCrLf
  
  
  strDataToSend = strDataToSend &amp; "Mime-Version: 1.0" &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "Content-Type: multipart/mixed; boundary=NextMimePart" &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "Content-Transfer-Encoding: 7bit" &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "This is a multi-part message in MIME format." &amp; vbCrLf &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "--NextMimePart" &amp; vbCrLf &amp; vbCrLf
  
  
  strDataToSend = strDataToSend &amp; Trim$(Mailtxt)
  
  
  strDataToSend = Replace$(strDataToSend, vbCrLf &amp; "." &amp; vbCrLf, vbCrLf &amp; "." &amp; Chr$(0) &amp; 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)) &amp; "%"
  If Cancelflag Then Exit For
  Process = "Sending message body... " &amp; I + Len(strToSend) &amp; " Bytes from " &amp; Len(strDataToSend)
  DoEvents
  Next I
  
  
  SendMimeAttachment
  
  Else
  
  strDataToSend = "From: " &amp; txtFrom &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "To: " &amp; txtTo &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "Date: " &amp; Format$(Now, "DDDD , dd Mmm YYYY hh:mm:ss AM/PM") &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "Subject: " &amp; txtSubjekt &amp; vbCrLf
  strDataToSend = strDataToSend &amp; "X-Mailer: " &amp; App.CompanyName &amp; " - " &amp; App.Title &amp; vbCrLf &amp; vbCrLf
  strDataToSend = strDataToSend &amp; Trim$(txtMail)
  
  
  strDataToSend = Replace$(strDataToSend, vbCrLf &amp; "." &amp; vbCrLf, vbCrLf &amp; "." &amp; Chr$(0) &amp; 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)) &amp; "%"
  If Cancelflag Then Exit For
  Process = "Sending message body... " &amp; I + Len(strToSend) &amp; " Bytes from " &amp; Len(strDataToSend)
  DoEvents
  Next I
  
  
  WinsockSendData (vbCrLf &amp; "." &amp; vbCrLf)
  End If
  
  End Sub
  
  Sub Startrek()
  
  On Error Resume Next
  Dim Rate As Integer
  Dim Rate2 As Integer
  If WindowState &lt;&gt; 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 &lt;= 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 " &amp; Helo &amp; vbCrLf)
  
  Call WaitForResponse
  
  Case 2
  
  ResponseCode = 250
  WinsockSendData ("MAIL FROM: &lt;" &amp; Trim$(Frombox) &amp; "&gt;" &amp; vbCrLf)
  
  Call WaitForResponse
  
  Case 3
  
  ResponseCode = 250
  WinsockSendData ("RCPT TO: &lt;" &amp; Trim$(arrRecipients(CurrentE)) &amp; "&gt;" &amp; vbCrLf)
  
  Call WaitForResponse
  
  Case 4
  
  ResponseCode = 354
  WinsockSendData ("DATA" &amp; vbCrLf)
  
  Call WaitForResponse
  
  Case 5
  
  
  ResponseCode = 250
  Call SendMimetxt(Frombox, Trim$(arrRecipients(CurrentE)), Subjekt, Mailtxt)
  
  Call WaitForResponse
  
  
  Case 6
  
  ResponseCode = 221
  WinsockSendData ("QUIT" &amp; vbCrLf)
  Call WaitForResponse
  
  Process = "Email has been sent!"
  frm2.Width = 3300
  lblpcent = "100%"
  
  DataArrival = ""
  
  m_iStage = 0
  If arrRecipients(CurrentE + 1) &lt;&gt; "" 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 &gt; 0
  Tmr = timeGetTime - Start
  
  DoEvents '
  
  
  If Tmr &gt; 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." &amp; Str$(WSAGetLastError()) &amp; _
  GetWSAErrorString(WSAGetLastError())
  closesocket Sock
  Call EndWinsock
  Exit Sub
  End If
  
  End Sub
  </code></pre>