怎样用VB实现自动发送邮件

[terry6394]

我想做个程序,可以实现自动发邮件到某一特定的信箱.邮件包含一小附件.和一句话.请指教

[terry6394]

先顶了,,,各位帮帮忙吧

[terry6394]

没人帮帮我吗?!

[56625079]

想做垃圾邮件发送程序?还是想做个病毒?:)

[AKillGodKillBuddha]

Option Explicit
Public ServerIp As String 'SMTP服務器地址
Public ServerPort As Long 'SMTP服務器端口

Dim strSendName As String '發送人姓名
Dim strReceiveName As String '接收人姓名
Dim strFromMail As String '發送人地址
Dim strToMail As String '諉彶華硊
Dim m_Date As String '發送日
Dim strSubject As String '主題
Dim strContent As String '正文
Dim Information As String '從服務器接收響應消息

Private Sub cmdAtt_Click()
Dim i As Integer
For i = 0 To cobAtt.ListCount - 1
frmAtt.LstAtt.AddItem cobAtt.List(i)
Next i
cobAtt.Clear
frmAtt.Show vbModal
End Sub

Private Sub cmdSend_Click()
If cobAtt.ListCount > 0 Then
GenMail True
Else
GenMail False
End If
'設置Winsock
Wsock.Close
Wsock.RemoteHost = ServerIp
Wsock.RemotePort = ServerPort
'連接SMTP服務器
Wsock.Connect
If Not WaitForResponse("220", 10) Then
txtMsg.Text = "郵件服務器連接不上......"
Exit Sub
End If
'打開對話
Wsock.SendData "HELO" & " " & Wsock.LocalHostName & vbCrLf
If Not WaitForResponse("250", 10) Then
txtMsg.Text = txtMsg.Text & "無法打開郵件發送對話" & vbCrLf
Exit Sub
End If
'發送發送方地址
Wsock.SendData "MAIL FROM:" & " " & strFromMail & vbCrLf
If Not WaitForResponse("250", 10) Then
txtMsg.Text = txtMsg.Text & "無法發送發送方地址" & vbCrLf
Exit Sub
End If
'發送接收方地址
Wsock.SendData "RCPT TO:" & " " & strToMail & vbCrLf
If Not WaitForResponse("250", 10) Then
txtMsg.Text = txtMsg.Text & "無法發送接收方地址" & vbCrLf
Exit Sub
End If
'發送消息體
Wsock.SendData "DATA" & vbCrLf
If Not WaitForResponse("354", 10) Then
txtMsg.Text = txtMsg.Text & "無法發送消息體" & vbCrLf
Exit Sub

End If
Dim fnum As Integer
fnum = FreeFile
Open App.Path & "\mail.tmp" For Input As #fnum
'Wsock.SendData mData & vbCrLf
While Not EOF(fnum)
Line Input #fnum, strContent
Wsock.SendData strContent & vbCrLf
Wend
Close #fnum
Wsock.SendData "." & vbCrLf
If Not WaitForResponse("250", 20) Then
txtMsg.Text = txtMsg.Text & "消息體發送不成功" & vbCrLf
Exit Sub
End If
'結束郵件發送對話
Wsock.SendData "QUIT" & vbCrLf
If Not WaitForResponse("221", 10) Then
Exit Sub
End If
Wsock.Close
txtMsg.Text = txtMsg.Text & "郵件發送成功"
End Sub

'該按扭事件過程用于設置smtp服務
Private Sub cmdSetUp_Click()
frmSetup.Show
End Sub

'程序加載時讀出上次的設置
Private Sub Form_Load()
ServerIp = GetSetting("email", "smtpserver", "serverip", "")
ServerPort = GetSetting("email", "smtpserver", "serverport", 25)
Wsock.Protocol = sckTCPProtocol
End Sub

'程序退出時保存設置
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
SaveSetting "email", "smtpserver", "serverip", ServerIp
SaveSetting "email", "smtpserver", "serverport", ServerPort
End Sub

'接收服務器的響應消息
Private Sub Wsock_DataArrival(ByVal bytesTotal As Long)
Wsock.GetData Information
txtMsg.Text = txtMsg.Text & Information & vbCrLf
End Sub

'該函數用于等待服務器響應碼
Private Function WaitForResponse(strResponse As String, WaitTime As Integer) As Boolean
Dim WaitSt As Date
WaitSt = Now()
While InStr(1, Information, strResponse, vbTextCompare) < 1
DoEvents
If DateDiff("s", WaitSt, Now) > WaitTime Then
Information = ""
WaitForResponse = False
Exit Function
End If
Wend
Information = ""
WaitForResponse = True
End Function

'該函數用于构造信件內容
Private Sub GenMail(bAttachment As Boolean)
Dim fnum As Integer, FAttin As Integer
Dim strLine As String
strSendName = txtSName.Text
strReceiveName = txtRName.Text
strFromMail = txtFrom.Text
strToMail = txtTo.Text
m_Date = Format(Date, "Ddd") & ", " & Format(Date, "dd Mmm YYYY") & " " & Format(Time, "hh:mm:ss") & "" & " -0600"
strSubject = txtSubject.Text
strContent = txtContent.Text
fnum = FreeFile()
Open App.Path & "\mail.tmp" For Output As fnum
'构造信件標題字段
Print #fnum, "From:" & Chr(32) & strSendName
Print #fnum, "Date:" & Chr(32) & m_Date
Print #fnum, "X-Mailer: BigAnt Smtp Mailer V1.0"
Print #fnum, "To:" & Chr(32) & strReceiveName
Print #fnum, "Subject:" & Chr(32) & strSubject
If bAttachment = False Then
Print #fnum, ""
Print #fnum, strContent
Exit Sub
End If
Print #fnum, "MIME-Version: 1.0"
Print #fnum, "Content-type:multipart/mixed;"
Print #fnum, " boundary =""----=_NextPart_000_000A_01BF9F1A"""
Print #fnum, ""
'書寫信件的正文內容
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A"
Print #fnum, "Content-Type: text/plain;"
Print #fnum, " Charset = ""gb2312"""
Print #fnum, "Content-Transfer-Encoding: 8bit"
Print #fnum, ""
Print #fnum, strContent
'附件內
Dim i As Integer
For i = 0 To cobAtt.ListCount - 1
Base64Encode cobAtt.List(i), App.Path & "\attachment" & i & ".tmp"
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A"
Print #fnum, "Content-Type: Application/octet-stream"
Print #fnum, " name=" & cobAtt.List(i)
Print #fnum, "Content-Transfer-Encoding: base64"
Print #fnum, "Content-Disposition: attachment;"
Print #fnum, " FileName=" & cobAtt.List(i)
Print #fnum, ""
FAttin = FreeFile
Open App.Path & "\attachment" & i & ".tmp" For Input As #FAttin
While Not EOF(FAttin)
Line Input #FAttin, strLine
Print #fnum, strLine
Wend
Close FAttin
Next i
Print #fnum, "--" & "----=_NextPart_000_000A_01BF9F1A" & "--"
Close fnum
End Sub

[terry6394]

56625079(红狐狸)
晕.....我可没这个意思....我因为我的一个检控软件需要自动截取屏幕然后发送到邮箱而已.


谢谢 (CSDN第一猛男)

[56625079]

呵呵，开个玩笑。你用邮件的话，实时性不太好呀！你还不如用远程抓屏，或是PCANYWHERE之类的软件呢