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

Status
Not open for further replies.

picklechips

New Member
Joined
Jun 22, 2018
Messages
21
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

Code:
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
 

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Status
Not open for further replies.

Forum statistics

Threads
1,223,893
Messages
6,175,249
Members
452,623
Latest member
Techenthusiast

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top