|
|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
发送邮件无警告弹出函数：
Public Function FnSendMailSafe(strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strMessageBody As String, _
Optional strAttachments As String) As Boolean
' (c) 2005 Wayne Phillips - Written 07/05/2005
' Last updated 26/03/2008 - Bugfix for empty recipient strings
' http://www.everythingaccess.com
'
' You are free to use this code within your application(s)
' as long as the copyright notice and this message remains intact.
On Error GoTo ErrorHandler:
Dim MAPISession As Outlook.NameSpace
Dim MAPIFolder As Outlook.MAPIFolder
Dim MAPIMailItem As Outlook.MailItem
Dim oRecipient As Outlook.Recipient
Dim TempArray() As String
Dim varArrayItem As Variant
Dim strEmailAddress As String
Dim strAttachmentPath As String
Dim blnSuccessful As Boolean
'Get the MAPI NameSpace object
Set MAPISession = Application.Session
If Not MAPISession Is Nothing Then
'Logon to the MAPI session
MAPISession.Logon , , True, False
'Create a pointer to the Outbox folder
Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
If Not MAPIFolder Is Nothing Then
'Create a new mail item in the "Outbox" folder
Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
If Not MAPIMailItem Is Nothing Then
With MAPIMailItem
'Create the recipients TO
TempArray = Split(strTo, ";")
For Each varArrayItem In TempArray
strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olTo
Set oRecipient = Nothing
End If
Next varArrayItem
'Create the recipients CC
TempArray = Split(strCC, ";")
For Each varArrayItem In TempArray
strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olCC
Set oRecipient = Nothing
End If
Next varArrayItem
'Create the recipients BCC
TempArray = Split(strBCC, ";")
For Each varArrayItem In TempArray
strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olBCC
Set oRecipient = Nothing
End If
Next varArrayItem
'Set the message SUBJECT
.Subject = strSubject
'Set the message BODY (HTML or plain text)
If StrComp(Left(strMessageBody, 6), "<HTML>", _
vbTextCompare) = 0 Then
.HTMLBody = strMessageBody
Else
.Body = strMessageBody
End If
'Add any specified attachments
' TempArray = Split(strAttachments, ";")
' For Each varArrayItem In TempArray
'
' strAttachmentPath = Trim(varArrayItem)
' If Len(strAttachmentPath) > 0 Then
' .Attachments.Add strAttachmentPath
' End If
'
' Next varArrayItem
.Send 'The message will remain in the outbox if this fails
Set MAPIMailItem = Nothing
End With
End If
Set MAPIFolder = Nothing
End If
MAPISession.Logoff
End If
'If we got to here, then we shall assume everything went ok.
blnSuccessful = True
ExitRoutine:
Set MAPISession = Nothing
FnSendMailSafe = blnSuccessful
Exit Function
ErrorHandler:
MsgBox "An error has occured in the user defined Outlook VBA function " & _
"FnSendMailSafe()" & vbCrLf & vbCrLf & _
"Error Number: " & CStr(Err.Number) & vbCrLf & _
"Error Description: " & Err.Description, _
vbApplicationModal + vbCritical
Resume ExitRoutine
End Function
接收邮件无警告弹出函数：
Public Function GetEmailContent() As Integer
On Error GoTo ErrorHandler:
Dim MAPISession As Outlook.NameSpace
Dim MAPIFolder As Outlook.MAPIFolder
Dim MAPIMailItem As Outlook.MailItem
Dim oRecipient As Outlook.Recipient
Dim TempArray() As String
Dim varArrayItem As Variant
Dim strEmailAddress As String
Dim strAttachmentPath As String
Dim blnSuccessful As Boolean
'Get the MAPI NameSpace object
Set MAPISession = Application.Session
If Not MAPISession Is Nothing Then
'Logon to the MAPI session
MAPISession.Logon , , True, False
'Create a pointer to the Outbox folder
Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderInbox)
If Not MAPIFolder Is Nothing Then
'Create a new mail item in the "Inbox" folder
Dim vItem As Object
Dim strname As String
If MAPIFolder.UnReadItemCount > 0 Then
For Each vItem In MAPIFolder.Items
If vItem.UnRead = True Then
strname = vItem.Subject
strname = Replace(strname, "*", "_")
strname = Replace(strname, "\", "_")
strname = Replace(strname, "/", "_")
strname = Replace(strname, "$", "_")
strname = Replace(strname, "%", "_")
strname = Replace(strname, "!", "_")
strname = Replace(strname, "~", "_")
strname = Replace(strname, "(", "_")
strname = Replace(strname, ")", "_")
strname = Replace(strname, "+", "_")
strname = Replace(strname, ":", "_")
vItem.SaveAs "D:\" & strname & ".txt", olTXT
vItem.UnRead = False
End If
Next
End If
Set MAPIFolder = Nothing
End If
MAPISession.Logoff
End If
'If we got to here, then we shall assume everything went ok.
blnSuccessful = True
ExitRoutine:
Set MAPISession = Nothing
'FnSendMailSafe = blnSuccessful
Exit Function
ErrorHandler:
MsgBox "An error has occured in the user defined Outlook VBA function " & _
"FnSendMailSafe()" & vbCrLf & vbCrLf & _
"Error Number: " & CStr(Err.Number) & vbCrLf & _
"Error Description: " & Err.Description, _
vbApplicationModal + vbCritical
Resume ExitRoutine
End Function
如果遇到无法使用Outlook的Macro的情况，请在tools->Macro->Security->设置安全级别为low. |
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2010-6-4 13:55
