Sub MySendObject()
Dim rs As New ADODB.Recordset
Dim ssql As String
Dim i As Long
ssql = "select distinct 村,邮箱 from CODE_TB2"
rs.Open ssql, CurrentProject.Connection, adOpenKeyset, adLockOptimistic
For i = 1 To rs.RecordCount
ssql = "select * from tb1 whhere 村='" & rs!村.Value & "'"
Call UpdateQuery("邮件查询", ssql)
DoCmd.OutputTo acOutputQuery, "邮件查询", acFormatXLS, "d:\邮件查询.xls"
DoEvents
SendEmail "你的邮箱全称", "你的邮箱服务器", "你的邮箱密码", "报表", "请及时上报!", "d:\邮件查询.xls", rs!邮箱.Value
rs.movenext
Next
End Sub
Public Sub SendEmail(ByVal stMail As String, ByVal stRx As String, ByVal stPw As String, _
ByVal stZt As String, ByVal stNr As String, ByVal stFj As String, ByVal stE1 As String)
'功能:发邮件
'参数:stMail --- 发送方邮箱全名称
' stRx --- 发送方邮箱后缀服务器
' stPw --- 发送方邮箱密码
' stZt --- 邮件主题
' stNr --- 邮件内容
' stFj --- 邮件附件
' stE1 --- 主要接收方邮箱完整帐号
'示例:SendEmail "88888888","QQ.COM","123456","报表","请于2015年/6/10前修改后上报。","d:\报表.xls","4444444@QQ.COM"
Dim vCDO As Object
Dim stul As String
stul = "http://schemas.microsoft.com/cdo/configuration/" '微软服务器网址
Set vCDO = CreateObject("CDO.Message")
vCDO.From = stUs & "@" & stRx '发送方邮箱完整帐号
vCDO.SubJect = stZt '邮件主题
vCDO.Textbody = stNr '邮件内容
vCDO.AddAttachment stFj '邮件附件
vCDO.to = stE1 '主要接收方邮箱完整帐号
With vCDO.Configuration.Fields
.Item(stul & "smtpserver") = "smtp." & stRx 'SMTP服务器地址
.Item(stul & "smtpserverport") = 25 'SMTP服务器端口
.Item(stul & "sendusing") = 2 '发送端口
.Item(stul & "smtpauthenticate") = 1 '
.Item(stul & "sendusername") = stUs '发送方邮箱名称
.Item(stul & "sendpassword") = stPw '发送方邮箱密码
.Update
End With
vCDO.Send
Set vCDO = Nothing
End Sub
Sub UpdateQuery(ByVal queryName As String, ByVal strSql As String)
'功能:动态生成查询
Dim Qdef As QueryDef
If DCount("*", "MSysObjects", "type=5 and name='" & queryName & "'") = 0 Then
Set Qdef = CurrentDb.CreateQueryDef(queryName)
Else
Set Qdef = CurrentDb.QueryDefs(queryName)
End If
Qdef.SQL = strSql
Set Qdef = Nothing
End Sub
搞不定,我放弃了。
总记录:7篇 页次:1/1 9 1 :