All geek questions in one place

"Runtime error 462: The remote server computer does not exist or is unavailable" when you run VBA code again

Below is the code that works fine the first time it starts, but when I need to run it a second time , it gives me this error:

Runtime error '462': remote server does not exist or is unavailable

This does not always happen, so I suppose this has something to do with Word (not) running in the background ...? What am I missing here?

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
+5
source share
2 answers

First problem: Runtime error '462' : The remote server computer does not exist or is unavailable.

The problem here is to use:

  • Late Biding: Dim Smthg As Object or
  • Implicit links: Dim Smthg As Range instead of Dim Smthg As Excel.Range or Dim Smthg As Word.Range

So, you need to fully qualify all the variables that you set (I did this in your code)

Second problem

You work with multiple instances of Word and you only need one to process multiple documents .

So instead of creating a new one every time with

 Set WordApp = CreateObject("Word.Application")

You can get an open instance (if any) or create it using this code:

 On Error Resume Next Set WordApp = GetObject(, "Word.Application") If Err.Number > 0 Then Set WordApp = CreateObject("Word.Application") On Error GoTo 0

And , as soon as you put this at the beginning of your proc, you can use this instance to the end for proc and to the end, exit it to avoid running multiple instances.

Here is your code viewed and cleaned up, look:

 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
+1
source

If this works in Excel, you probably need to specify that CentimetersToPoints comes from the Word library. Be that as it may, VBA must guess, and sometimes it probably cannot find it. So try:

 wdApp.CentimetersToPoints
+2
source

Source: https://habr.com/ru/post/1235616/

More articles:


All Articles