我的代码如下:我用163和126的邮箱都测试过了总是弹出“发送失败”请大伙帮忙看看工程已经引用相关组件,部件创建都没问题因为是一个朋友帮忙写的他说的话在他的电脑上没问题,他是windows2003好像,我的是XPOption ExplicitPrivate Sub Command1_Click()
If List1.SelCount <= 0 Then Exit Sub Dim MailBody As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Text1.Text & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=1';"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open "select * from [" & List1.Text & "$]", con, adOpenKeyset, adLockReadOnly, adCmdText
MailBody = "<table border='1'><tr>"
Dim i As Long, j As Long
For i = 0 To rs.Fields.Count - 1
MailBody = MailBody & "<td>" & rs.Fields(i).Name & "</td>"
Next
MailBody = MailBody & "</tr>"
For i = 0 To rs.RecordCount - 1
MailBody = MailBody & "<tr>"
For j = 0 To rs.Fields.Count - 1
MailBody = MailBody & "<td>" & rs.Fields(j).Value & "</td>"
Next
rs.MoveNext
MailBody = MailBody & "</tr>"
Next
MailBody = MailBody & "</table>"
'MsgBox MailBody
Dim re
re = SendMail(Text7.Text, Text6.Text, MailBody, Text2.Text, Text4.Text, Text5.Text, Text3.Text)
If re Then
MsgBox "发送成功"
Else
MsgBox "发送失败"
End If
rs.Close
con.Close
End SubPrivate Sub Command2_Click()
With CommonDialog1
.DialogTitle = "请选择Excel文件"
.CancelError = True
.Filter = "Excel Files(*.xls)|*.xls"
On Error Resume Next
.ShowOpen
Text1.Text = .FileName
End With
If Text1.Text = "" Then Exit Sub
Me.MousePointer = 11
Dim objExcel As Excel.Application
Dim objWork As Excel.Workbook
Dim objSheet As Excel.Worksheet
Set objExcel = New Excel.Application
Set objWork = objExcel.Workbooks.Open(Text1.Text)
For Each objSheet In objWork.Worksheets
List1.AddItem objSheet.Name
Next
objWork.Close
objExcel.Quit
Set objExcel = Nothing
Me.MousePointer = 0
End Sub'函数名: SendMail
'作 用:用Jmail组件发送邮件
'参 数:
' MailtoAddress -----收信人信箱
' Subject -----主题
' MailBody -----信件内容
' MailFrom -----发信人信箱
' MailServerUser -----登陆邮箱用户名
' MailServerPass -----登陆邮箱密码
' MailServer -----发件SMTP服务器
'**************************************************
Function SendMail(MailtoAddress, Subject, MailBody, MailFrom, MailServerUser, MailServerPass, MailServer)
' on error resume next
Dim JMail As JMail.Message, JMailstat
Set JMail = CreateObject("JMail.Message")
If Err Then
Err.Clear
JMail.Close
Set JMail = Nothing
Exit Function
End If
JMail.Charset = "gb2312" '邮件字符集
JMail.Silent = True '忽略错误
JMail.ContentType = "text/html" '邮件编码
JMail.AddRecipient MailtoAddress '收件人地址
'JMail.ReturnReceipt = True '是否收条(验证中)
JMail.From = MailFrom '发件人邮箱
'JMail.MailDomain = MailDomain '邮箱所在域名(验证中)
'JMail.FromName = FromName '发件人姓名
JMail.MailServerUserName = MailServerUser '邮箱用户名
JMail.MailServerPassWord = MailServerPass '邮箱密码
JMail.Subject = Subject '邮件主题
'JMail.Body = MailBody '邮件正文(纯文本格式)
JMail.HTMLBody = MailBody '邮件正文(HTML格式)
'JMail.Priority = 3 '邮件等级,1为加急,3为普通,5为低级
JMailstat = JMail.Send(MailServer)
If JMailstat Then
SendMail = True
Else
SendMail = False
End If
JMail.Close
Set JMail = Nothing
End Function
If List1.SelCount <= 0 Then Exit Sub Dim MailBody As String
Dim con As ADODB.Connection
Dim rs As ADODB.Recordset
Set con = New ADODB.Connection
con.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & Text1.Text & ";Extended Properties='Excel 8.0;HDR=Yes;IMEX=1';"
Set rs = New ADODB.Recordset
rs.CursorLocation = adUseClient
rs.Open "select * from [" & List1.Text & "$]", con, adOpenKeyset, adLockReadOnly, adCmdText
MailBody = "<table border='1'><tr>"
Dim i As Long, j As Long
For i = 0 To rs.Fields.Count - 1
MailBody = MailBody & "<td>" & rs.Fields(i).Name & "</td>"
Next
MailBody = MailBody & "</tr>"
For i = 0 To rs.RecordCount - 1
MailBody = MailBody & "<tr>"
For j = 0 To rs.Fields.Count - 1
MailBody = MailBody & "<td>" & rs.Fields(j).Value & "</td>"
Next
rs.MoveNext
MailBody = MailBody & "</tr>"
Next
MailBody = MailBody & "</table>"
'MsgBox MailBody
Dim re
re = SendMail(Text7.Text, Text6.Text, MailBody, Text2.Text, Text4.Text, Text5.Text, Text3.Text)
If re Then
MsgBox "发送成功"
Else
MsgBox "发送失败"
End If
rs.Close
con.Close
End SubPrivate Sub Command2_Click()
With CommonDialog1
.DialogTitle = "请选择Excel文件"
.CancelError = True
.Filter = "Excel Files(*.xls)|*.xls"
On Error Resume Next
.ShowOpen
Text1.Text = .FileName
End With
If Text1.Text = "" Then Exit Sub
Me.MousePointer = 11
Dim objExcel As Excel.Application
Dim objWork As Excel.Workbook
Dim objSheet As Excel.Worksheet
Set objExcel = New Excel.Application
Set objWork = objExcel.Workbooks.Open(Text1.Text)
For Each objSheet In objWork.Worksheets
List1.AddItem objSheet.Name
Next
objWork.Close
objExcel.Quit
Set objExcel = Nothing
Me.MousePointer = 0
End Sub'函数名: SendMail
'作 用:用Jmail组件发送邮件
'参 数:
' MailtoAddress -----收信人信箱
' Subject -----主题
' MailBody -----信件内容
' MailFrom -----发信人信箱
' MailServerUser -----登陆邮箱用户名
' MailServerPass -----登陆邮箱密码
' MailServer -----发件SMTP服务器
'**************************************************
Function SendMail(MailtoAddress, Subject, MailBody, MailFrom, MailServerUser, MailServerPass, MailServer)
' on error resume next
Dim JMail As JMail.Message, JMailstat
Set JMail = CreateObject("JMail.Message")
If Err Then
Err.Clear
JMail.Close
Set JMail = Nothing
Exit Function
End If
JMail.Charset = "gb2312" '邮件字符集
JMail.Silent = True '忽略错误
JMail.ContentType = "text/html" '邮件编码
JMail.AddRecipient MailtoAddress '收件人地址
'JMail.ReturnReceipt = True '是否收条(验证中)
JMail.From = MailFrom '发件人邮箱
'JMail.MailDomain = MailDomain '邮箱所在域名(验证中)
'JMail.FromName = FromName '发件人姓名
JMail.MailServerUserName = MailServerUser '邮箱用户名
JMail.MailServerPassWord = MailServerPass '邮箱密码
JMail.Subject = Subject '邮件主题
'JMail.Body = MailBody '邮件正文(纯文本格式)
JMail.HTMLBody = MailBody '邮件正文(HTML格式)
'JMail.Priority = 3 '邮件等级,1为加急,3为普通,5为低级
JMailstat = JMail.Send(MailServer)
If JMailstat Then
SendMail = True
Else
SendMail = False
End If
JMail.Close
Set JMail = Nothing
End Function
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货