none
Macro SendToKindle: How to copy in one same Word document the Whole bodies of selected (several) Outlook emails? RRS feed

  • Question

  • Hi, I'm trying to create a Outlook VBA macro that allows me to send quickly all emails I want to read later to my Kindle. The thing is Kindle service only adds the attachments of the emails you send to the @kinlde.com address, not the text in them.

    That is why I came up with the idea me to send an email to my @kindle.com address with a Word document attachment where I previously copy-pasted the Email body (without loosing the HTML format) of a single email. And I succeeded. Kindle service automatically converts your .docx to a .azw and preserves images, HTML format, and table of contents if you create one in your doc. That's awesome! Its good, and saves me a great deal of time sending things to Kindle, but I want better. Here it is:

    Public Sub SendtoKindle()
    
    CopyWholeBody
    MailtoKindle
    
    End Sub
    
    
    Sub CopyWholeBody()
    
        Dim itmSelected
        Dim docSelectedBody As Word.Document
         
        Set itmSelected = ActiveExplorer.Selection(1)
        Set docSelectedBody = itmSelected.GetInspector.WordEditor
        
        docSelectedBody.Application.Selection.WholeStory
        docSelectedBody.Application.Selection.Copy
    End Sub
    Sub MailtoKindle()
    
    Dim appWord As New Word.Application
        Dim docNew As Word.Document
        Dim i As Integer
    Dim docName As String
    Dim MsgNew As MailItem
    
    Dim dirAttachmentKindle As String
    Dim Killfile As String
       
           
        Set docNew = appWord.Documents.Add(, , wdNewXMLDocument)
            
        appWord.Visible = False
           
        docName = InputBox("Ingrese el nombre del documento a enviar a Kindle. Este no puede contener signos de puntuación (.,;:/&% etc.)")
           
        appWord.Visible = False
        
        appWord.Selection.PasteAndFormat (wdFormatOriginalFormatting)
        appWord.ChangeFileOpenDirectory "C:\Users\youruser\Documents"
        appWord.ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatXMLDocument
       appWord.ActiveDocument.Close
        
    dirAttachmentKindle = "C:\Users\youruser\Documents" & "\" & docName & ".docx"
       
    Set MsgNew = Application.CreateItem(olMailItem)
    
    'MsgNew.Display
    MsgNew.Attachments.Add (dirAttachmentKindle)
    MsgNew.To = MyKindleEmail
    MsgNew.Subject = docName
    MsgNew.Send
    
    Killfile = dirAttachmentKindle
       
    End Sub
    
    

    As you see, I'm not a pro developer and I know that my code is messy, but it works...

    Now, I would like to develop a macro to copy several whole bodies of selected emails in the explorer window, paste them in one single .docx that would become and attachment of an email to Kindle. I tried, but I'm having problems to copy the body of diferent emails one after the other. Up to now I get X times the body of the first email (X number of selected emails)

    My big problem is how to place in the clipboard different bodies form items from a ActiveExplorer.Selection. How to copy email body 1, the go to word, paste, copy email body 2, go to word, paste, copy email body 3, go to word, paste, copy email body 4... and so on.

    Here is my Sub SeveralMailstoKindle () try. Sorry if it is a mess.

    Sub SeveralMailsToKindle()
    'Test
    'This macro sends all content of the selected emails to @Kindle in a single (.docx) file. Name file will be: "To read later (date)"
    
    Dim myOlExp As Outlook.Explorer
    Dim mySelItems As Outlook.Selection
    Dim objItem As Object
    Dim selMail As MailItem
    Dim appWord As New Word.Application
        Dim docNew As Word.Document
        Dim i As Integer, k As Integer, x As Integer
        Dim tableRange As Word.Range
        
    Dim docName As String
    Dim MsgNew As MailItem
    Dim dteToday As Date
    Dim strDate As String
    Dim dirAttachmentKindle As String
    Dim Killfile As String
    
        dteToday = Now
        docName = "To dead later" & " " & Format(dteToday, "dd-mm-yyyy_h-N")
      
    'opens a new .docx
    
        Set docNew = appWord.Documents.Add
        appWord.Visible = False
        Set myOlExp = Application.ActiveExplorer
        Set mySelItems = myOlExp.Selection
       
    
    'THIS IS THE PART WHERE I CAN'T DO WHAT I WANT.
    'I ALWAYS GET THE BODY OF THE FIRST EMAIL IN THE SELECTION X TIMES.
    'Is there another way to do it?
       
    '*****************************************************
    'Copies bodies from each email in the selection.
    
     For Each objItem In mySelItems
    
        'OR For x = 1 To myOlSel.Count <--I also tried this method.
    
            If objItem.Class = Outlook.OlObjectClass.olMail Then
    
            'Set selMail = myOlSel.Item(x)
    
                Set selMail = objItem
                Set docSelectedBody = selMail.GetInspector.WordEditor
                Set docSelectedBody = Application.ActiveInspector.WordEditor
                docSelectedBody.Application.Selection.WholeStory
                docSelectedBody.Application.Selection.Copy
                appWord.Visible = False
    
    'Pastes Whole Body into Word. Previously it adds a Section Break
    
                appWord.Selection.InsertBreak Type:=wdSectionBreakContinuous
                appWord.Selection.PasteAndFormat (wdFormatOriginalFormatting)
        
    'To cycle between emails in the selection I even came up with something like these googling for a solution.
    
    'Application.ActiveExplorer.RemoveFromSelection (objItem)
    'Application.ActiveExplorer.AddToSelection (objItem)
    
            Else
                MsgBox "The Outlook selection does not appear to be of mail items", vbCritical, "Not Mail"
                Exit For
                Exit Sub
            End If
    
    Next objItem
        'Next x
    '***************************************************
    
    'Asigns Outline Level 1 to all sections' first lines, goes to the top of the .docx, creates the title and the Table of contents.
    
    For k = 1 To docNew.Sections.Count
    appWord.Selection.GoTo What:=wdGoToSection, Count:=k
    appWord.Selection.MoveDown Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    appWord.Selection.ParagraphFormat.OutlineLevel = wdOutlineLevel1
    Next
    'Va al inicio del Doc y le pone el título
    With appWord
    .Selection.GoTo What:=wdGoToLine, Which:=wdGoToFirst, Name:=""
    .Selection.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText
    .Selection.Font.Name = "Times New Roman"
    .Selection.Font.Size = "14"
    .Selection.Font.Color = wdColorBlack
    .Selection.Font.Bold = True
    .Selection.TypeText Text:=docName
    .Selection.TypeParagraph
    .Selection.TypeParagraph
    End With
    
    'Marks the place where ToC goes.
    
    Set tableRange = appWord.Selection.Range
    
    'Creates ToC with other Sub.
    
    CreateTOC True, False, docNew, tableRange
    
    With appWord
        .Selection.ParagraphFormat.OutlineLevel = wdOutlineLevelBodyText
        .Selection.TypeParagraph
        .Selection.TypeParagraph
        .Selection.InsertBreak Type:=wdSectionBreakContinuous
    End With
     
    'Saves the .docx in order to look for it as an email attachment.
    
    appWord.ChangeFileOpenDirectory dirTempDocs
    appWord.ActiveDocument.SaveAs FileName:=docName, FileFormat:=wdFormatXMLDocument
    appWord.ActiveDocument.Close
        
    dirAttachmentKindle = dirTempDocs & "\" & docName & ".docx"
      
    'Creates email and attaches .docx
    
    Set MsgNew = Application.CreateItem(olMailItem)
    MsgNew.Display
    MsgNew.Attachments.Add (dirAttachmentKindle)
    MsgNew.To = "user@kindle.com"
    MsgNew.Subject = docName
    MsgNew.Send
    
    'Eliminates temp .docx
    
    Kill dirAttachmentKindle
    
    End Sub
    
    Sub CreateTOC (blnOutlineYes As Boolean, blnStylesYes As Boolean, ByVal curDoc As Word.Document, ByVal tableRange As Word.Range)
    'if you created some styles you want to include in the TOC add them between the semicolons in AddedStyles' line.
    
    curDoc.TablesOfContents.Add _
     Range:=tableRange, _
     UseFields:=False, _
     UseOutlineLevels:=blnOutlineYes, _
     UseHeadingStyles:=blnStylesYes, _
     AddedStyles:="", _
     LowerHeadingLevel:=3, _
     UpperHeadingLevel:=1, _
     UseHyperlinks:=True, _
     HidePageNumbersInWeb:=True
      
    End Sub


    Can someone help me to get it right? 




    Saturday, October 25, 2014 3:30 PM

