Question

以下代码被编程为从MS ACCESS 2010表中检索数据并将其放入MS WORD 2010表格b中。代码每次都正常工作并抛出NO错误但打开文档并且每隔一段时间才放置数据。

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然后结束。

代码在VBA中每隔一段时间运行一次

1 个答案: