代码在 VBA 中每隔一段时间工作一次

Question

下面的代码被编程为从 MS ACCESS 2010 表中检索数据并将其放入 MS WORD 2010 表格 b 中。该代码每次都能正常工作，不会抛出任何错误，但会打开文档并每隔一次放置一次数据。

Sub Module11()
Dim appWord As Word.Application
Dim conn As ADODB.Connection
Dim doc As Word.Document
Dim rst As ADODB.Recordset

Dim tnum As String
Dim sname As String
Dim frst As Integer
Dim mrst As Integer
Dim sam As Integer
Dim strSQL As String

On Error Resume Next
Err.Clear

If Err.Number <> 0 Then
Set appWord = New Word.Application
End If

Set rst = New ADODB.Recordset
Set appWord = GetObject(, "Word.Application")
Set conn = New ADODB.Connection



conn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= D:\Database\Database.mdb"
rst.Open "tableSDR", conn, adOpenKeyset, adLockOptimistic


 tnum = InputBox("Enter the Tracking Number of the Record " & _
  "you want to find:", "TRACKING NUMBER")

strSQL = "Select * from table where rst!TrackingNumber='" & tnum & "'"
'AND " _
 '   & "[rst!TrackingNumber]='" & tnum & "' "

rst.Open strSQL, cn, adOpenDynamic, adLockReadOnly

sam = rst!TrackingNumber

Do While Not rst.EOF
If sam <> tnum Then
    rst.MoveNext
    sam = rst!TrackingNumber

Else
     Exit Do
End If
Loop

Do While rst.EOF
MsgBox "Tracking Number Not Found! "
   Exit Sub
Loop


Set doc = appWord.Documents.Open("D:\Database\Form.docx", True)


With doc
    .FormFields("model").Result = rst!Model
    .FormFields("date_submitted").Result = rst!TDate
    .FormFields("part_number").Result = rst!PartNumber
    .FormFields("sup_name").Result = rst!SupplierName
    .FormFields("part_name").Result = rst!PartName
    .FormFields("sup_location").Result = rst!SupplierLocation
    .FormFields("rev_level").Result = rst!RevisionLevel
    .FormFields("sup_contact").Result = rst!SupplierContact
    .FormFields("po_number").Result = rst!PONumber
    .FormFields("telephone_num").Result = rst!TelephoneNum
    .FormFields("quantity").Result = rst!Quantity
    .FormFields("fax_number").Result = rst!FaxNum
    .FormFields("required_date").Result = rst!RequiredDate
    .FormFields("dev_req").Result = rst!DeviationRequest
    .FormFields("dev_period").Result = rst!DeviationPeriod

        frst = rst!FirstTime
        mrst = rst!MaterialChange

        If (frst = 1) Then
             If (mrst = 1) Then
                   doc.FormFields("time").Result = " Material Change and First Time"
             ElseIf (msrt = 0) Then
                   doc.FormFields("time").Result = "First Time"
             End If
        ElseIf (frst = 0) Then
             If (mrst = 1) Then
                   doc.FormFields("time").Result = " Material Change "
             ElseIf (msrt = 0) Then
                   doc.FormFields("time").Result = "Not Applicable"
             End If
      End If


    .FormFields("cur_spec").Result = rst!CurrentSPecification
    .FormFields("prop_dev").Result = rst!ProposedDeviation
    .FormFields("reason_dev").Result = rst!ReasonForDeviation

    .FormFields("pur_sign").Result = rst!PurchaseSign
    .FormFields("pur_des").Result = rst!PurchaseAD
    .FormFields("pur_date").Result = rst!PurchaseDate
    .FormFields("pur_com").Result = rst!PurchaseComments
    .FormFields("qual_sign").Result = rst!QualitySign

    .FormFields("qual_des").Result = rst!QualityAD
    .FormFields("qual_date").Result = rst!QualityDate
    .FormFields("qual_com").Result = rst!QualityComments
    .FormFields("engg_sign").Result = rst!EnggSign

    .FormFields("engg_des").Result = rst!EnggAD
    .FormFields("engg_date").Result = rst!EnggDate
    .FormFields("engg_com").Result = rst!EnggComments

    .FormFields("manu_sign").Result = rst!ManuSign
    .FormFields("manu_des").Result = rst!ManuAD
    .FormFields("manu_date").Result = rst!ManuDate
    .FormFields("manu_com").Result = rst!ManuComments

    .FormFields("other_sign").Result = rst!OtherSign
    .FormFields("other_des").Result = rst!OtherAD
    .FormFields("other_date").Result = rst!OtherDate
    .FormFields("other_com").Result = rst!OtherComments

    .FormFields("doc_req").Result = rst!ChangeRequired
    .FormFields("pca_number").Result = rst!PCANum
    .FormFields("dis_comments").Result = rst!Comments
    .FormFields("tracking_num").Result = rst!TrackingNumber



.Visible = True

.Activate

End With

doc.ActiveDocument.SaveAs (MSQname)
doc.Quit
Set doc = Nothing
Set rst = Nothing
Set appWord = Nothing
Set conn = Nothing
Exit Sub

errHandler:

MsgBox Err.Number & ": " & Err.Description
End Sub

Answer 1

我看不到连接的任何关闭。代码掉落会导致它关闭，因此它会在下一次工作。然后尝试 rs.close。