• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

VBA Code to copy all shapes from Powerpoint to Body on email/outlook as picture

tejthakur

New Member
Dear All,
I am trying to copy all shapes from slides 1 and paste as picture on body of email. Wrote a code but not working. Help will be highly appreciated

Code:
Sub Email_body()
    Dim OutApp As Object
    Dim OutMail As Object
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    Dim xHTMLBody As String
    Dim Allshape As PowerPoint.Shapes
   
      
    Set pptApp = CreateObject("PowerPoint.Application")
        pptApp.Visible = True
        pptApp.Activate
        Set pptPres = pptApp.ActivePresentation
        Set pptSlide = pptPres.Slides(1)
        Set Allshape = pptSlide.Shapes
        With pptPres
           Allshape.SelectAll
           .Copy
           Debug.Print Allshape
          
        End With
       
    End With
   
    Set OutApp = CreateObject("Outlook.Application")
       Set OutMail = OutApp.CreateItem(0)
       With OutMail
          .Display
          .body = ""
                 
                                               
           With .GetInspector.WordEditor
           .Application.Selection.EndKey Unit:=6 '6wdStory
           .Application.Selection.TypeParagraph
            .Application.Selection.Paste
           End With
            
       End With
   
    On Error GoTo 0
   
    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptSlide = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Last edited by a moderator:
You need to use Presentation's Range object. e.g.
Code:
Sub Email_body()
  Dim OutApp As Object
  Dim OutMail As Object
  Dim pptApp As Object
  Dim pptPres As Object
  Dim pptSlide As Object
  Dim xHTMLBody As String
  Dim Allshape As Object  'PowerPoint.Shapes
  
  
  Set pptApp = CreateObject("PowerPoint.Application")
  pptApp.Visible = True
  pptApp.Activate
  Set pptPres = pptApp.ActivePresentation
  Set pptSlide = pptPres.Slides(1)
  Set Allshape = pptSlide.Shapes
  Allshape.Range.Copy
  
  Set OutApp = CreateObject("Outlook.Application")
  Set OutMail = OutApp.CreateItem(0)
  With OutMail
    .Display
    .body = ""
    With .GetInspector.WordEditor
      '.Application.Selection.EndKey Unit:=6 '6wdStory
      '.Application.Selection.TypeParagraph
      .Application.Selection.Paste
    End With
  End With
  
  On Error GoTo 0
  
  Set pptApp = Nothing
  Set pptPres = Nothing
  Set pptSlide = Nothing
  Set OutMail = Nothing
  Set OutApp = Nothing
End Sub
 
Back
Top