Sub sendMailforCheck()
Dim Subj As String
Dim EmailAddr As String, Emailcc As String
Dim msg As String
Dim attachFileName As String
Dim dayMark As String, qjdDeliverNo As String
' qjdDeliverNo = ActiveWorkbook.ActiveSheet.Range("J17").Value
qjdDeliverNo = Evaluate("'C:\Users\huyg\Desktop\[操作.xlsm]日周报'!$J$17")
dayMark = InputBox("请输入日期标识符,格式如:20150808", , Format(Date - 1, "YYYYMMDD"))
Subj = "forcheck" & dayMark & "及配送量"
EmailAddr = "*************"
Emailcc = "******************"
msg = "Hi,All <br /><br />"
msg = msg & "forcheck" & dayMark & ",请查收"
msg = msg & "<br />" & dayMark & "量为:<font color='red'>" & qjdDeliverNo & "</font>"
attachFileName = "E:\03 日报\" & dayMark & "forcheck.xls"
Call sendMailFor(Subj, EmailAddr, Emailcc, msg, attachFileName)
End Sub
Sub sendMailFor(subject As String, EmailAddr As String, Emailcc As String, msg As String, attachFileName As String)
attachFileArr = VBA.Split(attachFileName, "#")
Application.ScreenUpdating = False
'Create Outlook object
Set outlookapp = CreateObject("Outlook.Application")
On Error Resume Next
'Send this Email?
Ans = MsgBox("Send Email To:" & EmailAddr & "?", vbYesNo, "Seng Email?")
If Ans = vbNo Then
Exit Sub
End If
'Create Mail Item and send it
Set MItem = outlookapp.CreateItem(olMailItem) 'olMailItem
With MItem
.BodyFormat = Outlook.OlBodyFormat.olFormatHTML 'olFormatHTML
.To = EmailAddr
.cc = Emailcc
.subject = subject
' .Body = Msg
For i = 0 To UBound(attachFileArr)
.Attachments.Add attachFileArr(i)
Next
.HTMLBody = .HTMLBody & "<p style='font-family:verdana;line-height:1px;margin:1px'><font face='微软雅黑';style='font-size: 14px'>" + _
msg + "</font></p>" '' "<img src='E:\Chart1.png'>Excel <wbr>VBA操作Outlook发送邮件"
.Display
'.Send
' .Save 'to Drafts folder
End With
Application.ScreenUpdating = True
On Error GoTo 0
Set outlookapp = Nothing
' Delete the file
'Kill MyFileName
End Sub
VBA自动发送邮件
最新推荐文章于 2024-06-06 13:20:44 发布