VBA Document Locked for Editing error - powerpoint slide into email body

[picklechips]

Hi all,

I have a macro that creates an email and inserts a powerpoint slide into the email body using (.GetInspector.WordEditor) function.

Frequently I get an error saying "This Method or Property is not available because the document is locked for editing" which hits at the code (.Application.Selection.TypeParagraph).

However, the powerpoint file is not a read-only file, is not open by anyone, and doesnt have any special permissions that im aware of. It works when I go through the code slowly line by line (using F8 in VBA editor) but when I try to run the macro in one shot I get the error. Any help would be greatly appreciated! Below is my code.

Thanks,
Pickles

Option Explicit



Function GetBoiler(ByVal sFile As String) As String
    Dim fso As Object, ts As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
    GetBoiler = ts.readall
    ts.Close
End Function


Sub Emailtest()
    Dim SigString As String
    Dim SigName As String
    Dim Signature As String
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EmailTo As String
    Dim Ratesheetpdf As Variant
    Dim subj As String
    Dim body As String
    Dim LastRw As Long
    Dim i As Integer
    Dim wb As Workbook
    
    Set wb = ThisWorkbook
    
 On Error GoTo ErrorHandler


    'Ratesheet pdf attachment
    MsgBox ("SELECT RATESHEET PDF - EMAIL ATTACHMENT")
    Ratesheetpdf = Application.GetOpenFilename("PDF Files (*.pdf), *.pdf")
    
    'ppt slide attachment
    MsgBox ("SELECT POWERPOINT FILE - EMAIL BODY")
    Dim strFileName As String
    
    strFileName = Application.GetOpenFilename( _
        FileFilter:="PowerPoint Files (*.pptx), *.pptx", _
        Title:="Open", _
        ButtonText:="Open")
        
    If strFileName = "False" Then Exit Sub
    
    Dim pptApp As Object
    Dim pptPres As Object
    Dim pptSlide As Object
    
    Set pptApp = CreateObject("PowerPoint.Application")
    Set pptPres = pptApp.Presentations.Open(strFileName)
    Set pptSlide = pptPres.Slides(1)
    Set OutApp = CreateObject("Outlook.Application")
    
    'Get the text that will go on the email subject
    subj = Sheets(1).Range("c2")


    wb.Activate
    
    'add signature to email
    SigName = Sheets(1).Range("d2")
    SigString = Environ("appdata") & _
                "\Microsoft\Signatures\" & SigName & ".htm"
    If Dir(SigString) <> "" Then
        Signature = GetBoiler(SigString)
    Else
        Signature = ""
    End If
   
    'Create email loop
    LastRw = Range("A" & Rows.Count).End(xlUp).Row
    
    For i = 2 To LastRw Step 100


        EmailTo = Join(Application.Transpose(Sheets(1).Range("A" & i & ":A" & WorksheetFunction.Min(i + 99, LastRw)).Value), ";")
    
       Set OutMail = OutApp.CreateItem(0)
       With OutMail
            .Display
            .To = EmailTo
            .CC = ""
            .BCC = ""
            .subject = subj
            .Display
            .body = ""
            pptSlide.Copy
            With .GetInspector.WordEditor
            .Application.Selection.EndKey Unit:=6 'wdStory
            .Application.Selection.TypeParagraph
            .Application.Selection.Paste
                With .InlineShapes(.InlineShapes.Count)
                .ScaleWidth = 150
                .ScaleHeight = 150
                End With
            End With
            .htmlbody = .htmlbody & "<br>" & "<span style='background:aqua;mso-highlight:aqua'>" & "If you wish to unsubscribe to this e-mail please respond with the subject Unsubscribe" & "</span>" & "<br>" & "<br>" & Signature
            
            .Attachments.Add Ratesheetpdf
            '.send
             End With
             
             'OutMail.Display
            'Dim wordDoc As Word.Document
            'Set wordDoc = OutMail.GetInspector.WordEditor
             'resize ppt slide
            'Dim shp As Object
            'For Each shp In wordDoc.InlineShapes
            'shp.ScaleWidth = 200
            'Next
  
    Next i
    On Error GoTo 0


    pptPres.Close
    pptApp.Quit
    Set pptApp = Nothing
    Set pptPres = Nothing
    Set pptSlide = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing


Exit Sub


ErrorHandler:
pptPres.Close
pptApp.Quit
MsgBox "Your stupid computer thinks the Powerpoint file is open by another user. Please try again." & vbNewLine & vbNewLine & Err.Description & Err.Number & Err.Source & Err.HelpFile & Err.HelpContext
OutMail.Close 1


End Sub

 

[Fluff]

Duplicate https://www.mrexcel.com/forum/excel...quality-powerpoint-slide-into-email-body.html

Please do not post the same question multiple times. All clarifications, follow-ups, and bumps should be posted back to the original thread.
Per forum rules, posts of a duplicate nature will be locked or deleted (rule 12 here: Forum Rules).