Answers

  • I think you will find that the following should work. You included calls to functions that were not present, but I have included sufficient code for it to work. You may use your own code for the TOC if you prefer (or modify this one to get trhe effect you need).


    Option Explicit

    Sub SeveralMailsToKindle()
    'This macro sends all content of the selected emails to @Kindle in a single (.docx) file.
    'Name file will be: "To read later (date)"
    'The macro uses late binding to Word and thus does not need a reference to the Word object library.


    Dim myOlExp As Outlook.Explorer
    Dim mySelItems As Outlook.Selection
    Dim objItem As Object
    Dim selMail As Outlook.MailItem
    Dim appWord As Object
    Dim docNew As Object
    Dim oRng As Object, oNewRange As Object
    Dim i As Integer, k As Integer
    Dim tableRange As Object
    Dim olInsp As Outlook.Inspector
    Dim docSelectedBody As Object
    Dim docName As String
    Dim MsgNew As MailItem
    Dim strDate As String
    Dim dirAttachmentKindle As String
    Const dirTempDocs As String = "C:\Path\" 'change to the required temp path

        docName = "To read later " & Format(Now, "dd-mm-yyyy_h-N")

        'opens a new .docx
        On Error Resume Next
        Set appWord = GetObject(, "Word.Application")
        If Err Then
            Set appWord = CreateObject("Word.Application")
        End If


        Set docNew = appWord.Documents.Add
        appWord.Visible = True
        Set myOlExp = ActiveExplorer
        Set mySelItems = myOlExp.Selection


        '*****************************************************
        'Copies the formatted bodies from each email message

        For Each objItem In ActiveExplorer.Selection
            Set selMail = objItem
            With selMail
                .BodyFormat = olFormatHTML
                Set olInsp = .GetInspector
                .Display
                Set docSelectedBody = olInsp.WordEditor
                Set oRng = docSelectedBody.Range
                oRng.Copy
                Set oNewRange = docNew.Range
                oNewRange.collapse 0 'collapse the range to the end
                oNewRange.PasteAndFormat 16     'wdFormatOriginalFormatting
                oNewRange.collapse 0
                oNewRange.insertbreak Type:=3        'wdSectionBreakContinuous
            End With
            selMail.Close 0
        Next objItem
        'Asigns Outline Level 1 to all sections' first lines, goes to the top of the .docx, creates the title and the Table of contents.

        For k = 1 To docNew.sections.Count
            docNew.sections(k).Range.Paragraphs(1).Range.ParagraphFormat.outlinelevel = 1
        Next k
        
        Set oNewRange = docNew.Range
        oNewRange.collapse 1
        With oNewRange
            .Text = docName & vbCr & vbCr & vbCr
            .ParagraphFormat.outlinelevel = 10 'wdOutlineLevelBodyText
            .Font.Name = "Times New Roman"
            .Font.Size = "14"
            .Font.Color = 0
            .Font.Bold = True
        End With

        'Marks the place where ToC goes.

        Set tableRange = oNewRange.Paragraphs(2).Range

        'Creates ToC with other Sub.
        'CreateTOC True, False, docNew, tableRange

        CreateTOC docNew, oNewRange

        'Saves the .docx in order to look for it as an email attachment.

        appWord.ActiveDocument.SaveAs Filename:=dirTempDocs & docName, FileFormat:=12
        appWord.ActiveDocument.Close 0

        dirAttachmentKindle = dirTempDocs & docName & ".docx"

        'Creates email and attaches .docx

        Set MsgNew = Application.CreateItem(olMailItem)
        With MsgNew
            .Display
            .Attachments.Add dirAttachmentKindle
            .To = "user@kindle.com"
            .Subject = docName
            .sEnd
        End With

        Kill dirAttachmentKindle
        Set appWord = Nothing
        Set docNew = Nothing
        Set oRng = Nothing
        Set oNewRange = Nothing
        Set tableRange = Nothing
        Set objItem = Nothing
        Set selMail = Nothing
    End Sub

    Sub CreateTOC(oDoc As Object, oRng As Object)
        With oDoc
            .TablesOfContents.Add Range:=oRng, _
                                  RightAlignPageNumbers:=True, _
                                  UseHeadingStyles:=True, _
                                  UpperHeadingLevel:=1, _
                                  LowerHeadingLevel:=3, _
                                  IncludePageNumbers:=True, _
                                  AddedStyles:="", _
                                  UseHyperlinks:=True, _
                                  HidePageNumbersInWeb:=True, _
                                  UseOutlineLevels:=True
            .TablesOfContents(1).TabLeader = 1
            .TablesOfContents.Format = 0
        End With
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Sunday, October 26, 2014 6:31 AM

