当运行VBA代码第二次“运行时错误462：远程服务器计算机不存在或不可用”
下面的代码在我第一次运行的时候工作的很好，但是当我需要再次运行时 ，它给了我这个错误：
运行时错误“462”：远程服务器计算机不存在或不可用
它不会一直发生，所以我想这与Word（不）在后台运行有关…？ 我在这里错过了什么？
Sub Docs() Sheets("examplesheet").Select Dim WordApp1 As Object Dim WordDoc1 As Object Set WordApp1 = CreateObject("Word.Application") WordApp1.Visible = True WordApp1.Activate Set WordDoc1 = WordApp1.Documents.Add Range("A1:C33").Copy WordApp1.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _ Placement:=wdInLine, DisplayAsIcon:=False Application.Wait (Now + TimeValue("0:00:02")) WordDoc1.PageSetup.TopMargin = CentimetersToPoints(1.4) WordDoc1.PageSetup.LeftMargin = CentimetersToPoints(1.5) WordDoc1.PageSetup.BottomMargin = CentimetersToPoints(1.5) ' Control if folder exists, if not create folder If Len(Dir("F:\documents\" & Year(Date), vbDirectory)) = 0 Then MkDir "F:\documents\" & Year(Date) End If WordDoc1.SaveAs "F:\documents\" & Year(Date) & "\examplename " & Format(Now, "YYYYMMDD") & ".docx" WordDoc1.Close 'WordApp1.Quit Set WordDoc1 = Nothing Set WordApp1 = Nothing Windows("exampleworkbook.xlsm").Activate Sheets("examplesheet").Select Application.CutCopyMode = False Range("A1").Select ' export sheet 2 to Word Sheets("examplesheet2").Select Set WordApp2 = CreateObject("Word.Application") WordApp2.Visible = True WordApp2.Activate Set WordDoc2 = WordApp2.Documents.Add Range("A1:C33").Copy WordApp2.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _ Placement:=wdInLine, DisplayAsIcon:=False Application.Wait (Now + TimeValue("0:00:02")) WordDoc2.PageSetup.LeftMargin = CentimetersToPoints(1.5) WordDoc2.PageSetup.TopMargin = CentimetersToPoints(1.4) WordDoc2.PageSetup.BottomMargin = CentimetersToPoints(1.5) WordDoc2.SaveAs "F:\files\" & Year(Date) & "\name" & Format(Now, "YYYYMMDD") & ".docx" WordDoc2.Close 'WordApp2.Quit Set WordDoc2 = Nothing Set WordApp2 = Nothing Windows("exampleworkbook.xlsm").Activate Sheets("examplesheet2").Select Application.CutCopyMode = False Range("A1").Select ' Variables Outlook Dim objOutlook As Object Dim objMail As Object Dim rngTo As Range Dim rngCc As Range Dim rngSubject As Range Dim rngBody As Range Dim rngAttach1 As Range Dim rngAttach2 As Range Dim numSend As Integer Set objOutlook = CreateObject("Outlook.Application") Set objMail = objOutlook.CreateItem(0) ' Outlook On Error GoTo handleError With Sheets("Mail") Set rngTo = .Range("B11") Set rngCc = .Range("B12") Set rngSubject = .Range("B13") Set rngBody = .Range("B14") Set rngAttach1 = .Range("B15") Set rngAttach2 = .Range("B16") End With With objMail .To = rngTo.Value .Subject = rngSubject.Value .Cc = rngCc.Value '.Body = rngBody.Value .Body = "Hi," & _ vbNewLine & vbNewLine & _ rngBody.Value & _ vbNewLine & vbNewLine & _ "Kind regards," .Attachments.Add rngAttach1.Value .Attachments.Add rngAttach2.Value .Display Application.Wait (Now + TimeValue("0:00:01")) Application.SendKeys "%s" ' .Send ' Instead of .Display, you can use .Send to send the email _ or .Save to save a copy in the drafts folder End With numSend = numSend + 1 GoTo skipError handleError: numErr = numErr + 1 oFile.WriteLine "*** ERROR *** Email for account" & broker & " not sent. Error: " & Err.Number & " " & Err.Description skipError: On Error GoTo 0 MsgBox "Sent emails: " & numSend & vbNewLine & "Number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished" GoTo endProgram cancelProgram: MsgBox "No mails were sent.", vbOKOnly + vbExclamation, "Operation cancelled" endProgram: Set objOutlook = Nothing Set objMail = Nothing Set rngTo = Nothing Set rngSubject = Nothing Set rngBody = Nothing Set rngAttach1 = Nothing Set rngAttach2 = Nothing End Sub 第一个问题： 运行时错误“462” ：远程服务器机器不存在或不可用。
这里的问题是使用：
- 晚期投标：
Dim Smthg As Object还是投标 - 隐式引用：
Dim Smthg As Range而不是
Dim Smthg As Excel.Range或Dim Smthg As Word.Range
所以你需要完全限定你设置的所有variables （我已经在你的代码中完成了）
第二个问题
您可以使用 Word的多个实例 ，并且只需要一个来处理多个文档 。
所以不要每次都创build一个新的：
Set WordApp = CreateObject("Word.Application")
你可以得到一个开放的实例（如果有的话）或者使用该代码创build一个实例：
On Error Resume Next Set WordApp = GetObject(, "Word.Application") If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application") On Error GoTo 0
一旦你把这个放在你的proc 开始的时候，你可以使用这个实例直到 proc 结束，在结束之前退出它，以避免有多个实例在运行。
这里是你的代码审查和清理，看看：
Sub Docs() Dim WordApp As Word.Application Dim WordDoc As Word.Document ' Control if folder exists, if not create folder If Len(Dir("F:\documents\" & Year(Date), vbDirectory)) = 0 Then MkDir "F:\documents\" & Year(Date) ' Get or Create a Word Instance On Error Resume Next Set WordApp = GetObject(, "Word.Application") If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application") On Error GoTo 0 Workbooks("exampleworkbook.xlsm").Sheets("examplesheet").Range("A1:C33").Copy With WordApp .Visible = True .Activate Set WordDoc = .Documents.Add .Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _ Placement:=wdInLine, DisplayAsIcon:=False End With With Application .Wait (Now + TimeValue("0:00:02")) .CutCopyMode = False End With With WordDoc .PageSetup.TopMargin = WordApp.CentimetersToPoints(1.4) .PageSetup.LeftMargin = WordApp.CentimetersToPoints(1.5) .PageSetup.BottomMargin = WordApp.CentimetersToPoints(1.5) .SaveAs "F:\documents\" & Year(Date) & "\examplename " & Format(Now, "YYYYMMDD") & ".docx" .Close End With ' export sheet 2 to Word Workbooks("exampleworkbook.xlsm").Sheets("examplesheet2").Range("A1:C33").Copy Set WordDoc = WordApp.Documents.Add WordApp.Selection.PasteSpecial Link:=False, DataType:=wdPasteRTF, _ Placement:=wdInLine, DisplayAsIcon:=False Application.Wait (Now + TimeValue("0:00:02")) With WordDoc .PageSetup.LeftMargin = WordApp.CentimetersToPoints(1.5) .PageSetup.TopMargin = WordApp.CentimetersToPoints(1.4) .PageSetup.BottomMargin = WordApp.CentimetersToPoints(1.5) .SaveAs "F:\files\" & Year(Date) & "\name" & Format(Now, "YYYYMMDD") & ".docx" .Close End With Application.CutCopyMode = False WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing ' Variables Outlook Dim objOutlook As Outlook.Application Dim objMail As Outlook.MailItem Dim rngTo As Excel.Range Dim rngCc As Excel.Range Dim rngSubject As Excel.Range Dim rngBody As Excel.Range Dim rngAttach1 As Excel.Range Dim rngAttach2 As Excel.Range Dim numSend As Integer On Error Resume Next Set objOutlook = GetObject(, "Outlook.Application") If Err.Number > 0 Then Set objOutlook = CreateObject("Outlook.Application") On Error GoTo 0 Set objMail = objOutlook.CreateItem(0) ' Outlook On Error GoTo handleError With Sheets("Mail") Set rngTo = .Range("B11") Set rngCc = .Range("B12") Set rngSubject = .Range("B13") Set rngBody = .Range("B14") Set rngAttach1 = .Range("B15") Set rngAttach2 = .Range("B16") End With With objMail .To = rngTo.Value .Subject = rngSubject.Value .CC = rngCc.Value '.Body = rngBody.Value .Body = "Hi," & _ vbNewLine & vbNewLine & _ rngBody.Value & _ vbNewLine & vbNewLine & _ "Kind regards," .Attachments.Add rngAttach1.Value .Attachments.Add rngAttach2.Value .Display Application.Wait (Now + TimeValue("0:00:01")) Application.SendKeys "%s" ' .Send ' Instead of .Display, you can use .Send to send the email _ or .Save to save a copy in the drafts folder End With numSend = numSend + 1 GoTo skipError handleError: numErr = numErr + 1 oFile.WriteLine "*** ERROR *** Email for account" & broker & " not sent. Error: " & Err.Number & " " & Err.Description skipError: On Error GoTo 0 MsgBox "Sent emails: " & numSend & vbNewLine & "Number of errors: " & numErr, vbOKOnly + vbInformation, "Operation finished" GoTo endProgram cancelProgram: MsgBox "No mails were sent.", vbOKOnly + vbExclamation, "Operation cancelled" endProgram: Set objOutlook = Nothing Set objMail = Nothing Set rngTo = Nothing Set rngSubject = Nothing Set rngBody = Nothing Set rngAttach1 = Nothing Set rngAttach2 = Nothing End Sub
如果这是在Excel中运行，则可能需要指定CentimetersToPoints来自Word库。 就目前而言，VBA必须猜测，有时可能找不到它。 所以试试：
wdApp.CentimetersToPoints