尝试在Word VBA中粘贴文本时出现4605错误

Question

我将代码编译为:

1-清除当前文档的所有内容，包括页眉和页脚;

2-按顺序将文件夹中多个word文件的内容复制到当前文件中，并在每个文件后插入一个换行符;

3-删除空白页(我想删除另一个空白页，但我不知道如何)。

这段代码运行了几次，但是现在，它给出了

错误4605

代码中的黄线是:

Selection.PasteAndFormat wdPasteDefault

Sub criarRelatorio()
Application.ScreenUpdating = True
Application.DisplayAlerts = False 'desabilita mensagens de atualização
Dim MasterDoc As String
Dim mySource As Object
Dim oFile As Object
Dim endPasta As String
Dim SeparateDoc As String
Dim nFile As Integer
Dim i As Integer
Dim Msg, Style, Title, Response, MyString
endPasta = "H:AssessoresPareceresLHRrelats"
Msg = "Deseja colar os " & nFiles(endPasta) & " arquivos que estão na pasta (" & endPasta & ") neste documento? " _
& vbNewLine & vbNewLine & "Isso pode demorar de 5 a 10 minutos." & vbNewLine & vbNewLine & _
" Caso aceite, aguarde até que apareça uma mensagem confirmando a colagem dos itens."    ' Define message.
Style = vbYesNo Or vbCritical Or vbDefaultButton2    ' Define buttons.
Title = "Utilização de macro LHR"    ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then    ' User chose Yes.
GoTo aceitou ' Perform some action.
Else    ' User chose No.
GoTo cancelou ' Perform some action.
End If
aceitou:
'delete all content before starting
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.WholeStory
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Set WordApplication = CreateObject("Word.Application")
Set obj = CreateObject("Scripting.FileSystemObject")
MasterDoc = ActiveDocument.Name
Set mySource = obj.getfolder(endPasta)
nFile = nFiles(endPasta)
i = 0
For Each oFile In mySource.Files
If i < nFile Then
Application.Documents.Open mySource & "" & oFile.Name, Visible:=False
Documents(oFile.Name).Activate
SeparateDoc = ActiveDocument.Name
Selection.WholeStory
Selection.Expand wdParagraph
Selection.Copy
Documents(oFile.Name).Close
Documents(MasterDoc).Activate
Selection.InsertBreak Type:=wdSectionBreakNextPage
Selection.PasteAndFormat wdPasteDefault
Selection.Collapse Direction:=wdCollapseEnd
End If
i = i + 1
Next oFile
ActiveDocument.Paragraphs(1).Range.Delete
'removing first line
ActiveDocument.Range(0, 0).Select
Selection.MoveEnd wdLine
Selection.Delete
ActiveDocument.Undo
Selection.HomeKey Unit:=wdStory
MsgBox "Os " & nFiles(endPasta) & " Relatórios já foram colados!", , "Atenção!!"
Exit Sub
cancelou:
MsgBox "Operação Não Executada", , "Cancelado"
Exit Sub
'habilita mensagens de atualização
Application.DisplayAlerts = True
End Sub

Answer 1

您的主要问题是在循环中使用剪贴板，这是一个操作系统函数。您的VBA代码执行得比剪贴板所能处理的要快，从而导致错误。

完全有可能在不使用剪贴板的情况下做你正在尝试的事情。Word中的范围有一个FormattedText属性，可以从一个范围分配给另一个范围。这有效地完成了与复制/粘贴相同的工作，但无需调用剪贴板。

我已经编辑了你的代码来使用这个方法，但还没有编辑循环后的代码。你得自己收拾。

Sub criarRelatorio()
Application.ScreenUpdating = True
Application.DisplayAlerts = False 'desabilita mensagens de atualização
Dim MasterDoc As Document
Dim mySource As Object
Dim oFile As Object
Dim endPasta As String
Dim SeparateDoc As Document
Dim nFile As Integer
Dim i As Integer
Dim Msg, Style, Title, Response, MyString
endPasta = "H:AssessoresPareceresLHRrelats"
Msg = "Deseja colar os " & nFiles(endPasta) & " arquivos que estão na pasta (" & endPasta & ") neste documento? " _
& vbNewLine & vbNewLine & "Isso pode demorar de 5 a 10 minutos." & vbNewLine & vbNewLine & _
" Caso aceite, aguarde até que apareça uma mensagem confirmando a colagem dos itens."    ' Define message.
Style = vbYesNo Or vbCritical Or vbDefaultButton2    ' Define buttons.
Title = "Utilização de macro LHR"    ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then    ' User chose Yes.
GoTo aceitou ' Perform some action.
Else    ' User chose No.
GoTo cancelou ' Perform some action.
End If

aceitou:
'delete all content before starting
Set MasterDoc = ActiveDocument
With MasterDoc
.Content.Delete
.Sections(1).Headers(wdHeaderFooterPrimary).Range.Delete
End With
'This isn't needed. You're running the code in Word so don't need another instance
'Set WordApplication = CreateObject("Word.Application")
Set obj = CreateObject("Scripting.FileSystemObject")
Set mySource = obj.getfolder(endPasta)
nFile = nFiles(endPasta)
i = 0
For Each oFile In mySource.Files
If i < nFile Then
Set SeparateDoc = Documents.Open(mySource & "" & oFile.Name, Visible:=False)
MasterDoc.Content.InsertBreak Type:=wdSectionBreakNextPage
MasterDoc.Characters.Last.FormattedText = SeparateDoc.Content.FormattedText
SeparateDoc.Close wdDoNotSaveChanges
'replaced by lines above
'Selection.WholeStory
'Selection.Expand wdParagraph
'Selection.Copy
'Documents(oFile.Name).Close
'Documents(MasterDoc).Activate
'Selection.InsertBreak Type:=wdSectionBreakNextPage
'Selection.PasteAndFormat wdPasteDefault
'Selection.Collapse Direction:=wdCollapseEnd
End If
i = i + 1
Next oFile
ActiveDocument.Paragraphs(1).Range.Delete
'removing first line
ActiveDocument.Range(0, 0).Select
Selection.MoveEnd wdLine
Selection.Delete
ActiveDocument.Undo
Selection.HomeKey Unit:=wdStory
MsgBox "Os " & nFiles(endPasta) & " Relatórios já foram colados!", , "Atenção!!"
Exit Sub
cancelou:
MsgBox "Operação Não Executada", , "Cancelado"
Exit Sub
'habilita mensagens de atualização
Application.DisplayAlerts = True
End Sub