Thread: [Solved] Outlook 2010 Read Receipts
View Single Post
 
Old 01-23-2015, 12:09 AM
gmayor's Avatar
gmayor gmayor is offline Windows 7 64bit Office 2010 32bit
Expert
 
Join Date: Aug 2014
Posts: 4,106
gmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud ofgmayor has much to be proud of
Default

You can use the following macro in either Word or Excel. 'MacroWord' and 'MacroExcel' show how to call it from those applications with the data you wish to supply.

You can of course use named files instead of the activefiles.

Re-instate the '.Send' command when you are happy it works for you.

Code:
Sub MacroWord()
    Dim strMessageBody As String
    strMessageBody = "This is the body of the message." & vbCr & "etc"
    ActiveDocument.Save 'it is important to save the item you are sending - here the active document
    
    Send_As_Mail "someone@somewhere.com", _
                 "Attachment: " & ActiveDocument.name, _
                 strMessageBody, _
                 ActiveDocument.FullName
End Sub

Sub MacroExcel()
    Dim strMessageBody As String
    strMessageBody = "This is the body of the message." & vbCr & "etc"
    ActiveWorkbook.Save 'it is important to save the item you are sending - here the active workbook
    
    Send_As_Mail "someone@somewhere.com", _
                 "Attachment: " & ActiveWorkbook.Name, _
                 strMessageBody, _
                 ActiveWorkbook.FullName
End Sub

Public Sub Send_As_Mail(strTo As String, _
                 strSubject As String, _
                 strMessage As String, _
                 Optional strAttachment As String)

' send the document as an attachment _
  in an Outlook Email message
Dim olApp As Object
Dim olInsp As Object
Dim oItem As Object
Dim oDoc As Object
Dim orng As Object

    On Error Resume Next
    
    'Get Outlook if it's running
    Set olApp = GetObject(, "Outlook.Application")

    'Outlook wasn't running, start it from code
    If Err <> 0 Then
        Set olApp = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0

    'Create a new mailitem
    Set oItem = olApp.CreateItem(0)

    With oItem
        .to = strTo
        .Subject = strSubject
        If Not strAttachment = "" Then .Attachments.Add strAttachment
        .BodyFormat = 2        'olFormatHTML
        Set olInsp = .GetInspector
        Set oDoc = olInsp.WordEditor
        Set orng = oDoc.Range(0, 0)
        orng.Text = strMessage & vbCr
        .Display
        '.Send 'restore fter testing
    End With
lbl_Exit:
    Set oItem = Nothing
    Set olApp = Nothing
    Set olInsp = Nothing
    Set oDoc = Nothing
    Set orng = Nothing
    Exit Sub
End Sub
__________________
Graham Mayor - MS MVP (Word) (2002-2019)
Visit my web site for more programming tips and ready made processes www.gmayor.com
Reply With Quote