'窗体代码.Option ExplicitPrivate Sub cmdAbout_Click() frmAbout.Show vbModal End SubPrivate Sub cmdClose_Click() Unload Me End SubPrivate Sub cmdSelect_Click()
cmdDialog.ShowOpen txtAttach = cmdDialog.FileName
End SubPrivate Sub cmdSend_Click()
cmdSend.Enabled = False
If ValidateEntry = False Then MsgBox "Either the server name or to address were left empty.", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub
If txtAttach.Text <> "" Then lblStatus = "Encoding file attachment" Base64EncodeFile txtAttach.Text, rtfAttach, txtOutput End If
lblStatus = "Connecting to POP Server" ConnectToServer txtServer.Text, Winsock1
End SubPrivate Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
End SubPrivate Function ValidateEntry() As Boolean
ValidateEntry = True
If txtServer.Text = "" Or txtToAddress = "" Then ValidateEntry = False
End Function'模块代码Option ExplicitPublic 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,rtfTemp,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, rtfTemp As RichTextBox, txtOutput As TextBox)
Dim intCount As Integer Dim strTemp As String Dim lngMax As Long lngMax = 0 txtOutput.Text = "" rtfTemp.LoadFile strFile
If lngMax = 72 Then lngMax = 0 txtOutput.Text = txtOutput.Text & vbCrLf End If
DoEvents Next intCount
End Sub' ConnectToServer(strServer, wsk, strSrvPort) ' ConnectToServer "pop.microsoft.com", Winsock1, 25 ' Normally leave out the last arguement and let the Winsock control use ' the default port.Public Sub ConnectToServer(strServer As String, wsk As Winsock, Optional strSrvPort As String)
wsk.RemoteHost = strServer
If strSrvPort = "" Then wsk.RemotePort = 25 Else wsk.RemotePort = Val(strSrvPort) End If
wsk.ConnectEnd Sub' ExtractArgument(ArgNum, srchstr, Delim) ' ExtractArgument(3, "No 1, No 2, No 3", ",") Would return No 3 ' I did not have time to sort out the variable names in this function, ' so if you can be bothered to, please send it to me at [email protected] Function ExtractArgument(ArgNum As Integer, srchstr As String, Delim As String) As String On Error GoTo Err_ExtractArgument
Dim ArgCount As Integer Dim LastPos As Integer Dim Pos As Integer Dim Arg As String
Arg = "" LastPos = 1 If ArgNum = 1 Then Arg = srchstr Do While InStr(srchstr, Delim) > 0 Pos = InStr(LastPos, srchstr, Delim) If Pos = 0 Then If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos) Exit Do Else ArgCount = ArgCount + 1 If ArgCount = ArgNum Then Arg = Mid(srchstr, LastPos, Pos - LastPos) Exit Do End If End If LastPos = Pos + 1 Loop ExtractArgument = Arg
Exit Function
Err_ExtractArgument: MsgBox "Error " & Err & ": " & Error Resume Next End Function' SendMail(strFrom, strTo, strSubject, strBody, wsk, strAttachName, txtEncodedFile) ' SendMail "[email protected]", "[email protected]", "Test Message", "Body", Winsock1, "myfile.ext", txtEncodedFile ' If you omit the last two arguements then no file is attached ' Before attaching a file, you must first encode it using the Base64EncodeFile functionPublic Sub SendMail(strFrom As String, strTo As String, strSubject As String, strBody As TextBox, wsk As Winsock, Optional strAttachName As String, Optional txtEncodedFile As Control)
我隻用mapi發附件 Private Sub cmdAttachment_Click() On Error Resume Next
With CommonDialog1 .DialogTitle = "Insert Attachment" .Filter = "All Files (*.*)|*.*" .ShowOpen
If Dir(.FileName) <> "" Then txtAttachment.Text = .FileName
' 顯示 Attachment 的 Icon oleAttachment.SourceDoc = .FileName oleAttachment.CreateEmbed .FileName Else MsgBox "Attachment is not available.", vbCritical End If End With End SubPrivate Sub cmdSend_Click() ' 開始 MAPI Session MAPISession1.SignOn
' 當 MAPI Session 建立後, ' Session 所產生的 Handle 會存於 SessionID 屬性中 If MAPISession1.SessionID <> 0 Then
' 設定 Attachment (附件) If Dir(txtAttachment.Text) <> "" Then MAPIMessages1.MsgNoteText = MAPIMessages1.MsgNoteText & vbCrLf MAPIMessages1.AttachmentPosition = Len(MAPIMessages1.MsgNoteText) - 1 MAPIMessages1.AttachmentPathName = txtAttachment.Text End If
' 傳送 E-Mail 且不顯示"郵件對話盒" (直接傳送) MAPIMessages1.Send False End If
' 結束 MAPI Session MAPISession1.SignOff End SubPrivate Sub cmdExit_Click() End End Sub
winsock發，但是不帶附件的 Dim strData As String Dim Start As Single Dim WaitTime As SinglePrivate Sub cmdSend_Click() Dim sFrom As String Dim sTo As String Dim sSubject As String Dim sDate As String Dim sMailType As String Dim sMailHeader As String Dim sMailBody As String Dim blnOK As Boolean
If Winsock1.State = sckClosed Then ' 使用 TCP Protocol Winsock1.Protocol = sckTCPProtocol
' 設定郵件伺服器 IP Address Winsock1.RemoteHost = txtServer.Text
' 設定 SMTP Port 為 25 Winsock1.RemotePort = 25
' 送件端嘗試連結至郵件伺服器端 Winsock1.Connect
' 等候郵件伺服器回傳 220 Ready for Mail 訊息 blnOK = WaitforResponse("220") ' Ready for Mail
If Not blnOK Then StatusBar1.Panels(1).Text = "Status: Connection Fail" StatusBar1.Refresh Exit Sub End If
' 等候郵件伺服器回傳 250 OK 訊息 blnOK = WaitforResponse("250") ' OK If Not blnOK Then StatusBar1.Panels(1).Text = "Status: Connection Fail" StatusBar1.Refresh Exit Sub End If ' 送件端發出 RCPT TO: 指令代表收件者 E-Mail Address Winsock1.SendData "RCPT TO: " & Trim(txtToAddress.Text) & vbCrLf
' 等候郵件伺服器回傳 250 OK 訊息 blnOK = WaitforResponse("250") ' OK
If Not blnOK Then StatusBar1.Panels(1).Text = "Status: Connection Fail" StatusBar1.Refresh Exit Sub End If
' 送件端發出 DATA 指令代表開始傳送 E-Mail Winsock1.SendData "DATA" & vbCrLf
' 等候郵件伺服器回傳 354 Start Mail Input 訊息 blnOK = WaitforResponse("354") ' Start Mail Input
If Not blnOK Then StatusBar1.Panels(1).Text = "Status: Connection Fail" StatusBar1.Refresh Exit Sub End If
' 等候郵件伺服器回傳 221 Close Connection 訊息 blnOK = WaitforResponse("221") ' Close Connection
If Not blnOK Then StatusBar1.Panels(1).Text = "Status: Connection Fail" StatusBar1.Refresh Exit Sub End If
' 關閉 Winsock Winsock1.Close
StatusBar1.Panels(1).Text = "Status: Mail Sent" StatusBar1.Refresh End If End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long) ' 郵件伺服器回傳訊息, 其中: ' 220 代表 Ready for Mail ' 221 代表 Close Connection ' 250 代表 OK ' 354 代表 Start Mail Input
Winsock1.GetData strData End SubPrivate Function WaitforResponse(ResponseCode As String) As Boolean Start = Timer
' SMTP Error: Time Out Do While Len(strData) = 0 WaitTime = Timer - Start DoEvents If WaitTime > 50 Then MsgBox "SMTP Error: Time Out.", vbCritical WaitforResponse = False Exit Function End If Loop
' Winsock Error Do While Left(strData, 3) <> ResponseCode DoEvents If WaitTime > 50 Then MsgBox "SMTP Error: " & ResponseCode & " " & strData, vbCritical WaitforResponse = False Exit Function End If Loop
strData = "" WaitforResponse = True End FunctionPrivate Sub cmdExit_Click() If Winsock1.State <> sckClosed Then Winsock1.Close End If End End Sub
frmAbout.Show vbModal
End SubPrivate Sub cmdClose_Click()
Unload Me
End SubPrivate Sub cmdSelect_Click()
cmdDialog.ShowOpen
txtAttach = cmdDialog.FileName
End SubPrivate Sub cmdSend_Click()
cmdSend.Enabled = False
If ValidateEntry = False Then MsgBox "Either the server name or to address were left empty.", vbCritical + vbOKOnly, Me.Caption: cmdSend.Enabled = True: Exit Sub
If txtAttach.Text <> "" Then
lblStatus = "Encoding file attachment"
Base64EncodeFile txtAttach.Text, rtfAttach, txtOutput
End If
lblStatus = "Connecting to POP Server"
ConnectToServer txtServer.Text, Winsock1
End SubPrivate Sub Form_Load()
txtAttach = ""
txtBody = ""
txtFromAddress = ""
txtServer = ""
txtSubject = ""
txtToAddress = ""
End SubPrivate Sub Winsock1_Connect()
lblStatus = "Connected to POP Server"
Wait 0.5
lblStatus = "Sending mail"
If txtAttach.Text = "" Then
SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1
Else
SendMail txtFromAddress, txtToAddress, txtSubject, txtBody, Winsock1, txtAttach, txtOutput
End If
lblStatus = "Mail sent"
cmdSend.Enabled = True
lblStatus = "Status:"
End SubPrivate Sub Winsock1_Error(ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
MsgBox "Error Number: " & Number & vbCrLf & Description & vbCrLf & Source, vbCritical + vbOKOnly, Me.Caption
End SubPrivate Function ValidateEntry() As Boolean
ValidateEntry = True
If txtServer.Text = "" Or txtToAddress = "" Then ValidateEntry = False
End Function'模块代码Option ExplicitPublic 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,rtfTemp,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, rtfTemp As RichTextBox, txtOutput As TextBox)
Dim intCount As Integer
Dim strTemp As String
Dim lngMax As Long lngMax = 0
txtOutput.Text = ""
rtfTemp.LoadFile strFile
For intCount = 1 To Len(rtfTemp.Text) Step 3
strTemp = Mid(rtfTemp.Text, intCount, 3)
txtOutput.Text = txtOutput.Text & Base64Encode(strTemp)
lngMax = lngMax + 4
If lngMax = 72 Then
lngMax = 0
txtOutput.Text = txtOutput.Text & vbCrLf
End If
DoEvents
Next intCount
End Sub' ConnectToServer(strServer, wsk, strSrvPort)
' ConnectToServer "pop.microsoft.com", Winsock1, 25
' Normally leave out the last arguement and let the Winsock control use
' the default port.Public Sub ConnectToServer(strServer As String, wsk As Winsock, Optional strSrvPort As String)
wsk.RemoteHost = strServer
If strSrvPort = "" Then
wsk.RemotePort = 25
Else
wsk.RemotePort = Val(strSrvPort)
End If
wsk.ConnectEnd Sub' ExtractArgument(ArgNum, srchstr, Delim)
' ExtractArgument(3, "No 1, No 2, No 3", ",") Would return No 3
' I did not have time to sort out the variable names in this function,
' so if you can be bothered to, please send it to me at [email protected] Function ExtractArgument(ArgNum As Integer, srchstr As String, Delim As String) As String On Error GoTo Err_ExtractArgument
Dim ArgCount As Integer
Dim LastPos As Integer
Dim Pos As Integer
Dim Arg As String
Arg = ""
LastPos = 1
If ArgNum = 1 Then Arg = srchstr
Do While InStr(srchstr, Delim) > 0
Pos = InStr(LastPos, srchstr, Delim)
If Pos = 0 Then
If ArgCount = ArgNum - 1 Then Arg = Mid(srchstr, LastPos)
Exit Do
Else
ArgCount = ArgCount + 1
If ArgCount = ArgNum Then
Arg = Mid(srchstr, LastPos, Pos - LastPos)
Exit Do
End If
End If
LastPos = Pos + 1
Loop
ExtractArgument = Arg
Exit Function
Err_ExtractArgument:
MsgBox "Error " & Err & ": " & Error
Resume Next
End Function' SendMail(strFrom, strTo, strSubject, strBody, wsk, strAttachName, txtEncodedFile)
' SendMail "[email protected]", "[email protected]", "Test Message", "Body", Winsock1, "myfile.ext", txtEncodedFile
' If you omit the last two arguements then no file is attached
' Before attaching a file, you must first encode it using the Base64EncodeFile functionPublic Sub SendMail(strFrom As String, strTo As String, strSubject As String, strBody As TextBox, wsk As Winsock, Optional strAttachName As String, Optional txtEncodedFile As Control)
Dim intCount As Integer
Wait 0.5
wsk.SendData "EHLO " & wsk.LocalIP & vbCrLf
wsk.SendData "MAIL FROM:" & strFrom & vbCrLf
Wait 0.5
wsk.SendData "RCPT TO:" & strTo & vbCrLf
wsk.SendData "DATA" & vbCrLf
Wait 0.5
wsk.SendData "MIME-Version: 1.0" & vbCrLf
wsk.SendData "From: " & ExtractArgument(1, strFrom, "@") & " <" & strFrom & ">" & vbCrLf
wsk.SendData "To: <" & strTo & ">" & vbCrLf
wsk.SendData "Subject: " & strSubject & vbCrLf
wsk.SendData "Content-Type: multipart/mixed;" & vbCrLf
wsk.SendData " boundary=Unique-Boundary" & vbCrLf & vbCrLf
wsk.SendData " [ Random garbage here ]" & vbCrLf & vbCrLf
wsk.SendData vbCrLf & "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-type: text/plain; charset=US-ASCII" & vbCrLf & vbCrLf
wsk.SendData strBody.Text & vbCrLf & vbCrLf
If LTrim(RTrim(strAttachName)) <> "" Then
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:
wsk.SendData "--Unique-Boundary" & vbCrLf
wsk.SendData "Content-Type: multipart/parallel; boundary=Unique-Boundary-2" & vbCrLf & vbCrLf
wsk.SendData "--Unique-Boundary-2" & vbCrLf
wsk.SendData "Content-Type: application/octet-stream;" & vbCrLf
wsk.SendData " name=" & strAttachName & vbCrLf
wsk.SendData "Content-Transfer-Encoding: base64" & vbCrLf
wsk.SendData "Content-Disposition: inline;" & vbCrLf
wsk.SendData " filename=" & strAttachName & vbCrLf & vbCrLf
wsk.SendData txtEncodedFile.Text & "==" & vbCrLf
wsk.SendData "--Unique-Boundary-2----Unique-Boundary--"
End If
wsk.SendData vbCrLf & "." & vbCrLf
Wait 0.5
wsk.SendData "QUIT" & vbCrLf
Wait 0.5
wsk.Close
End Sub' Wait(WaitTime)
' Wait 0.5Public Sub Wait(WaitTime) Dim StartTime As Double
StartTime = Timer
Do While Timer < StartTime + WaitTime
If Timer > 86395 Or Timer = 0 Then Exit Do
DoEvents
Loop
End Sub
Private Sub cmdAttachment_Click()
On Error Resume Next
With CommonDialog1
.DialogTitle = "Insert Attachment"
.Filter = "All Files (*.*)|*.*"
.ShowOpen
If Dir(.FileName) <> "" Then
txtAttachment.Text = .FileName
' 顯示 Attachment 的 Icon
oleAttachment.SourceDoc = .FileName
oleAttachment.CreateEmbed .FileName
Else
MsgBox "Attachment is not available.", vbCritical
End If
End With
End SubPrivate Sub cmdSend_Click()
' 開始 MAPI Session
MAPISession1.SignOn
' 當 MAPI Session 建立後,
' Session 所產生的 Handle 會存於 SessionID 屬性中
If MAPISession1.SessionID <> 0 Then
' 建立 MAPIMessages 與 MAPISession 間之有效關聯
MAPIMessages1.SessionID = MAPISession1.SessionID
' 建立新的 E-Mail Message
MAPIMessages1.Compose
' 收件者 (Recipient's Name)
MAPIMessages1.RecipDisplayName = txtName.Text
' 收件者的 E-Mail Address
MAPIMessages1.RecipAddress = "smtp: " & txtAddress.Text
' 是否要檢查收件者有無存在於全域 (Global) 或個人 (Personal) 通訊錄裏
MAPIMessages1.AddressResolveUI = True
' 檢查收件者有無存在於全域 (Global) 或個人 (Personal) 通訊錄裏
MAPIMessages1.ResolveName
' E-Mail 的主旨
MAPIMessages1.MsgSubject = txtSubject.Text
' E-Mail 的內文
MAPIMessages1.MsgNoteText = txtNote.Text
' 設定 Attachment (附件)
If Dir(txtAttachment.Text) <> "" Then
MAPIMessages1.MsgNoteText = MAPIMessages1.MsgNoteText & vbCrLf
MAPIMessages1.AttachmentPosition = Len(MAPIMessages1.MsgNoteText) - 1
MAPIMessages1.AttachmentPathName = txtAttachment.Text
End If
' 傳送 E-Mail 且不顯示"郵件對話盒" (直接傳送)
MAPIMessages1.Send False
End If
' 結束 MAPI Session
MAPISession1.SignOff
End SubPrivate Sub cmdExit_Click()
End
End Sub
Dim strData As String
Dim Start As Single
Dim WaitTime As SinglePrivate Sub cmdSend_Click()
Dim sFrom As String
Dim sTo As String
Dim sSubject As String
Dim sDate As String
Dim sMailType As String
Dim sMailHeader As String
Dim sMailBody As String
Dim blnOK As Boolean
If Winsock1.State = sckClosed Then
' 使用 TCP Protocol
Winsock1.Protocol = sckTCPProtocol
' 設定郵件伺服器 IP Address
Winsock1.RemoteHost = txtServer.Text
' 設定 SMTP Port 為 25
Winsock1.RemotePort = 25
' 送件端嘗試連結至郵件伺服器端
Winsock1.Connect
' 等候郵件伺服器回傳 220 Ready for Mail 訊息
blnOK = WaitforResponse("220") ' Ready for Mail
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
StatusBar1.Panels(1).Text = "Status: Connecting ...."
StatusBar1.Refresh
' 送件端發出 HELO 指令
Winsock1.SendData "HELO " & txtServer.Text & vbCrLf
' 等候郵件伺服器回傳 250 OK 訊息
blnOK = WaitforResponse("250") ' OK
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
StatusBar1.Panels(1).Text = "Status: Connected"
StatusBar1.Refresh
' 送件端發出 MAIL FROM: 指令代表送件者 E-Mail Address
Winsock1.SendData "MAIL FROM: " & Trim(txtFromAddress.Text) & vbCrLf StatusBar1.Panels(1).Text = "Status: Sending Message"
StatusBar1.Refresh
' 等候郵件伺服器回傳 250 OK 訊息
blnOK = WaitforResponse("250") ' OK If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If ' 送件端發出 RCPT TO: 指令代表收件者 E-Mail Address
Winsock1.SendData "RCPT TO: " & Trim(txtToAddress.Text) & vbCrLf
' 等候郵件伺服器回傳 250 OK 訊息
blnOK = WaitforResponse("250") ' OK
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
' 送件端發出 DATA 指令代表開始傳送 E-Mail
Winsock1.SendData "DATA" & vbCrLf
' 等候郵件伺服器回傳 354 Start Mail Input 訊息
blnOK = WaitforResponse("354") ' Start Mail Input
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
' E-Mail Header (標頭) 部分
sFrom = "From: """ & txtFromName.Text & """ <" & Trim(txtFromAddress.Text) & ">" & vbCrLf
sTo = "To: """ & txtToName.Text & """ <" & Trim(txtToAddress.Text) & ">" & vbCrLf
sSubject = "Subject: " & txtSubject.Text & vbCrLf
sDate = "Date: " & Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & " +0800" & vbCrLf
sMailType = "MIME-Version: 1.0" & vbCrLf & "X-Mailer: Internet Mail Service (5.5.2448.0)" & vbCrLf
sMailHeader = sFrom & sTo & sSubject & sDate & sMailType
' 送件端傳送 E-Mail Header (標頭) 部分
Winsock1.SendData sMailHeader & vbCrLf
' E-Mail Body (內容) 部分
sMailBody = txtMessage.Text & vbCrLf
' 送件端傳送 E-Mail Body (內容) 部分
Winsock1.SendData sMailBody & vbCrLf
' E-Mail 以句點 (.) 作為結尾
Winsock1.SendData vbCrLf & "." & vbCrLf
' 等候郵件伺服器回傳 250 OK 訊息
blnOK = WaitforResponse("250") ' OK
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
' 送件端發出 QUIT 指令代表關閉 TCP 連結
Winsock1.SendData "QUIT" & vbCrLf
StatusBar1.Panels(1).Text = "Status: Disconnecting"
StatusBar1.Refresh
' 等候郵件伺服器回傳 221 Close Connection 訊息
blnOK = WaitforResponse("221") ' Close Connection
If Not blnOK Then
StatusBar1.Panels(1).Text = "Status: Connection Fail"
StatusBar1.Refresh
Exit Sub
End If
' 關閉 Winsock
Winsock1.Close
StatusBar1.Panels(1).Text = "Status: Mail Sent"
StatusBar1.Refresh
End If
End SubPrivate Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
' 郵件伺服器回傳訊息, 其中:
' 220 代表 Ready for Mail
' 221 代表 Close Connection
' 250 代表 OK
' 354 代表 Start Mail Input
Winsock1.GetData strData
End SubPrivate Function WaitforResponse(ResponseCode As String) As Boolean
Start = Timer
' SMTP Error: Time Out
Do While Len(strData) = 0
WaitTime = Timer - Start
DoEvents
If WaitTime > 50 Then
MsgBox "SMTP Error: Time Out.", vbCritical
WaitforResponse = False
Exit Function
End If
Loop
' Winsock Error
Do While Left(strData, 3) <> ResponseCode
DoEvents
If WaitTime > 50 Then
MsgBox "SMTP Error: " & ResponseCode & " " & strData, vbCritical
WaitforResponse = False
Exit Function
End If
Loop
strData = ""
WaitforResponse = True
End FunctionPrivate Sub cmdExit_Click()
If Winsock1.State <> sckClosed Then
Winsock1.Close
End If End
End Sub
csdnexplore(csdnexplore）给我的代码让我得到很大启发另处，我邮箱里居然有龙卷风这小子的邮件，不知道是不是用 csdnexplore(csdnexplore)的代码发过来的，我用他的代码还没成功发过，不过其中GenMail函数正是我需有的，我正是卡在这里，结贴，下次问收邮件的问题