Vba ошибка 462

Search code, repositories, users, issues, pull requests…

Provide feedback

Saved searches

Use saved searches to filter your results more quickly

Sign up

Источник

First problem : Run-time error ‘462’ : The remote server machine does not exist or is unavailable.

The issue here is the use of :

  1. Late Biding : Dim Smthg As Object or
  2. Implicit references : Dim Smthg As Range instead of
    Dim Smthg As Excel.Range or Dim Smthg As Word.Range

So you need to fully qualified all the variables that you set (I’ve done that in your code)

Second problem

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

So instead of creating a new one each time with :

Set WordApp = CreateObject("Word.Application")

You can get an open instance (if there is one) or create one with that 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 once you’ve put this at the start of your proc, you can use this instance until the end of the proc and before the end, quit it to avoid having multiple instances running.

Here is your code reviewed and cleaned, take a 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

Источник

The code below is working fine the first time I run it, but when I need to run it a second time, it gives me this error:

Run Time error ‘462’: the remote server machine does not exist or is unavailable

It does happen all the time and i’ve fight against background excel instance so maybe it’s something like that…? What am I missing here?

Option Compare Database
Option Explicit

Private Sub Commande2_Click()
On Error GoTo err_Handler

   MsgBox ExportRequest, vbInformation, "Terminé"
   Application.FollowHyperlink CurrentProject.Path & "\Stage1.xlsm"

exit_Here:
   Exit Sub
err_Handler:
   MsgBox Err.Description, vbCritical, "Erreur"
   Resume exit_Here
End Sub


Public Function ExportRequest() As String
   On Error GoTo err_Handler

   ' Excel object variables
   Dim appExcel As Excel.Application
   Dim wbk As Excel.Workbook
   Dim wks As Excel.Worksheet

   Dim sTemplate As String
   Dim sTempFile As String
   Dim sOutput As String

   Dim dbs As DAO.Database
   Dim rst As DAO.Recordset
   Dim sSQL As String
   Dim Periode_var As String
   Dim lRecords As Long
   Dim iRow As Integer
   Dim iCol As Integer
   Dim derl As Integer
   Dim iFld As Integer
   Dim R As Long

   Const cTabTwo As Byte = 2
   Const cStartRow As Byte = 6
   Const cStartColumn As Byte = 2

   DoCmd.Hourglass True 'icone tablier a true

   ' set to break on all errors
   Application.SetOption "Error Trapping", 0

   ' start with a clean file built from the template file
   sTemplate = CurrentProject.Path & "\Output_Template.xlsm"
   sOutput = CurrentProject.Path & "\Stage1.xlsm"
   If Dir(sOutput) <> "" Then Kill sOutput
   FileCopy sTemplate, sOutput

   ' Create the Excel Applicaiton, Workbook and Worksheet and Database object
   Set appExcel = New Excel.Application
    'appExcel.Visible = True
    'appExcel.DisplayAlerts = False
   Set wbk = appExcel.Workbooks.Open(sOutput)
   Set wks = appExcel.Worksheets(cTabTwo)

    Periode_var = Modifiable5.Value

   sSQL = "SELECT " & Periode_var & "A, Nom, Cat" & Periode_var & "A FROM Planif WHERE Cat" & Periode_var & "A > 0 ORDER BY Cat" & Periode_var & "A ASC "
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)
   If Not rst.BOF Then rst.MoveFirst

   ' For this template, the data must be placed on the 4th row, third column.
   ' (these values are set to constants for easy future modifications)
   iCol = cStartColumn
   iRow = cStartRow
  '''''''''''''''''''''''''''''''''''''

  wks.Names.Add Name:="Tablo", RefersTo:="=DECALER(Feuil2!$B$6;;;NBVAL(Feuil2!$B$6:$B$5000);5)"
    'ActiveWorkbook.Worksheets("Feuil1").Names("tablo111").Comment = ""

   '''''''''''''''''''''''''''''''''''''
