VB 6失敗發送到電子郵件服務器

Question

我想寫一個程序，將發送電子郵件與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 

Answer 1

我沒有刻意去閱讀你的代碼。太難。以下是如何輕鬆做到這一點。

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" 

以下是如何從高級對象獲取互聯網上的文件。您必須使用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記錄集（比字典，數組或集合更好），對單行命令進行排序。