VBAコードを2回実行すると、「実行時エラー462：リモートサーバーマシンが存在しないか、使用できません」

Question

以下のコードは最初に実行したときは正常に動作しますが、2回目に実行する必要があるとき、次のエラーが発生します。

実行時エラー「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

Answer 1

最初の問題： 実行時エラー '462' ：リモートサーバーマシンが存在しないか、使用できません。

ここでの問題は、以下の使用です。

1. レイトバイディング：Dim Smthg As Objectまたは
2. 暗黙の参照：Dim Smthg As Range の代わりに
   Dim Smthg As Excel.RangeまたはDim Smthg As Word.Range

したがって、設定したすべての変数を完全修飾する必要があります（コードでこれを行いました）

---

---

2番目の問題

Wordの複数のインスタンスを操作し、複数のドキュメントを処理するために必要なのは1つだけです。

したがって、毎回新しいものを作成する代わりに：

Set WordApp = CreateObject("Word.Application")

開いているインスタンスを取得するか（存在する場合）、そのコードでインスタンスを作成できます。

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

Answer 2

これがExcelで実行されている場合は、CentimetersToPointsがWordライブラリからのものであることを指定する必要があります。現状では、VBAは推測する必要があり、場合によってはそれを見つけることができない可能性があります。だから試してみてください：

wdApp.CentimetersToPoints