'Stop
   Do Until rst.EOF
      'iFld = 0
      lRecords = lRecords + 1
      'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to Stage1.xls"
      Me.Repaint

      For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
         wks.Cells(iRow, "B") = rst.Fields(0)
         wks.Cells(iRow, "B").WrapText = False
         wks.Cells(iRow, "C") = rst.Fields(1)
         wks.Cells(iRow, "C").WrapText = False
         wks.Cells(iRow, "F") = rst.Fields(2)
         wks.Cells(iRow, "F").WrapText = False
      Next

      wks.Rows(iRow).EntireRow.AutoFit
     ' wks.Range("B" & iRow & ":E" & iRow).Borders.LineStyle = xlContinuous
      iRow = iRow + 1
      rst.MoveNext
   Loop

    sSQL = "SELECT " & Periode_var & "B, Nom, Cat" & Periode_var & "B FROM Planif WHERE Cat" & Periode_var & "B > 0 ORDER BY Cat" & Periode_var & "B ASC "
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)

   'Stop
   Do Until rst.EOF
      'iFld = 0
      lRecords = lRecords + 1
      'Me.lblMsg.Caption = "Exporting record #" & lRecords & " to Stage1.xls"
      Me.Repaint

      For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
         wks.Cells(iRow, "B") = rst.Fields(0)
         wks.Cells(iRow, "B").WrapText = False
         wks.Cells(iRow, "D") = rst.Fields(1)
         wks.Cells(iRow, "D").WrapText = False
         wks.Cells(iRow, "F") = rst.Fields(2)
         wks.Cells(iRow, "F").WrapText = False
      Next

      wks.Rows(iRow).EntireRow.AutoFit
   '   wks.Range("B" & iRow & ":E" & iRow).Borders.LineStyle = xlContinuous
      iRow = iRow + 1
      rst.MoveNext
   Loop

   appExcel.Run "Fusionner"

