VBA - email an X% zoom screenshot of an open Word document, with file also attached

[Dont Call me Betty]

Followed below instructions for the below code, only for step 7 there were no "Microsoft Outlook Object Library", so used "Microsoft Outlook 16.0 Object Library "

But nothing happens when code runs, at all, not even an error.

Using below code as a next best thing to figuring out how to incorporate that part into VBA I run in Excel to generate that word file.

So, added custom button to QAT in Word for below code -- will have to just make another click. Need it to work for any active word file, not just for a specific one.

Objective is to have an X% zoom screenshot of an open Word document to be placed into a generated email, with that Word document also attached.

Option Explicit
 
Sub eMailActiveDocument()
    
    Dim OL              As Object
    Dim EmailItem       As Object
    Dim Doc             As Document
    
    Application.ScreenUpdating = False
    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(olMailItem)
    Set Doc = ActiveDocument
    Doc.Save
    With EmailItem
        .Subject = "Insert Subject Here"
        .Body = "Insert message here" & vbCrLf & _
        "Line 2" & vbCrLf & _
        "Line 3"
        .To = "User@Domain.Com"
        .Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
        .Attachments.Add Doc.FullName
'        .Send
    End With
    
    Application.ScreenUpdating = True
    
    Set Doc = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
    
End Sub

How to use:

Open your Word document. Press Alt + F11 to open VBE. Double click where is says "ThisDocument" on the project explorer. Insert-Module. Paste the code there in the window at right. Modify the code lines containing .Subject, .Body .To, and .Importance as needed. Set a reference to the Microsoft Outlook Object Library (Tools | References). Close VBE (Alt + Q or press the X in the top right hand corner). Save the file.

Test the code:

Go to Tools-Macro-Macros and double-click eMailActiveDocument.

 

[Domenic]

You'll need to uncomment .Send in order to actually send the email. However, while testing the code, you should replace it with .Display. Once you're satisfied that everything is fine, then you can replace it with .Send. Also, there are a few things to consider.

First, since you're using early binding when setting a reference to the Microsoft Outlook Object Library, you can declare your variables as specific objects, instead of generic objects...

    Dim OL              As Outlook.Application
    Dim EmailItem       As Outlook.MailItem
    Dim Doc             As Word.Document

Secondly, with early binding, you can use the keyword New to create an instance of the Outlook application...

    Set OL = New Outlook.Application

Therefore, assuming that the screenshot is taken before running the code, you can amend it as follows...

Option Explicit
 
Sub eMailActiveDocument()
    
    Dim OL              As Outlook.Application
    Dim EmailItem       As Outlook.MailItem
    Dim Doc             As Word.Document
    
    Application.ScreenUpdating = False
    
    Set OL = New Outlook.Application
    Set EmailItem = OL.CreateItem(olMailItem)
    Set Doc = ActiveDocument
    Doc.Save
    With EmailItem
        .Display 'required when using the WordEditor
        .To = "User@Domain.Com"
        .Subject = "Insert Subject Here"
        .Body = "Insert message here" & vbCrLf & _
        "Line 2" & vbCrLf & _
        "Line 3"
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
        .Attachments.Add Doc.FullName
'        .Send
    End With
    
    Application.ScreenUpdating = True
    
    Set Doc = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
    
End Sub

Once you've tested it, you can uncomment .Send so that the email actually gets sent. So you would replace...

'        .Send

with

         .Send

Hope this helps!

 

[Dont Call me Betty]

You'll need to uncomment .Send in order to actually send the email. However, while testing the code, you should replace it with .Display. Once you're satisfied that everything is fine, then you can replace it with .Send. Also, there are a few things to consider.

First, since you're using early binding when setting a reference to the Microsoft Outlook Object Library, you can declare your variables as specific objects, instead of generic objects...

    Dim OL              As Outlook.Application
    Dim EmailItem       As Outlook.MailItem
    Dim Doc             As Word.Document

Secondly, with early binding, you can use the keyword New to create an instance of the Outlook application...

    Set OL = New Outlook.Application

Therefore, assuming that the screenshot is taken before running the code, you can amend it as follows...

Option Explicit
 
Sub eMailActiveDocument()
   
    Dim OL              As Outlook.Application
    Dim EmailItem       As Outlook.MailItem
    Dim Doc             As Word.Document
   
    Application.ScreenUpdating = False
   
    Set OL = New Outlook.Application
    Set EmailItem = OL.CreateItem(olMailItem)
    Set Doc = ActiveDocument
    Doc.Save
    With EmailItem
        .Display 'required when using the WordEditor
        .To = "User@Domain.Com"
        .Subject = "Insert Subject Here"
        .Body = "Insert message here" & vbCrLf & _
        "Line 2" & vbCrLf & _
        "Line 3"
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .Importance = olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
        .Attachments.Add Doc.FullName
'        .Send
    End With
   
    Application.ScreenUpdating = True
   
    Set Doc = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
   
End Sub

Once you've tested it, you can uncomment .Send so that the email actually gets sent. So you would replace...

'        .Send

with

         .Send

Hope this helps!

Hi,

1. The instructions I followed from the bottom of my original post only allow for the macro to be available within a specific word file, whereas I need it to be available for any active Word file. What do I need to do to make that happen? I have a custom button on the Word's QAT to trigger the macro.
2. Your code works, as you have mentioned -- provided the screenshot is taken manually, prior to running the code. Otherwise it does not even attach the file. Is there a way to automate screenshot taking & placement along with attaching the file? It's always just a one page document.
3. When I added your code to my Excel file, calling it at the end of another code that generates that Word file, I get the below picture error. I realize I got couple of things going here, having a separate code and button to click in Word is a Plan B, doing it all as part of the same code in Excel is a preference.
4. I'd also like for the word file to be named with value of a specific cell in that Excel file with the code.

 

