Copy text from an embedded word in excel, using VBA code

[Hijikatat]

Hello guys,

I am new here, and I am new in VBA coding too.

So i have embedded a word document in an excel file, and using VBA, i would like to extract the text from it and copy it in a cell of the excel, as well as the format of the text.
I have been going around few forums, but haven't found a solution to do this. I read that the word file can be taken as an OLEObject, but how do i extract what's in there?

The reason behind that is that I'd like to implement a code to send email using VBA. The body of the email would be taken from that word document.
For the email code i have been using this code which works pretty well, from :https://www.wallstreetmojo.com/vba-send-email-from-excel/

Sub SendEmail_Example1()
 
Dim EmailApp As Outlook.Application
Dim Source As String
Set EmailApp = New Outlook.Application
 
Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)
 
EmailItem.To = "Hi@gmail.com"
EmailItem.CC = "hello@gmail.com"
EmailItem.BCC = "hhhh@gmail.com"
EmailItem.Subject = "Test Email From Excel VBA"
EmailItem.HTMLBody = "Hi," & vbNewLine & vbNewLine & "This is my first email from Excel" & _
vbNewLine & vbNewLine & _
"Regards," & vbNewLine & _
"VBA Coder"
Source = ThisWorkbook.FullName
EmailItem.Attachments.Add Source
 
EmailItem.Send
 
End Sub

Then I tried to use what was in this doc : Redirecting

But the wDoc.COntent.copy doesn't seem to work for me.

Sub Test()
  Dim Oo As OLEObject
  Dim wDoc As Object 'Word.Document
 
  'Search for the embedded Word document
  For Each Oo In ActiveSheet.OLEObjects
    If InStr(1, Oo.progID, "Word.Document", vbTextCompare) > 0 Then
      'Open the embedded document
      Oo.Verb xlVerbPrimary
      'Get the document inside
      Set wDoc = Oo.Object
     
      'Copy the contents to cell A1
      wDoc.Content.Copy
      Range("A1").PasteSpecial xlPasteValues
     
      'Select any cell to close the document
      Range("A1").Select
      'Done
      Exit For
    End If
  Next
End Sub

If you guys ave any idea how I could manage to do that, would be very grateful!

Thanks

 

[Domenic]

But the wDoc.COntent.copy doesn't seem to work for me.

What happens exactly?

I've tested your code, and it seems to work. It opens the embedded Word document, copies its content, and then pastes the content as values starting at cell A1 in the active worksheet.

 

[Hijikatat]

Hey Domenic,

Thanks a lot for your reply.
My embedded word must have been corrupted, so i removed it and cretaed another one, now i get the text.

There are still two things i am trying to figure out:
-Keep the format of the word (bold, line breaks etc)
-if there is n line breaks in the word, then the code will break the text into n different cells, and i would like to be all in one...

This is my code

Sub SendEmail()

Dim EmailApp As Outlook.Application 'outlook app
Set EmailApp = New Outlook.Application 'laucnh outlook app

Dim EmailItem As Outlook.MailItem 'email item
Set EmailItem = EmailApp.CreateItem(olMailItem) 'launch new Outlook email


Dim Oo As OLEObject
Dim wDoc As Object 'Word.Document

 'Search for the embedded Word document
  For Each Oo In ActiveSheet.OLEObjects
    If InStr(1, Oo.progID, "Word.Document", vbTextCompare) > 0 Then
      'Open the embedded document
      Oo.Verb xlVerbPrimary
      'Get the document inside
      Set wDoc = Oo.Object
      
      'Copy the contents to cell A1
      wDoc.Content.Copy
      Worksheets("emailText").Range("M1").PasteSpecial xlPasteValues
      
      'Select any cell to close the document
      Range("A1").Select
      'Done
      Exit For
    End If
  Next


Dim recipients As String
Dim CC As String
Dim subject As String


recipients = Worksheets("emailSettings").Range("B3")
CC = Worksheets("emailSettings").Range("C3")
subject = Worksheets("emailSettings").Range("C3")

