On Error GoTo <label>无法正常工作</label>

时间：2012-07-26 13:54:54

标签： ms-access access-vba ms-access-2003

我在表单上有一个简单的命令按钮，“click”事件过程用于将Excel文件逐行导入数据库，作为自定义过程的一部分。我已经设置了我的：

On Error GoTo DtUplErr

在程序开始时，还检查了VBA选项以确保“中断未处理的错误是我的选项”，但它不会移动到我的Handle书签而是抛出标准的运行时错误提示。

实际程序本身利用工作空间来执行更新（不确定这是否会导致问题）

我正在打破的错误是3022（重复值），我打算查看并捕获它，因此这不是一个糟糕的数据问题。

我已经尝试将所有对象导入到干净的mdb中但仍然没有运气，我真的很困惑。

有什么建议吗？

完整代码（金额道歉）

Private Sub cmdSelect_Click()

'MS Excel
Dim xlApp       As Object 'Late Binding
Dim xlWrkBk     As Object
Dim xlWrkSt     As Object
Dim lngRow      As Long
Dim lngRowCnt   As Long

'Recordsets/Workspace
Dim WkSp        As DAO.Workspace 'Transaction Buffer
Dim rsMs        As DAO.Recordset 'Master
Dim rsSu        As DAO.Recordset 'Supplier
Dim rsAd        As DAO.Recordset 'Address
Dim rsAs        As DAO.Recordset 'Asset

'Misc
Dim strFile     As String
Dim dblMPRN     As Double
Dim lngPerc     As Long

On Error GoTo DtUplErr

Loading 1
strFile = DataUploadDialog
If strFile & "" = "" Then Exit Sub 'Quit if no file selected

'Open up the file
Set xlApp = CreateObject("Excel.Application")
Set xlWrkBk = xlApp.Workbooks.Open(strFile)
Set xlWrkSt = xlWrkBk.Worksheets(1)

Forms!frmUpload!cmdHidden.SetFocus
DoCmd.Hourglass -1

'Validate file format before import
With xlWrkSt
    If .Range("A1") <> "MPRN" _
    Or .Range("B1") <> "Notification" _
    Or .Range("C1") <> "Asset" _
    Or .Range("D1") <> "Reference No." _
    Or .Range("E1") <> "WMS Job No." _
    Or .Range("F1") <> "Meter Worker" _
    Or .Range("G1") <> "Job Status" _
    Or .Range("H1") <> "Date" _
    Or .Range("I1") <> "Time" _
    Or .Range("J1") <> "Sales district" _
    Or .Range("K1") <> "Customer" _
    Or .Range("L1") <> "Location" _
    Or .Range("M1") <> "Additional Info" _
    Or .Range("N1") <> "Street" _
    Or .Range("O1") <> "Dependent Locality" _
    Or .Range("P1") <> "Post Town" _
    Or .Range("Q1") <> "Postal Code" _
    Or .Range("R1") <> "Serial number" _
    Or .Range("S1") <> "Cur. Serial No." _
    Or .Range("T1") <> "Manufacturer Code" _
    Or .Range("U1") <> "Model Code" _
    Or .Range("V1") <> "Year of Manufacture" _
    Then
        xlWrkBk.Close
        xlApp.Quit
        Set xlApp = Nothing
        Set xlWrkBk = Nothing
        Set xlWrkSt = Nothing

        DoCmd.Hourglass 0

        MsgBox "Selected file is not in the correct format, please ensure " & _
               "the original column headers have not been moved/renamed" & _
               vbCr & vbCr & _
               "For further assistance please contact app support", 48
        Exit Sub
    End If
End With

Forms!frmUpload!cmdSelect.Enabled = 0
Forms!frmUpload!cmdClose.Enabled = 0

'Get total number of rows in file
lngRow = 1

Do Until xlWrkSt.Cells(lngRow, 1).Value & "" = ""
    lngRow = lngRow + 1
Loop

lngRowCnt = lngRow - 2

'Start writing to the tables
Set WkSp = DBEngine.Workspaces(0)

WkSp.BeginTrans

    Set rsMs = CurrentDb.OpenRecordset("tblMaster", dbOpenDynaset)
    Set rsSu = CurrentDb.OpenRecordset("tblSupplierHist", dbOpenDynaset)
    Set rsAd = CurrentDb.OpenRecordset("tblAddress", dbOpenDynaset)
    Set rsAs = CurrentDb.OpenRecordset("tblAssetHist", dbOpenDynaset)

    lngRow = 2

    Do Until lngRow > lngRowCnt + 1