[Domenic]

Can you please confirm from which application the macro will be run? From within Excel or Word?

 

[Dont Call me Betty]

Can you please confirm from which application the macro will be run? From within Excel or Word?

From within Excel - ideally

 

[Domenic]

In that case, it does change things. I'll post back with the amended code as soon as I get a chance.

 

[Domenic]

The following code uses late binding, so there's no need to set any references. The code first checks to make sure that an active Word document exists. If not, it exits the sub. Otherwise it continues with the rest of the code. Then it saves the Word document to the same folder as the active document. If the active Word document is unsaved, it saves it to the current directory. And it names the document after the value in cell A1, from Sheet1 in the workbook running the code (change this accordingly).

Option Explicit
 
Sub eMailActiveDocument()
  
    Dim OL                  As Object 'Outlook.Application
    Dim EmailItem           As Object 'Outlook.MailItem
    Dim Doc                 As Object 'Word.Document
    Dim SaveToFolderName    As String
    Dim SaveAsFileName      As String
  
    Application.ScreenUpdating = False
  
    On Error Resume Next
    Set Doc = GetObject(, "Word.Application").ActiveDocument
    If Doc Is Nothing Then
        MsgBox "No Word document found!", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
  
    SaveToFolderName = Doc.Path
    If Len(SaveToFolderName) = 0 Then
        SaveToFolderName = CurDir
    End If
  
    SaveAsFileName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value 'change the sheet name and cell reference accordingly
  
    Doc.SaveAs Filename:=SaveToFolderName & "\" & SaveAsFileName, FileFormat:=16 'wdFormatDocumentDefault (ie .docx)
  
    Doc.Windows(1).WindowState = 1 'wdWindowStateMaximize (make sure Word document isn't minimized)
  
    AppActivate Doc.Windows(1).Caption
  
    PauseMacro 3 'seconds (to make sure that Word document is activated)
  
    PrintCurrentApplicationWindow
  
    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(0) 'olMailItem
  
    With EmailItem
        .Display 'required when using the WordEditor
        .To = "User@Domain.Com"
        .Subject = "Insert Subject Here"
        .Body = "Insert message here" & vbCrLf & _
        "Line 2" & vbCrLf & _
        "Line 3"
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .Importance = 1 'olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
        .Attachments.Add Doc.FullName
'        .Send
    End With
  
    Application.ScreenUpdating = True
  
    Set Doc = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
  
End Sub

Private Sub PrintCurrentApplicationWindow()

    Application.SendKeys "%{1068}", True
  
    DoEvents
  
End Sub

Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
  
    Do
        DoEvents
    Loop Until Timer > endTime
  
End Sub

Hope this helps!

 

[Dont Call me Betty]

The following code uses late binding, so there's no need to set any references. The code first checks to make sure that an active Word document exists. If not, it exits the sub. Otherwise it continues with the rest of the code. Then it saves the Word document to the same folder as the active document. If the active Word document is unsaved, it saves it to the current directory. And it names the document after the value in cell A1, from Sheet1 in the workbook running the code (change this accordingly).

Option Explicit
 
Sub eMailActiveDocument()
 
    Dim OL                  As Object 'Outlook.Application
    Dim EmailItem           As Object 'Outlook.MailItem
    Dim Doc                 As Object 'Word.Document
    Dim SaveToFolderName    As String
    Dim SaveAsFileName      As String
 
    Application.ScreenUpdating = False
 
    On Error Resume Next
    Set Doc = GetObject(, "Word.Application").ActiveDocument
    If Doc Is Nothing Then
        MsgBox "No Word document found!", vbExclamation
        Exit Sub
    End If
    On Error GoTo 0
 
    SaveToFolderName = Doc.Path
    If Len(SaveToFolderName) = 0 Then
        SaveToFolderName = CurDir
    End If
 
    SaveAsFileName = ThisWorkbook.Worksheets("Sheet1").Range("A1").Value 'change the sheet name and cell reference accordingly
 
    Doc.SaveAs Filename:=SaveToFolderName & "\" & SaveAsFileName, FileFormat:=16 'wdFormatDocumentDefault (ie .docx)
 
    Doc.Windows(1).WindowState = 1 'wdWindowStateMaximize (make sure Word document isn't minimized)
 
    AppActivate Doc.Windows(1).Caption
 
    PauseMacro 3 'seconds (to make sure that Word document is activated)
 
    PrintCurrentApplicationWindow
 
    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(0) 'olMailItem
 
    With EmailItem
        .Display 'required when using the WordEditor
        .To = "User@Domain.Com"
        .Subject = "Insert Subject Here"
        .Body = "Insert message here" & vbCrLf & _
        "Line 2" & vbCrLf & _
        "Line 3"
        With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
        End With
        .Importance = 1 'olImportanceNormal 'Or olImprotanceHigh Or olImprotanceLow
        .Attachments.Add Doc.FullName
'        .Send
    End With
 
    Application.ScreenUpdating = True
 
    Set Doc = Nothing
    Set OL = Nothing
    Set EmailItem = Nothing
 
End Sub

Private Sub PrintCurrentApplicationWindow()

    Application.SendKeys "%{1068}", True
 
    DoEvents
 
End Sub

Sub PauseMacro(ByVal secs As Long)

    Dim endTime As Single
    endTime = Timer + secs
 
    Do
        DoEvents
    Loop Until Timer > endTime
 
End Sub

Hope this helps!

Hi,
Code gives below error:

on below line

 

[Domenic]

Try running the code again. This time, though, when the error occurs, click on Debug. Then enter the following line of code in the Immediate Window (Ctrl-G), and press ENTER...

? SaveToFolderName & "\" & SaveAsFileName

What does it return? Does it return the expected path and filename?