«Ошибка во время выполнения 462: компьютер с удаленным сервером не существует или недоступен» при повторном запуске кода VBA
Код нижеработает нормально в первый раз, когда я запускаю его, но когда мне нужно запустить его во второй раз, это дает мне эту ошибку:
Ошибка времени выполнения '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