我正在尝试编写一个程序，该程序将在VB6中发送带附件的电子邮件。我使用winsock和smtp.gmail.com作为我的邮件服务器，但它不起作用。无法连接到邮件服务器。代码工作正常。我唯一的问题是当我尝试发送消息时它没有连接请事先帮助我。
这是代码
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
答案 0 :(得分：0)
我没有费心阅读你的代码。太难。这是如何轻松完成的。
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"
以下是如何使用高级对象从Internet获取文件。您必须使用http：//的确切名称，因为没有帮助不正确的地址。
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
对于二进制文件，也使用ado流。要在内存中创建数据库，请使用adodb记录集（优于字典，数组或集合），使排序成为一行命令。