Public Function SendMailAttachment(ByVal strFile As String) As Boolean
On Error GoTo ErrHandler
Dim ol As Outlook.Application
Dim msg As Outlook.MailItem
Dim fldOut As Outlook.MAPIFolder
Dim cbrMenu As Office.CommandBar
Dim cbrTools As Office.CommandBarPopup
Dim cbrSend As Office.CommandBarControl
Dim lngCount As Long
Dim blnOpen As Boolean
If Dir(strFile) <> "" Then
On Error Resume Next
Set ol = GetObject(, "Outlook.Application")
If Err = 0 Then
blnOpen = True
Else
Set ol = CreateObject("Outlook.Application")
End If
On Error GoTo ErrHandler
Set msg = ol.CreateItem(olMailItem)
With msg
.To = "pnorton@symantec.om"
.Attachments.Add strFile
.Subject = "Please see attached file"
.Body = "Open attached file to view virus" & vbCrLf
.Send 'This just places mail in outbox
End With
'open an explorer
Call ol.Session.GetDefaultFolder(olFolderOutbox).GetExplorer.ShowPane(olFolderList, False)
'count items in outbox
Set fldOut = ol.Session.GetDefaultFolder(olFolderOutbox)
lngCount = fldOut.Items.Count
'capture the send action menu
Set cbrMenu = ol.ActiveExplorer.CommandBars("Menu Bar")
Set cbrTools = cbrMenu.Controls("Tools")
Set cbrSend = cbrTools.Controls("Send")
'Send now
cbrSend.Execute
If Not blnOpen Then
Do While fldOut.Items.Count >= lngCount
DoEvents
Loop
End If
SendMailAttachment = True
End If
ExitHere:
On Error Resume Next
Set msg = Nothing
Set cbrSend = Nothing
Set cbrTools = Nothing
Set cbrMenu = Nothing
If Not blnOpen Then
ol.Quit
End If
Set fldOut = Nothing
Set ol = Nothing
Exit Function
ErrHandler:
MsgBox "Error (" & Err & ") - " & Err.Description
Resume ExitHere
End Function