''''''''''''''''''''''''''''''''''''''''''''
    sSQL = "SELECT Categorie, Catindex FROM Catvaleur"
   Set dbs = CurrentDb
   Set rst = dbs.OpenRecordset(sSQL, dbOpenSnapshot)

  'Stop
   Do Until rst.EOF

      lRecords = lRecords + 1

      Me.Repaint

      For iCol = cStartColumn To cStartColumn + (rst.Fields.Count - 1)
         wks.Cells(iRow, "B") = rst.Fields(0)
         wks.Cells(iRow, "B").WrapText = False
         wks.Cells(iRow, "F") = rst.Fields(1)
         wks.Cells(iRow, "F").WrapText = False

         If rst.Fields(1) = "0,1" Then
                wks.Range("B" & iRow).Interior.Color = RGB(244, 176, 132)
            ElseIf rst.Fields(1) = "1,2" Then
                wks.Range("B" & iRow).Interior.Color = RGB(155, 194, 230)
            ElseIf rst.Fields(1) = "2,3" Then
                wks.Range("B" & iRow).Interior.Color = RGB(255, 192, 0)
            ElseIf rst.Fields(1) = "3,4" Then
                wks.Range("B" & iRow).Interior.Color = RGB(169, 208, 142)
            End If

      Next

      wks.Rows(iRow).EntireRow.AutoFit
   '   wks.Range("B" & iRow & ":E" & iRow).Borders.LineStyle = xlContinuous

      iRow = iRow + 1
      rst.MoveNext
   Loop

   'wks.Range("F6").End(xlDown).Select
   wks.Sort.SortFields.Clear
   wks.Sort.SortFields.Add Key:=Range("F6"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With wks.Sort
        .SetRange Range("B6:F300")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

     derl = Range("F6").End(xlDown).Row
     wks.Range("B6:E" & derl).Borders.LineStyle = xlContinuous
     appExcel.DisplayAlerts = False
    wbk.SaveAs CurrentProject.Path & "\Stage1.xlsm"
    ExportRequest = "Total de " & lRecords & " lignes traitées."

    'Quitte Excel
    'wbk.Close (True)
    'Libère la mémoire
'    Set wks = Nothing
'    wbk.Close savechanges:=False
'    appExcel.Quit
'    Set wbk = Nothing
'    Set appExcel = Nothing
    Dim sKill As String

sKill = "TASKKILL /F /IM excel.exe"
Shell sKill, vbHide

exit_Here:
   ' Cleanup all objects  (resume next on errors)
   On Error Resume Next
   Set wks = Nothing
   'wbk.Close savechanges:=True
   Set wbk = Nothing
   Set appExcel = Nothing
'        sKill = "TASKKILL /F /IM excel.exe"
'        Shell sKill, vbHide

   Set rst = Nothing
   Set dbs = Nothing
   DoCmd.Hourglass False 'icone tablier a false
   Exit Function

err_Handler:
   ExportRequest = Err.Description
   Resume exit_Here

End Function

Источник
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137

Private Function funOutputWord(strPathDot As String, strPathWord As String, arr_data As Variant, cnt_rows As Variant) As Boolean
'
'--------------------------------------------------------------------------
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim DlgUser As Integer
Dim myTable As Word.Table
Dim objRange As Object
 
On Error GoTo 0
 
    
    Set objWord = New Word.Application
 
    
    If Dir(strPathWord) <> "" Then
        DlgUser = MsgBox("Документ с таким именем ранее уже был создан. Заменить его?", vbYesNo, "admin")
        Select Case DlgUser
            Case vbNo
                objWord.Documents.Open strPathWord
                GoTo funOutputWord_End
            Case Else
                Kill strPathWord
        End Select
    End If
    
    'Открываем НОВЫЙ документ сформированный по заданному шаблону
    Set objDoc = objWord.Documents.Add(strPathDot)
    
    Set myTable = objWord.Selection.Range.Tables.Add(objDoc.Bookmarks("таблица").Range, cnt_rows, 6)
    
    With myTable
 
        .AutoFormat 16
        
        .Columns(1).Width = CentimetersToPoints(1.19)
        .Columns(2).Width = CentimetersToPoints(2.75)
        .Columns(3).Width = CentimetersToPoints(2.25)
        .Columns(4).Width = CentimetersToPoints(6.75)
        .Columns(5).Width = CentimetersToPoints(3)
        .Columns(6).Width = CentimetersToPoints(2.79)
 
        For i = 1 To 6
        
            myTable.Cell(1, i).Range.ParagraphFormat.Alignment = 1
            myTable.Cell(1, i).Range.Cells.VerticalAlignment = 1
            
            ' строка заголовков - жирным
            myTable.Cell(1, i).Range.Bold = True
        
        Next i
        
        
        myTable.Cell(1, 1).Range.Text = "№ п/п"
        
        myTable.Cell(1, 2).Range.Text = "Столбик 2"
        
        myTable.Cell(1, 3).Range.Text = "Столбик 3"
        
        myTable.Cell(1, 4).Range.Text = "Столбик 4"
        
        myTable.Cell(1, 5).Range.Text = "Столбик 5"
        
        myTable.Cell(1, 6).Range.Text = "Столбик 6"
        
 
        For i = 1 To UBound(arr_data)
 
            For j = 0 To UBound(arr_data, 2)
 
                If i = 1 Then
 
                    myTable.Cell(j + 2, i).Range.Text = arr_data(i, j) & "."
 
                Else
 
                    myTable.Cell(j + 2, i).Range.Text = arr_data(i, j)
 
                End If
 
 
                Select Case i
 
                    Case 1, 4, 5, 6
                    ' от левого
                        myTable.Cell(j + 2, i).Range.ParagraphFormat.Alignment = 0
 
                    Case 2
                    ' центр
                        myTable.Cell(j + 2, i).Range.ParagraphFormat.Alignment = 1
 
                    Case 3
                    ' от правого
                        myTable.Cell(j + 2, i).Range.ParagraphFormat.Alignment = 2
 
                End Select
                
                myTable.Cell(j + 2, i).Range.Cells.VerticalAlignment = 1
 
 
            Next j
 
 
        Next i
        
        '.SaveAs strPathWord
        
    End With
 
    
    
    funOutputWord = True
 
 
funOutputWord_End:
    On Error Resume Next
    objWord.Visible = True
    objWord.Activate
 
    Set myTable = Nothing
    Set objRange = Nothing
    Set objDoc = Nothing
    Set objWord = Nothing
    
    Err.Clear
    Exit Function
 
funOutputWord_Err:
 
 
    funOutputWord = False
    MsgBox "Error: " & Err.Number & vbCrLf & Err.Description & vbCrLf & _
    "in Function: funOutputWord in module: Form_Form1", vbCritical, "Error in Application"
    Err.Clear
    Resume funOutputWord_End
 
End Function
Источник
  • Remove From My Forums

  • Question

  • I get the above error when i run the code bellow , but when i re-run it after the error occur, the code seems to Work fine. For sure im missing something in it. Can you point
    me the right way to do this?

    I have a main form with two sub forms one of the sub forms contains a list of several OLE selected word documents, in which I loop, passing all these documents to another sub
    form, which also contains an OLE Field, which will gather these Documents, in one.

    First Sub:


Private Sub Command54_Click()


Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Verb = acOLEVerbOpen
Forms!frmFScomposicao!subfrmKitCenas![FSKitCenasOLE].Verb = acOLEVerbOpen
Set GeraKit0 = Forms!frmFScomposicao!subfrmKitCenas!FSKitCenasOLE.Range

With GeraKit0.Select
GeraKit0.WholeStory
GeraKit0.Delete
End With

Dim FirstTime As Integer
FirstTime = 1

Me.FirstTimeBox = FirstTime

Forms!frmFScomposicao!PRODUCAO.SetFocus

DoCmd.RunCommand acCmdRecordsGoToFirst
For f = 1 To Forms!frmFScomposicao!PRODUCAO![Tiroliro]
Me.FirstTimeBox = FirstTime

Call CompilarKitDiaGravacao
Forms!frmFScomposicao!PRODUCAO.SetFocus
FirstTime = FirstTime + 1

DoCmd.RunCommand acCmdRecordsGoToNext

Next f

DoCmd.RunCommand acCmdRecordsGoToFirst

End Sub


Second Sub:

Public Sub CompilarKitDiaGravacao()
'Set cenaspararecolher = Forms!frmFScomposicao!PRODUCAO.Action = acOLEActivate
Set cenaspararecolher = Forms!frmFScomposicao!PRODUCAO![Prod_Cena_Guiao].Range
With cenaspararecolher.Select
cenaspararecolher.WholeStory
cenaspararecolher.Copy
Set cenaspararecolher = Nothing
End With

If Forms!frmFScomposicao.FirstTimeBox = 1 Then

Set Vinho = Forms!frmFScomposicao!subfrmKitCenas!FSKitCenasOLE.Range
With Vinho.Select
Selection.EndKey wdStory
Selection.InsertBreak Type:=wdSectionBreakContinuous
Selection.PasteAndFormat wdPasteDefault
End With
Forms!frmFScomposicao!FirstTimeBox = Forms!frmFScomposicao!FirstTimeBox + 1

Else

Set Vinho = Forms!frmFScomposicao!subfrmKitCenas!FSKitCenasOLE.Range
With Vinho.Select
Selection.EndKey wdStory
Selection.InsertBreak 'Type:=wdSectionBreakContinuous
Selection.PasteAndFormat wdPasteDefault
End With
 End If


End Sub

Источник

Понравилась статья? Поделить с друзьями:
  • Vba ошибка 440
  • Vba ошибка 424 object required как исправить
  • Vba как пропустить ошибку
  • Vba исключение ошибок
  • Vampire the masquerade bloodlines ошибка при установке