EmailItem.To = recipients
EmailItem.CC = CC
EmailItem.subject = subject
EmailItem.Body = Worksheets("emailText").Range("M1")



EmailItem.Send

End Sub

and this is how excel puts it into cells (seems the website won't allow me to upload the file)

 

[Domenic]

In that case, since you want to keep the formatting from the embedded Word document, you can simply copy and paste the contents of the document directly into the email...

Sub SendEmail()

Dim EmailApp As Outlook.Application 'outlook app
Set EmailApp = New Outlook.Application 'laucnh outlook app

Dim EmailItem As Outlook.MailItem 'email item
Set EmailItem = EmailApp.CreateItem(olMailItem) 'launch new Outlook email


Dim Oo As OLEObject
Dim wDoc As Object 'Word.Document

 'Search for the embedded Word document
  For Each Oo In ActiveSheet.OLEObjects
    If InStr(1, Oo.progID, "Word.Document", vbTextCompare) > 0 Then
      'Open the embedded document
      Oo.Verb xlVerbPrimary
      'Get the document inside
      Set wDoc = Oo.Object
      'Copy the contents to cell A1
      wDoc.Content.Copy
      'Done
      Exit For
    End If
  Next


Dim recipients As String
Dim CC As String
Dim subject As String


recipients = Worksheets("emailSettings").Range("B3")
CC = Worksheets("emailSettings").Range("C3")
subject = Worksheets("emailSettings").Range("C3")

With EmailItem
    .Display 'needed when the Word editor is used
    .To = recipients
    .CC = CC
    .subject = subject
    With .GetInspector.WordEditor
        '.Application.Selection.endkey unit:=6 'wdStory
        '.Application.Selection.TypeParagraph
        '.Application.Selection.TypeParagraph
        .Application.Selection.Paste
    End With
    '.Send
End With

End Sub

Hope this helps!

 

[Hijikatat]

Thanks a lot, it seems to work, now i get the good format in the email.


So the broad idea is that i get the text from the word, but before the bodytext i'd like to get the different greetings, as in the picture below.

Therefore, the reason i want to have it in a variable is because i would like to do a for loop, that would take for each row:
-take the recipient list (in the picture below XX), the cc (XX) list. Take the greeting (Hi all) and concatenate the text from the word and send the email
-then for the second row, reset all these lists and take the list from the corresponding row: XX2, Dear ...

the way i saw was to do something in the line of:

dim i as Integer
dim mailbody as string 'get the word content

for i = 3 to 10
recipient= Worksheets("emailSettings").Cells(i,2)
CC=Worksheets("emailSettings").Cells(i,3)
EmailItem.Body= Worksheets("emailSettings").Cells(i,4) & vbNewLine & vbNewLine & mailbody

'then reset everything and go to the next i
end if
next i

Using your method, as we do not use any variable to store the recipient and CC list, I am wondering if there is any way to reset it each iteration and concatenate the greeting and the ".Application.Selection.Paste"

With EmailItem
    .Display 'needed when the Word editor is used
    .To = recipients
    .CC = CC
    .subject = subject
    With .GetInspector.WordEditor
        '.Application.Selection.endkey unit:=6 'wdStory
        '.Application.Selection.TypeParagraph
        '.Application.Selection.TypeParagraph
        .Application.Selection.Paste
    End With
    '.Send
End With

Thanks again for your great help!

 

[Domenic]

Try the following code, which loops through each row, starting from Row 3 until the last row containing data. For each row, a new email is created based on the corresponding data, and then the email is displayed. After you've tested it and everything seems fine, you can uncomment .Send so that emails can actually be sent.

Note that that I have assumed that the workbook running the code contains your emailSettings worksheet. Also, if the emailSettings worksheet contains the embedded Word document , you should replace...

For Each Oo In ActiveSheet.OLEObjects

with

For Each Oo In ThisWorkbook.Worksheets("emailSettings").OLEObjects

Here's the code . . .

Sub SendEmails()

    Dim Oo As OLEObject
    Dim wDoc As Object 'Word.Document
    
    'Search for the embedded Word document
     For Each Oo In ActiveSheet.OLEObjects
       If InStr(1, Oo.progID, "Word.Document", vbTextCompare) > 0 Then
         'Open the embedded document
         Oo.Verb xlVerbPrimary
         'Get the document inside
         Set wDoc = Oo.Object
         'Copy the contents to cell A1
         wDoc.Content.Copy
         'Done
         Exit For
       End If
     Next
      
     If wDoc Is Nothing Then
        MsgBox "No embedded Word document found!", vbExclamation
        Exit Sub
     End If
        
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Worksheets("emailSettings")
    
    Dim lastRow As Long
    With sourceWorksheet
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With
    
    Dim EmailApp As Outlook.Application 'outlook app
    Set EmailApp = New Outlook.Application 'laucnh outlook app
    
    Dim EmailItem As Outlook.MailItem 'email item
    Dim recipient As String
    Dim cc As String
    Dim subject As String
    Dim greetings As String
    Dim i As Long
    
    For i = 3 To lastRow
        recipient = sourceWorksheet.Cells(i, 2).Value
        cc = sourceWorksheet.Cells(i, 3).Value
        subject = " . . . " 'specify the cell from which the subject is retrieved
        greetings = sourceWorksheet.Cells(i, 4).Value
        Set EmailItem = EmailApp.CreateItem(olMailItem) 'launch new Outlook email
        With EmailItem
            .Display
            .To = recipient
            .cc = cc
            .subject = subject
            .Body = greetings
            With .GetInspector.WordEditor
                .Application.Selection.endkey unit:=6 'wdStory
                .Application.Selection.TypeParagraph
                .Application.Selection.TypeParagraph
                .Application.Selection.Paste
            End With
            '.Send
        End With
        DoEvents
    Next i

End Sub

 

[Hijikatat]

You're the man, thank you so much for your help

Maybe one last question, do you know if i can modify the format of the greetings from VBA, so it matches the email body?

Thanks again,

 

[Domenic]

Does this help?

Sub SendEmails()

    Dim Oo As OLEObject
    Dim wDoc As Object 'Word.Document
    
    'Search for the embedded Word document
     For Each Oo In ActiveSheet.OLEObjects
       If InStr(1, Oo.progID, "Word.Document", vbTextCompare) > 0 Then
         'Open the embedded document
         Oo.Verb xlVerbPrimary
         'Get the document inside
         Set wDoc = Oo.Object
         'Done
         Exit For
       End If
     Next
      
     If wDoc Is Nothing Then
        MsgBox "No embedded Word document found!", vbExclamation
        Exit Sub
     End If
        
    Dim sourceWorksheet As Worksheet
    Set sourceWorksheet = ThisWorkbook.Worksheets("emailSettings")
    
    Dim lastRow As Long
    With sourceWorksheet
        lastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
    End With
    
    Dim EmailApp As Outlook.Application 'outlook app
    Set EmailApp = New Outlook.Application 'laucnh outlook app
    
    Dim EmailItem As Outlook.MailItem 'email item
    Dim recipient As String
    Dim cc As String
    Dim subject As String
    Dim i As Long
    
    For i = 3 To lastRow
        recipient = sourceWorksheet.Cells(i, 2).Value
        cc = sourceWorksheet.Cells(i, 3).Value
        subject = " . . . " 'specify the cell from which the subject is retrieved
        Set EmailItem = EmailApp.CreateItem(olMailItem) 'launch new Outlook email
        With EmailItem
            .Display
            .To = recipient
            .cc = cc
            .subject = subject
            With .GetInspector.WordEditor
                wDoc.Content.Copy
                .Activate
                .Application.Selection.Paste
                sourceWorksheet.Cells(i, 4).Copy
                .Application.Selection.HomeKey Unit:=6 'wdStory
                .Application.Selection.PasteSpecial DataType:=2 'wdPasteText
                .Application.Selection.TypeParagraph
                .Application.Selection.TypeParagraph
            End With
            '.Send
        End With
        DoEvents
    Next i
    
    Application.CutCopyMode = False

End Sub

 

[Hijikatat]

It does... Thank you sir you're the best!

 

[Domenic]

You're very welcome, cheers!