VBA - Copy From Excel into Outlook - Page 2

Thanks Thanks:  0
Likes Likes:  0
Page 2 of 2 FirstFirst 12
Results 11 to 16 of 16

Thread: VBA - Copy From Excel into Outlook

  1. #11
    New Member
    Join Date
    Mar 2014
    Posts
    11
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - Copy From Excel into Outlook

    Hey all,

    Can anyone help me with a similar request? I have a macro that auto-filters Column G for non-blank cells. Now I want to copy those visible (filtered) cells into the body of an email. What should the rest of my macro contain? Thanks!

    Code:
    Sub Filter
    
    With ActiveSheet
        .AutoFilterMode = False
        .Range("A1:G1").AutoFilter
        .Range("A1:G1").AutoFilter Field:=7, Criteria1:="<>"
    End With
    
    End Sub

  2. #12
    New Member
    Join Date
    Sep 2016
    Posts
    10
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - Copy From Excel into Outlook

    I don't suppose you would be able to help me out. I copied your code and adapted it to my needs. It worked fine for a few moments then all of a sudden I've started getting Runtime error 1004 and stating "Method 'Publish' of object 'PublishObject failed"


    Thanks in advance

    Joe

    Code:
     Public Sub prcSendMail()
        Dim objOutlook As Object, objMail As Object
        
        Set objOutlook = CreateObject(Class:="Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
        
        With objMail
            .To = "Mark.pantall@plasticomnium.com"
            .Cc = "gerhard.wolter@plasticomnium.com"
            .Subject = "Leaf Requirements " & Format(Now, "dd/mm/yy")
            .HTMLBody = fncRangeToHtml("LEAF PLAN 2", "P27:R46")
            .Display 'zum testen
    '        .Send
        End With
        
        Set objMail = Nothing
        Set objOutlook = Nothing
        
    End Sub
      
    Private Function fncRangeToHtml( _
        strWorksheetName As String, _
        strRangeAddress As String) As String
        
        Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
        Dim strFilename As String, strTempText As String
        Dim blnRangeContainsShapes As Boolean
        
        strFilename = Environ$("temp") & "" & _
            Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
            
        ThisWorkbook.PublishObjects.Add( _
            SourceType:=xlSourceRange, _
            FileName:=strFilename, _
            Sheet:=strWorksheetName, _
            Source:=strRangeAddress, _
            HtmlType:=xlHtmlStatic).Publish True
            
        Set objFilesytem = CreateObject("Scripting.FileSystemObject")
        
        Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
        strTempText = objTextstream.ReadAll
        objTextstream.Close
        
        For Each objShape In Worksheets(strWorksheetName).Shapes
            If Not Intersect(objShape.TopLeftCell, Worksheets( _
                strWorksheetName).Range(strRangeAddress)) Is Nothing Then
                
                blnRangeContainsShapes = True
                Exit For
                
            End If
        Next
        
        If blnRangeContainsShapes Then _
            strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
        
        fncRangeToHtml = strTempText
        fncRangeToHtml = Replace(fncRangeToHtml, "align=center x:publishsource=", "align=left x:publishsource=")
        
        Set objTextstream = Nothing
        Set objFilesytem = Nothing
        
        Kill strFilename
        
    End Function
    Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
        Const HTM_START = "") - lngPathLeft)
        strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
        strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
        strTemp = strTemp & "/"
        
        strTempText = Replace(strTempText, strTemp, Environ$("temp") & "" & strTemp)
        fncConvertPictureToMail = strTempText
        
    End Function

  3. #13
    New Member
    Join Date
    Sep 2016
    Posts
    10
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - Copy From Excel into Outlook

    Quote Originally Posted by GermanPath View Post
    Hello Misca,

    I have found below code which fulfill your requirements RangeWithShapesToHTML_BODY. Was posted on office-loesung.de from user Nepomuk:

    Code:
    Option Explicit
    Public Sub prcSendMail()
        Dim objOutlook As Object, objMail As Object
        
        Set objOutlook = CreateObject(Class:="Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
        
        With objMail
            .To = "Mailadresse@irgendwo.de"
            .Subject = "Hallo"
            .HTMLBody = fncRangeToHtml("Sheet1", "B2:H37")
            .Display 'zum testen
    '        .Send
        End With
        
        Set objMail = Nothing
        Set objOutlook = Nothing
        
    End Sub
    
      
    Private Function fncRangeToHtml( _
        strWorksheetName As String, _
        strRangeAddress As String) As String
        
        Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
        Dim strFilename As String, strTempText As String
        Dim blnRangeContainsShapes As Boolean
        
        strFilename = Environ$("temp") & "" & _
            Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
            
        ThisWorkbook.PublishObjects.Add( _
            SourceType:=xlSourceRange, _
            FileName:=strFilename, _
            Sheet:=strWorksheetName, _
            Source:=strRangeAddress, _
            HtmlType:=xlHtmlStatic).Publish True
            
        Set objFilesytem = CreateObject("Scripting.FileSystemObject")
        Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
        strTempText = objTextstream.ReadAll
        objTextstream.Close
        
        For Each objShape In Worksheets(strWorksheetName).Shapes
            If Not Intersect(objShape.TopLeftCell, Worksheets( _
                strWorksheetName).Range(strRangeAddress)) Is Nothing Then
                
                blnRangeContainsShapes = True
                Exit For
                
            End If
        Next
        
        If blnRangeContainsShapes Then _
            strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
        
        fncRangeToHtml = strTempText
        fncRangeToHtml = Replace(fncRangeToHtml, "align=center x:publishsource=", "align=left x:publishsource=")
        
        Set objTextstream = Nothing
        Set objFilesytem = Nothing
        
        Kill strFilename
        
    End Function
    
    Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
        Const HTM_START = "") - lngPathLeft)
        strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
        strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
        strTemp = strTemp & "/"
        
        strTempText = Replace(strTempText, strTemp, Environ$("temp") & "" & strTemp)
        fncConvertPictureToMail = strTempText
        
    End Function

    I don't suppose you would be able to help me out. I copied your code and adapted it to my needs. It worked fine for a few moments then all of a sudden I've started getting Runtime error 1004 and stating "Method 'Publish' of object 'PublishObject failed"


    Thanks in advance

    Joe

    Code:
       
    Public Sub prcSendMail()
        Dim objOutlook As Object, objMail As Object
        
        Set objOutlook = CreateObject(Class:="Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
        
        With objMail
            .To = "Mark.pantall@plasticomnium.com"
            .Cc = "gerhard.wolter@plasticomnium.com"
            .Subject = "Leaf Requirements " & Format(Now, "dd/mm/yy")
            .HTMLBody = fncRangeToHtml("LEAF PLAN 2", "P27:R46")
            .Display 'zum testen
    '        .Send
        End With
        
        Set objMail = Nothing
        Set objOutlook = Nothing
        
    End Sub
      
    Private Function fncRangeToHtml( _
        strWorksheetName As String, _
        strRangeAddress As String) As String
        
        Dim objFilesytem As Object, objTextstream As Object, objShape As Shape
        Dim strFilename As String, strTempText As String
        Dim blnRangeContainsShapes As Boolean
        
        strFilename = Environ$("temp") & "" & _
            Format(Now, "dd-mm-yy_h-mm-ss") & ".htm"
            
        ThisWorkbook.PublishObjects.Add( _
            SourceType:=xlSourceRange, _
            FileName:=strFilename, _
            Sheet:=strWorksheetName, _
            Source:=strRangeAddress, _
            HtmlType:=xlHtmlStatic).Publish True
            
        Set objFilesytem = CreateObject("Scripting.FileSystemObject")
        
        Set objTextstream = objFilesytem.GetFile(strFilename).OpenAsTextStream(1, -2)
        strTempText = objTextstream.ReadAll
        objTextstream.Close
        
        For Each objShape In Worksheets(strWorksheetName).Shapes
            If Not Intersect(objShape.TopLeftCell, Worksheets( _
                strWorksheetName).Range(strRangeAddress)) Is Nothing Then
                
                blnRangeContainsShapes = True
                Exit For
                
            End If
        Next
        
        If blnRangeContainsShapes Then _
            strTempText = fncConvertPictureToMail(strTempText, Worksheets(strWorksheetName))
        
        fncRangeToHtml = strTempText
        fncRangeToHtml = Replace(fncRangeToHtml, "align=center x:publishsource=", "align=left x:publishsource=")
        
        Set objTextstream = Nothing
        Set objFilesytem = Nothing
        
        Kill strFilename
        
    End Function
    Public Function fncConvertPictureToMail(strTempText As String, objWorksheet As Worksheet) As String
        Const HTM_START = "") - lngPathLeft)
        strTemp = Replace(strTemp, HTM_START & Chr$(34), "")
        strTemp = Replace(strTemp, HTM_END & Chr$(34), "")
        strTemp = strTemp & "/"
        
        strTempText = Replace(strTempText, strTemp, Environ$("temp") & "" & strTemp)
        fncConvertPictureToMail = strTempText
        
    End Function

  4. #14
    New Member
    Join Date
    Nov 2017
    Posts
    1
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - Copy From Excel into Outlook

    Thank you for sharing this code - I was struggling to find the code that would export formatted excel cells in outlook.


    I'm trying now to modify it so it would export all worksheets from the book to email address specified in A1 cell in each workbook


    May be someone could help me with that ? I'm very new to VBA and still learning how it works


    Many thanks in advance !!

  5. #15
    New Member
    Join Date
    Dec 2017
    Posts
    1
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: VBA - Copy From Excel into Outlook

    I think this code is just what I needed. However, I seem to be getting error on line "With GetObject(, "Word.Application")". Error message is ActiveX component cannot create object. I have pasted this component in Excel VBA Editor and not in Outlook VBA Editor. Can I know why I am getting this error? I have checked the reference to MS Word, MS Office & MS Outlook 16.0 Object Libraries within EXCEL VBA references. Juts an FYI. Thanking in advance.

    Quote Originally Posted by ZVI View Post
    I mean that if Word is Outlook's default editor then this copies the selected Excel's range with its shapes into the new e-mail body:
    Code:
    Sub CopyRangeToRtfMail()
    ' ZVI:2013-06-15 http://www.mrexcel.com/forum/excel-questions/708544-visual-basic-applications-copy-excel-into-outlook.html
     
      Const olFormatRichText = 3, olEditorRTF = 3, olEditorWord = 4
      Dim olApp As Object, olEditorType As Long
      Dim IsCopyObject As Boolean
     
      ' Assign CopyObjectsWithCells=True
      With Application
        IsCopyObject = .CopyObjectsWithCells
        .CopyObjectsWithCells = True
      End With
     
      ' Copy the selected Excel's range with objects
      Selection.Copy
     
      ' Get/Greate object of Outlook Aplication
      On Error Resume Next
      Set olApp = GetObject(, "Outlook.Application")
      If Err Then
        Set olApp = CreateObject("Outlook.Application")
      End If
      On Error GoTo 0
     
      ' Paste into email body of RTF type
      With olApp.CreateItem(0)
        ' Check the type of Outlook's editor (Word is expected)
        olEditorType = .GetInspector.EditorType
        ' Copy range with shapes from Excel to email of RFT format
        If olEditorType = olEditorRTF Or olEditorType = olEditorWord Then
          'Set body format to RTF
          .BodyFormat = olFormatRichText
          ' Paste to RTF email
          With GetObject(, "Word.Application")
            .Visible = True
            .Selection.Paste
          End With
          ' Show or send email
          .Display ' or .Send
        Else
          MsgBox "Outlook's default Editor is not Word", vbExclamation, "Not copied"
        End If
       
        ' Disable Excel's copy mode
        Application.CutCopyMode = False
       
        ' Restore CopyObjectsWithCells
        Application.CopyObjectsWithCells = IsCopyObject
       
        ' Clear the memory of object variable
        Set olApp = Nothing
     
      End With
     
    End Sub
    Regards

  6. #16
    MrExcel MVP ZVI's Avatar
    Join Date
    Apr 2008
    Location
    Sevastopol
    Posts
    3,268
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    1 Thread(s)

    Default Re: VBA - Copy From Excel into Outlook

    That code (post #7 ) was written for Outlook 2003 where WordEditor was not embedded into Outlook.
    For Outlook 2007+ replace this line of the code: With GetObject(, "Word.Application")
    by that one: With .GetInspector.WordEditor.Application
    Last edited by ZVI; Dec 13th, 2017 at 10:48 AM.
    Vladimir Zakharov
    Microsoft MVP Excel

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  

 

DMCA.com