＆＃34;运行时错误462：远程服务器计算机不存在或不可用＆＃34;第二次运行VBA代码时

时间：2015-11-10 13:55:05

标签： excel vba excel-vba word-vba outlook-vba

下面的代码第一次运行时工作正常，但是当我需要第二次运行时，它会给我这个错误：

  

运行时错误＆＃39; 462＆＃39;：远程服务器计算机不存在或不可用

它并不是一直都在发生，所以我认为它与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

2 个答案:

答案 0 :(得分：2)

第一个问题：Run-time error '462'：远程服务器计算机不存在或不可用。

这里的问题是使用：

  1. 迟到：Dim Smthg As Object或
  2. 隐式引用：Dim Smthg As Range而不是
    Dim Smthg As Excel.Range或Dim Smthg As Word.Range

    3. 所以你需要完全限定你设置的所有变量（我已经在你的代码中完成了）

    第二个问题

    您使用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

    并且一旦你开始使用这个，你可以使用此实例直到结束和结束之前，退出以避免运行多个实例。

    以下是您的代码已审核并清理过，请查看：

    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 :(得分：2)

如果这是在Excel中运行，那么您可能需要指定CentimetersToPoints来自Word库。就目前而言，VBA必须猜测，有时可能无法找到它。所以试试：

wdApp.CentimetersToPoints
相关问题
最新问题