ProcessUpload:
        With xlWrkSt

            dblMPRN = .Range("A" & lngRow) 'Store MPRN for additional tables

            'Master
            rsMs.AddNew
                rsMs!MPRN = dblMPRN
                rsMs!LoadTimestamp = Now()
                rsMs!Notification = .Range("B" & lngRow)
                rsMs!Asset = .Range("C" & lngRow)
                rsMs!JobRef = .Range("D" & lngRow)
                rsMs!WmsJobRef = .Range("E" & lngRow)
                rsMs!MeterWorker = .Range("F" & lngRow)
                rsMs!JobStatus = .Range("G" & lngRow)
                rsMs!JobTimestamp = .Range("H" & lngRow) & " " & .Range("I" & lngRow)
                rsMs!SalesDistrict = .Range("J" & lngRow)
                rsMs!AddInfo = .Range("M" & lngRow)
            rsMs.Update

            'Supplier
            rsSu.AddNew
                rsSu!MPRN = dblMPRN
                rsSu!SupplierID = .Range("K" & lngRow)
                rsSu!Timestamp = Now()
                rsSu!Advisor = "System"
            rsSu.Update

            'Address
            rsAd.AddNew
                rsAd!MPRN = dblMPRN
                rsAd!Street = .Range("N" & lngRow)
                rsAd!Locality = .Range("O" & lngRow)
                rsAd!Town = .Range("P" & lngRow)
                rsAd!PostCode = .Range("Q" & lngRow)
            rsAd.Update

            'Asset
            rsAs.AddNew
                rsAs!MPRN = dblMPRN
                rsAs!SN = .Range("R" & lngRow)
                rsAs!Make = .Range("T" & lngRow)
                rsAs!Model = .Range("U" & lngRow)
                rsAs!YOM = .Range("V" & lngRow)
                rsAs!Location = .Range("L" & lngRow)
                rsAs!Timestamp = Now()
                rsAs!Advisor = "System"
            rsAs.Update

            'Work out progress
            lngPerc = Round((lngRow / lngRowCnt) * 100)
            lngPerc = IIf(lngPerc > 0, lngPerc - 1, lngPerc)

            Forms!frmUpload!txtPerc = lngPerc & "/" & lngRowCnt & "  (" & lngPerc & " %)"
            Forms!frmUpload!ProgBar.Value = lngPerc

            'Let the display catch up
            DoEvents
            Sleep 100

            lngRow = lngRow + 1 'Advance

        End With

    Loop

WkSp.CommitTrans

Forms!frmUpload!txtPerc = lngRowCnt & "/" & lngRowCnt & "  (100 %)"
Forms!frmUpload!ProgBar.Value = 100
DoEvents

'Cleanup
xlWrkBk.Close
xlApp.Quit
Set xlApp = Nothing
Set xlWrkBk = Nothing
Set xlWrkSt = Nothing

rsMs.Close
rsSu.Close
rsAd.Close
rsAs.Close
WkSp.Close
Set rsMs = Nothing
Set rsSu = Nothing
Set rsAd = Nothing
Set rsAs = Nothing
Set WkSp = Nothing

Forms!frmUpload!cmdClose.Enabled = -1

DoCmd.Hourglass 0

Exit Sub

DtUplErr:
Select Case Err

    Case 3022 'Index Violation (Assumed PK MPRN in tblMaster)
        lngRow = lngRow + 1
        GoTo ProcessUpload

    Case Else 'Cleanup and then show error
        WkSp.Rollback 'Cancel transaction so data not affected

        xlWrkBk.Close
        xlApp.Quit
        Set xlApp = Nothing
        Set xlWrkBk = Nothing
        Set xlWrkSt = Nothing

        rsMs.Close
        rsSu.Close
        rsAd.Close
        rsAs.Close
        WkSp.Close
        Set rsMs = Nothing
        Set rsSu = Nothing
        Set rsAd = Nothing
        Set rsAs = Nothing
        Set WkSp = Nothing

        Forms!frmUpload!cmdSelect.Enabled = -1
        Forms!frmUpload!cmdClose.Enabled = -1

        DoCmd.Hourglass 0

        ShowError Err, "ModFunctions", "DataUpload", Err.Description

End Select

End Sub

3 个答案:

答案 0 :(得分：1)

感谢来自@HansUp的建议，我逐步完成了我的代码，试图阻止错误的根源，正如我所料，这是最简单（但最富裕的）事情。

在第一个错误中，我的代码按预期运行到这一点：

DtUplErr:
    Select Case Err

    Case 3022 'Index Violation (Assumed PK MPRN in tblMaster)
        lngRow = lngRow + 1
        GoTo ProcessUpload

然后返回我们转到下一个项目和剩下的过程，但是在下一个错误中它会失败，并且它有效地归结为一个“单词”，我已经改变了这一行：

Goto ProcessUpload

要：

Resume ProcessUpload

现在错误仍在继续处理，phew，我一直都知道“恢复”关键字超过“GoTo”是有充分理由的，但直到现在还没有感受到错误的错误^ _ ^

答案 1 :(得分：1)

为了简化您的代码以便日后解决问题，我提出了这个建议。

将部分从'Cleanup更改为Exit Sub，直至：

MySubShallHaveOnlyOneExitPoint:
    xlWrkBk.Close
    xlApp.Quit
    Set xlApp = Nothing
    Set xlWrkBk = Nothing
    Set xlWrkSt = Nothing
    rsMs.Close
    rsSu.Close
    rsAd.Close
    rsAs.Close
    WkSp.Close
    Set rsMs = Nothing
    Set rsSu = Nothing
    Set rsAd = Nothing
    Set rsAs = Nothing
    Set WkSp = Nothing
    Forms!frmUpload!cmdClose.Enabled = -1
    DoCmd.Hourglass 0
    Exit Sub

然后，错误处理程序中的Case Else可以简化为：

Case Else ' Cleanup and then show error '
    WkSp.Rollback ' Cancel transaction so data not affected '
    Forms!frmUpload!cmdSelect.Enabled = -1
    ShowError Err, "ModFunctions", "DataUpload", Err.Description
    Resume MySubShallHaveOnlyOneExitPoint

答案 2 :(得分：0)

编辑：Err对象默认返回的'Number'属性。

我认为问题在于你的Select Case声明。您错过了错误对象的“Number”属性。所以它只是跳过整个Select Case块 

DtUplErr:
Select Case Err.Number 'Use the Error Number for your Select Case Statement

    Case 3022 'Index Violation (Assumed PK MPRN in tblMaster)
        lngRow = lngRow + 1
        Err.Clear
        On Error Goto DtUplErr 'might need to tell it to branch on error again, i havn't tested
        GoTo ProcessUpload

    Case Else 'Cleanup and then show error
        MsgBox Err.Description
        'do whatever here
End Select

<击>

相关问题
最新问题