我想使用VB做的程序发送数据到邮件中去,该怎么实现啊!?
解决方案 »
- vb winsock 编程 求高手~
- vb编程序listbox 与option连接的问题
- SendMessage 无反应问题,在线等!~
- 用datareport导出的问题
- ||||敬请关注:关于syslistview32||||
- 我论坛里的几个经典笑话,大家开心一下吧。
- 安装VB时出现的诡异现象
- 还有大师吗?谁能替我解决这个问题???难道就没有一个大师?????真不想再做程序了???
- 求助:给看下这个简单加密解密程序哪儿出错了?
- 如何能调能这段代码实现要求的功能?
- 叶帆 达人请问你的EMAIL是多少啊?/谢谢先
- 使用VB+DAO开发的程序,为什么安装到windows sp2下会出现数据类型转换错误的问题?
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1
Caption = "Form1"
ClientHeight = 5805
ClientLeft = 2355
ClientTop = 1680
ClientWidth = 5730
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5805
ScaleWidth = 5730
Begin VB.TextBox txtServerInf
Height = 1395
Left = 0
MultiLine = -1 'True
ScrollBars = 3 'Both
TabIndex = 19
Top = 4410
Width = 5715
End
Begin VB.CommandButton cmdSend
Caption = "发送(&S)"
Height = 495
Left = 4590
TabIndex = 17
Top = 3720
Width = 1065
End
Begin MSWinsockLib.Winsock dsSock
Left = 3750
Top = 3120
_ExtentX = 741
_ExtentY = 741
_Version = 393216
End
Begin VB.TextBox txtPwd
Height = 375
IMEMode = 3 'DISABLE
Left = 2760
PasswordChar = "O"
TabIndex = 16
Top = 3750
Width = 1425
End
Begin VB.TextBox txtUser
Height = 375
Left = 600
TabIndex = 14
Top = 3750
Width = 1425
End
Begin VB.CheckBox chkSMTP
Caption = "SMTP服务器需要验证"
Height = 195
Left = 0
TabIndex = 12
Top = 3480
Value = 1 'Checked
Width = 2025
End
Begin VB.TextBox txtSMTPPort
Height = 375
Left = 5220
TabIndex = 11
Text = "25"
Top = 3060
Width = 495
End
Begin VB.TextBox txtSMTPServer
Height = 375
Left = 1290
TabIndex = 9
Top = 3060
Width = 2115
End
Begin VB.TextBox txtContent
Height = 1935
Left = 0
MultiLine = -1 'True
TabIndex = 7
Top = 1110
Width = 5715
End
Begin VB.TextBox txtSubject
Height = 375
Left = 1020
TabIndex = 5
Top = 450
Width = 4695
End
Begin VB.TextBox txtTo
Height = 375
Left = 3960
TabIndex = 3
Top = 60
Width = 1755
End
Begin VB.TextBox txtFrom
Height = 375
Left = 1020
TabIndex = 1
Top = 60
Width = 1755
End
Begin VB.Label Label9
AutoSize = -1 'True
Caption = "服务器信息:"
Height = 195
Left = 0
TabIndex = 18
Top = 4170
Width = 1080
End
Begin VB.Label Label8
AutoSize = -1 'True
Caption = "密码:"
Height = 195
Left = 2130
TabIndex = 15
Top = 3840
Width = 540
End
Begin VB.Label Label7
AutoSize = -1 'True
Caption = "帐号:"
Height = 195
Left = 0
TabIndex = 13
Top = 3780
Width = 540
End
Begin VB.Label Label6
AutoSize = -1 'True
Caption = "端口号:"
Height = 195
Left = 4380
TabIndex = 10
Top = 3150
Width = 720
End
Begin VB.Label Label5
AutoSize = -1 'True
Caption = "SMTP服务器:"
Height = 195
Left = 0
TabIndex = 8
Top = 3150
Width = 1170
End
Begin VB.Label Label4
AutoSize = -1 'True
Caption = "邮件正文:"
Height = 195
Left = 0
TabIndex = 6
Top = 870
Width = 900
End
Begin VB.Label Label3
AutoSize = -1 'True
Caption = "主题:"
Height = 195
Left = 30
TabIndex = 4
Top = 540
Width = 540
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "收件人:"
Height = 195
Left = 2970
TabIndex = 2
Top = 150
Width = 720
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "发件人:"
Height = 195
Left = 30
TabIndex = 0
Top = 150
Width = 720
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim Answerf As Boolean
Sub SendMail(strFrom As String, strTo As String, strSubject As String, strMsg As String)
dsSock.Close
dsSock.Connect txtSMTPServer, txtSMTPPort
Waiting
dsSock.SendData "EHLO" & strFrom & vbCrLf
Waiting
If chkSMTP.Value = Checked Then
dsSock.SendData "AUTH LOGIN" & vbCrLf
Waiting
MsgBox Base64Encode(txtUser) & Base64Encode(txtPwd)
dsSock.SendData Base64Encode(txtUser) & vbCrLf
Waiting
dsSock.SendData Base64Encode(txtPwd) & vbCrLf
Waiting
End If
dsSock.SendData "MAIL FROM:<" & strFrom & ">" & vbCrLf
Waiting
dsSock.SendData "RCPT TO:<" & strTo & ">" & vbCrLf
Waiting
dsSock.SendData "DATA" & vbCrLf
Waiting
dsSock.SendData "DATA:" & Format$(Now, "dd mmm yy ttttt") & vbCrLf
dsSock.SendData "FROM:" & strFrom & vbCrLf
dsSock.SendData "TO:" & strTo & vbCrLf
dsSock.SendData "SUBJECT:" & strSubject & vbCrLf & vbCrLf
dsSock.SendData strMsg & vbCrLf & "." & vbCrLf
Waiting
dsSock.Close
MsgBox "信件发送完毕!"
End SubPublic Sub Waiting()
Dim PauseTime, Start
PauseTime = 30
Start = Timer
Do While Timer < Start + PauseTime And Not Answerf
DoEvents
Loop
Answerf = False
End Sub
Private Sub cmdSend_Click()
txtServerInf.Text = ""
Call SendMail(txtFrom.Text, txtTo.Text, txtSubject.Text, txtContent.Text)
End Sub
Private Sub dsSock_DataArrival(ByVal bytesTotal As Long)
Dim Comedata As String
dsSock.GetData Comedata
txtServerInf.Text = txtServerInf.Text + Comedata
Answerf = True
End SubPrivate Sub txtFrom_LostFocus()
If chkSMTP.Value = Checked Then
Dim i As Integer
i = InStr(1, txtFrom, "@")
If i <> 0 Then
txtUser = Mid(txtFrom, 1, i - 1)
txtSMTPServer = Mid(txtFrom, i + 1, Len(txtFrom) - i)
End If
End If
End Sub
Function MyASC(OneChar)
If OneChar = "" Then MyASC = 0 Else MyASC = Asc(OneChar)
End Function
Private Function Base64Encode(inData)
Const Base64 = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
Dim cOut, sOut, i
For i = 1 To Len(inData) Step 3
Dim nGroup As Long
Dim pOut, sGroup
nGroup = &H10000 * Asc(Mid(inData, i, 1)) + &H100 * MyASC(Mid(inData, i + 1, 1)) + MyASC(Mid(inData, i + 2, 1))
sGroup = Oct(nGroup)
sGroup = String(8 - Len(sGroup), "0") & sGroup
pOut = Mid(Base64, CLng("&o" & Mid(sGroup, 1, 2)) + 1, 1) + Mid(Base64, CLng("&o" & Mid(sGroup, 3, 2)) + 1, 1) + Mid(Base64, CLng("&o" & Mid(sGroup, 5, 2)) + 1, 1) + Mid(Base64, CLng("&o" & Mid(sGroup, 7, 2)) + 1, 1)
sOut = sOut + pOut
If (i + 2) Mod 57 = 0 Then sOut = sOut + vbCrLf
Next
Select Case Len(inData) Mod 3
Case 1:
sOut = Left(sOut, Len(sOut) - 2) + "=="
Case 2:
sOut = Left(sOut, Len(sOut) - 1) + "="
End Select
Base64Encode = sOut
End Function
和 处理多个附件 有人有资料吗?> 可以发出来吗?
最好不是用mapi,这个用起来不爽,最好斯用sock控件写的。
我倒是有个可以发信的。可惜不支持附件。我参照别的所谓支持附件的程序增加发送附件的代码,结果反倒不行了 :(
望高手指点阿!