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

2004-06-28 03:02:02 843 阅读 AI 写同款 · GEO 优化AI 选题数据监测一键分发 ›

terry6394 墨衍会员 · AI 创作全网分发关注 + 加入社区

STM32H723串口接收全为0 & CAN错误中断问题 STM32H723串口接收全为0 和叠加的导致CAN错误问题阅读详情

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

...全文

《Ventoy 制作系统安装 U 盘的具体步骤》然后您可以在电脑的磁盘管理中对 U 盘进行快速格式化，选择 FAT32 或 NTFS 文件系统。至此，Ventoy 系统安装 U 盘就制作完成了。您可以在需要安装系统的电脑上，从 U 盘启动，然后选择相应的系统镜像进行安装。安装完成后，将您需要的操作系统镜像文件（如 Windows、Linux 等的 ISO 格式镜像）复制到 U 盘的根目录。在安装程序中，选择您插入的 U 盘设备，确保选择正确，以免误操作。2. 确认选择的 U 盘盘符正确，防止误操作导致其他磁盘数据丢失。点击“安装”按钮，等待安装完成。阅读详情

terry6394

VB基础类 7,788 成员 197,583 内容

+ 关注 + 加入社区

切换为时间正序

56625079 2004-07-09

打赏
举报

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

terry6394 2004-06-28

打赏
举报

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

谢谢 (CSDN第一猛男)

AKillGodKillBuddha 2004-06-28

打赏
举报

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

56625079 2004-06-28

打赏
举报

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

terry6394 2004-06-28

打赏
举报

没人帮帮我吗?!

terry6394 2004-06-28

打赏
举报

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

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

相关推荐