![](/img/trans.png)
[英]“Run-time error 462 : The remote server machine does not exist or is unavailable” when running VBA code a second time
[英]"Run-time error 462 : The remote server machine does not exist or is unavailable" when running VBA code a second time
下面的代码在我第一次运行时运行良好,但是当我需要第二次运行它时,它给了我这个错误:
运行时错误“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
这里的问题是使用:
Dim Smthg As Object
或Dim Smthg As Range
而不是Dim Smthg As Excel.Range
或Dim Smthg As Word.Range
所以你需要完全限定你设置的所有变量(我已经在你的代码中完成了)
您使用多个Word实例,并且只需要一个来处理多个文档。
因此,而不是每次都创建一个新的:
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
如果这是在 Excel 中运行,那么您可能需要指定 CentimetersToPoints 来自 Word 库。 就目前而言,VBA 必须猜测,有时可能找不到。 所以尝试:
wdApp.CentimetersToPoints
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.