All replies

  • I think you will find that the following should work. You included calls to functions that were not present, but I have included sufficient code for it to work. You may use your own code for the TOC if you prefer (or modify this one to get trhe effect you need).


    Option Explicit

    Sub SeveralMailsToKindle()
    'This macro sends all content of the selected emails to @Kindle in a single (.docx) file.
    'Name file will be: "To read later (date)"
    'The macro uses late binding to Word and thus does not need a reference to the Word object library.


    Dim myOlExp As Outlook.Explorer
    Dim mySelItems As Outlook.Selection
    Dim objItem As Object
    Dim selMail As Outlook.MailItem
    Dim appWord As Object
    Dim docNew As Object
    Dim oRng As Object, oNewRange As Object
    Dim i As Integer, k As Integer
    Dim tableRange As Object
    Dim olInsp As Outlook.Inspector
    Dim docSelectedBody As Object
    Dim docName As String
    Dim MsgNew As MailItem
    Dim strDate As String
    Dim dirAttachmentKindle As String
    Const dirTempDocs As String = "C:\Path\" 'change to the required temp path

        docName = "To read later " & Format(Now, "dd-mm-yyyy_h-N")

        'opens a new .docx
        On Error Resume Next
        Set appWord = GetObject(, "Word.Application")
        If Err Then
            Set appWord = CreateObject("Word.Application")
        End If


        Set docNew = appWord.Documents.Add
        appWord.Visible = True
        Set myOlExp = ActiveExplorer
        Set mySelItems = myOlExp.Selection


        '*****************************************************
        'Copies the formatted bodies from each email message

        For Each objItem In ActiveExplorer.Selection
            Set selMail = objItem
            With selMail
                .BodyFormat = olFormatHTML
                Set olInsp = .GetInspector
                .Display
                Set docSelectedBody = olInsp.WordEditor
                Set oRng = docSelectedBody.Range
                oRng.Copy
                Set oNewRange = docNew.Range
                oNewRange.collapse 0 'collapse the range to the end
                oNewRange.PasteAndFormat 16     'wdFormatOriginalFormatting
                oNewRange.collapse 0
                oNewRange.insertbreak Type:=3        'wdSectionBreakContinuous
            End With
            selMail.Close 0
        Next objItem
        'Asigns Outline Level 1 to all sections' first lines, goes to the top of the .docx, creates the title and the Table of contents.

        For k = 1 To docNew.sections.Count
            docNew.sections(k).Range.Paragraphs(1).Range.ParagraphFormat.outlinelevel = 1
        Next k
        
        Set oNewRange = docNew.Range
        oNewRange.collapse 1
        With oNewRange
            .Text = docName & vbCr & vbCr & vbCr
            .ParagraphFormat.outlinelevel = 10 'wdOutlineLevelBodyText
            .Font.Name = "Times New Roman"
            .Font.Size = "14"
            .Font.Color = 0
            .Font.Bold = True
        End With

        'Marks the place where ToC goes.

        Set tableRange = oNewRange.Paragraphs(2).Range

        'Creates ToC with other Sub.
        'CreateTOC True, False, docNew, tableRange

        CreateTOC docNew, oNewRange

        'Saves the .docx in order to look for it as an email attachment.

        appWord.ActiveDocument.SaveAs Filename:=dirTempDocs & docName, FileFormat:=12
        appWord.ActiveDocument.Close 0

        dirAttachmentKindle = dirTempDocs & docName & ".docx"

        'Creates email and attaches .docx

        Set MsgNew = Application.CreateItem(olMailItem)
        With MsgNew
            .Display
            .Attachments.Add dirAttachmentKindle
            .To = "user@kindle.com"
            .Subject = docName
            .sEnd
        End With

        Kill dirAttachmentKindle
        Set appWord = Nothing
        Set docNew = Nothing
        Set oRng = Nothing
        Set oNewRange = Nothing
        Set tableRange = Nothing
        Set objItem = Nothing
        Set selMail = Nothing
    End Sub

    Sub CreateTOC(oDoc As Object, oRng As Object)
        With oDoc
            .TablesOfContents.Add Range:=oRng, _
                                  RightAlignPageNumbers:=True, _
                                  UseHeadingStyles:=True, _
                                  UpperHeadingLevel:=1, _
                                  LowerHeadingLevel:=3, _
                                  IncludePageNumbers:=True, _
                                  AddedStyles:="", _
                                  UseHyperlinks:=True, _
                                  HidePageNumbersInWeb:=True, _
                                  UseOutlineLevels:=True
            .TablesOfContents(1).TabLeader = 1
            .TablesOfContents.Format = 0
        End With
    End Sub


    Graham Mayor - Word MVP
    www.gmayor.com

    Sunday, October 26, 2014 6:31 AM
  • Graham, thank you very much, it works great! 
    Monday, October 27, 2014 2:03 PM