При вставке данных в почтовое тело Outlook я получаю сообщение об ошибке 4506 «приложение заблокировано для редактирования» - PullRequest
Новая
       7

При вставке данных в почтовое тело Outlook я получаю сообщение об ошибке 4506 «приложение заблокировано для редактирования»

0 голосов
/ 18 января 2019

Я должен составить почтовое тело, содержащее текст из нескольких источников.

Однако редактор строк.Application.Selection.Paste выдает ошибку «4505», приложение заблокировано при редактировании

Я вставляю несколько раз из 3 источников, чтобы создать много писем 

Dim Outapp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim wd, cmmtrs, ftnt As Object
Dim editor As Object
Dim savePath As String
Dim filePath As String

Dim lastRow As Integer: lastRow = Sheet2.Range("D20000").End(xlUp).Row
filePath = Application.ActiveWorkbook.Path
savePath = filePath & "\" & Format(Now(), "yyyy-mm-dd")
Set wd = CreateObject("Word.Application")
Set cmmtrs = wd.Documents.Open(savePath & "\ABC.docx", ReadOnly:=True)

'create multiple emails 
For i = 2 To lastRow
    Set Outapp = CreateObject("Outlook.Application")
    Set OutMail = Outapp.CreateItem(olMailItem)
    Set vInspector = OutMail.GetInspector
    Set editor = vInspector.WordEditor


    With OutMail
        .To = Sheet2.Range("B" & i).Value
        .CC = Sheet2.Range("C" & i).Value
        .Subject = Sheet2.Range("D" & i).Value
        .Body = Sheet2.Range("E" & i).Value & vbCrLf & vbNewLine
        Dim lst As Integer: lst = Sheet3.Cells(1000, Sheet3.Range("A3:XAA3").Find(i - 1).Column).End(xlUp).Row
        Dim col1, col2 As Integer: col1 = Sheet3.Range("A3:XAA3").Find(i - 1).Column
        .Display
    End With

    With OutMail
      If Sheet3.Range("A3:XAA3").Find(i) Is Nothing Then
            col2 = Sheet3.Cells.Find(What:="*", After:=Sheet3.Cells(1, 1), LookIn:=xlValues, LookAt:=xlPart, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column
        Else
            col2 = Sheet3.Range("A3:XAA3").Find(i).Column - 1
        End If
        Sheet3.Range(Sheet3.Cells(4, col1), Sheet3.Cells(lst + 1, col2)).Copy
        editor.Application.Selection.Start = Len(.Body)
        editor.Application.Selection.End = editor.Application.Selection.Start
        Application.Wait (Now + 0.0001)

        editor.Application.Selection.Paste
    End With

    If Sheet2.Range("G" & i) = "Yes" Then
        cmmtrs.Content.Copy
        With OutMail
            editor.Application.Selection.Start = Len(.Body)
            editor.Application.Selection.End = editor.Application.Selection.Start
            Application.Wait (Now + 0.00005)
            editor.Application.Selection.Paste
        End With
    End If
...