How to stop VBA code that is running

'**********************************************************
'Procedure Uploads QE Data
'06/14/2007
'Amended on 05/28/2008
'**********************************************************
Dim cnABOMS As ADODB.Connection
Dim rst_WEB_tblExam_QE_OC As ADODB.Recordset
Dim rst_tblExam_QE_OC As Recordset, rst_tblQE_Application As Recordset, rst_tblQE_Examination As Recordset
Dim DB As Database
    
'On Error GoTo Err_cmdUpload_Updated_AppItems_Click
 
Set DB = CurrentDb
 
'Enables user to stop upload
If Me.cmdUpload_Updated_AppItems.Caption = "Click to stop" Then
    *******IThis I wrote to stop the code but it is not working...I need something to stop the code******
    Me.cmdUpload_Updated_AppItems.Caption = "Upload Update Application Items"
    Me.PrgBarUploadAppItems.Visible = False
    Me.txtCounter.Visible = False
    Me.lblBuildingData.Visible = False
    'Exit Do
    Exit Sub
 
Else
 
    Me.cmdUpload_Updated_AppItems.Caption = "Click to stop"
 
    'Retrieve people to upload, only people who have submitted online, manual people are retrived later**remember to put the nULL in here
    Set rst_tblExam_QE_OC = DB.OpenRecordset("Select * from tblExam_QE_OC " & _
    "WHERE (((tblExam_QE_OC.ExamType) = 'QE')) " & _
    "OR (((tblExam_QE_OC.ExamType)='RE'))")
 
        If rst_tblExam_QE_OC.RecordCount = 0 Then
 
            Exit Sub 'Exit routine
        Else
            rst_tblExam_QE_OC.MoveLast
            rst_tblExam_QE_OC.MoveFirst
        End If
    
            'Initialize progress bar and counter
            Me.PrgBarUploadAppItems.Visible = True
            Me.txtCounter.Visible = True
            Me.lblBuildingData.Visible = True
        
                    IntRecordCount = rst_tblExam_QE_OC.RecordCount
                    Me.PrgBarUploadAppItems.Min = 0
                    Me.PrgBarUploadAppItems.Max = IntRecordCount
                    Me.PrgBarUploadAppItems.Value = 0
                    Me.txtCounter.Value = IntRecordCount
 
'Update to tblExam_QE_OC ROE, LicenceReceived, TrainingVerification, Photo, Approval, and IntentDates
Do
 
If rst_tblExam_QE_OC!QE_App_Credentials_Date <> "" Or IsNull(rst_tblExam_QE_OC!QE_App_Credentials_Date) = False Then
 
    'Check tblQEApplication Table to retrieve dates
    Set rst_tblQE_Application = DB.OpenRecordset("" & _
    "SELECT tblWQEApplication.* " & _
    "FROM tblWQEApplication " & _
    "Where tblWQEApplication.DiplomateNumber = " & Trim(rst_tblExam_QE_OC!DiplomateNumber) & " and  " & _
    "tblWQEApplication.ApplicationDate = " & "#" & Trim(rst_tblExam_QE_OC!QE_App_Credentials_Date) & "#")
 
        rst_tblExam_QE_OC.Edit
    
            rst_tblExam_QE_OC!QE_App_LicenceReceived_Date = rst_tblQE_Application!LicenseReceivedDate
            rst_tblExam_QE_OC!QE_App_TrainingVerification_Date = rst_tblQE_Application!TrainingVerificationdate
            rst_tblExam_QE_OC!QE_App_Category1Received_Date = rst_tblQE_Application!Category1ReceivedDate
            rst_tblExam_QE_OC!QE_App_Approval_date = rst_tblQE_Application!Approvaldate
            rst_tblExam_QE_OC!QE_App_ROE_Date = rst_tblQE_Application!ROEReceivedDate
            rst_tblExam_QE_OC!QE_App_Photo = rst_tblQE_Application!PhotoID
        
        rst_tblExam_QE_OC.Update
    
rst_tblQE_Application.Close
'****QE Intent Date does not need to be retrieved, it is in tblExma_QE_OC already
 
Else
    'Nothing
End If
 
 
 
 
Me.PrgBarUploadAppItems.Value = Me.PrgBarUploadAppItems.Value + 1
Me.txtCounter.Value = Me.txtCounter - 1
DoEvents
 
rst_tblExam_QE_OC.MoveNext
 
Loop Until rst_tblExam_QE_OC.EOF
DoEvents
 
'Check for people who paid for QE App manuall
Call QE_Manually_Paid
 
 
 
 
'Send information to Web*************************************************************************************
'Set master recordset back to first record
rst_tblExam_QE_OC.MoveFirst
 
'Reinitalize progress bar and counter
Me.lblBuildingData.Caption = "Uploading Data, Part 3 of 3"
Me.PrgBarUploadAppItems.Min = 0
Me.PrgBarUploadAppItems.Max = IntRecordCount
Me.PrgBarUploadAppItems.Value = 0
Me.txtCounter.Value = IntRecordCount
DoEvents
 
'Open connection to SQL WEB
Set cnABOMS = New ADODB.Connection
 
    With cnConString
    .ConnectionString = "Provider=MSDataShape.1;Persist Security Info=True;Data Source=database.domain.com;" & _
    "User ID=Login;Password=password;Initial Catalog=Domain_org_01;Data Provider=SQLOLEDB.1"
    .ConnectionTimeout = 10
    .Open
    End With
 
'Upload Records
Do
 
Set rst_WEB_tblExam_QE_OC = New ADODB.Recordset
With rst_WEB_tblExam_QE_OC
.CursorType = adOpenDynamic
.CursorLocation = adUseClient
.LockType = adLockOptimistic
.Open "SELECT * FROM tblExam_QE_OC WHERE SSN = " & "'" & rst_tblExam_QE_OC!SSN & "'", cnABOMS
End With
 
    
'Uploads records/Converts empty strings to Null Values
 
'Credentials Date
If IsNull(rst_tblExam_QE_OC!QE_App_Credentials_Date) Then
    rst_WEB_tblExam_QE_OC!QE_App_Credentials_Date = Null
Else
    rst_WEB_tblExam_QE_OC!QE_App_Credentials_Date = rst_tblExam_QE_OC!QE_App_Credentials_Date
End If
    
    'Roe Date
    If IsNull(rst_tblExam_QE_OC!QE_App_ROE_Date) Then
        rst_WEB_tblExam_QE_OC!QE_App_ROE_Date = Null
    Else
        rst_WEB_tblExam_QE_OC!QE_App_ROE_Date = rst_tblExam_QE_OC!QE_App_ROE_Date
    End If
    
        'LicenceReceived Date
        If IsNull(rst_tblExam_QE_OC!QE_App_LicenceReceived_Date) Then
            rst_WEB_tblExam_QE_OC!QE_App_LicenceReceived_Date = Null
        Else
            rst_WEB_tblExam_QE_OC!QE_App_LicenceReceived_Date = rst_tblExam_QE_OC!QE_App_LicenceReceived_Date
        End If
    
            'Training Verification Date
            If IsNull(rst_tblExam_QE_OC!QE_App_TrainingVerification_Date) Then
                rst_WEB_tblExam_QE_OC!QE_App_TrainingVerification_Date = Null
            Else
                rst_WEB_tblExam_QE_OC!QE_App_TrainingVerification_Date = rst_tblExam_QE_OC!QE_App_TrainingVerification_Date
            End If
    
                'Category1Received Date
                If IsNull(rst_tblExam_QE_OC!QE_App_Category1Received_Date) Then
                    rst_WEB_tblExam_QE_OC!QE_App_Category1Received_Date = Null
                Else
                    rst_WEB_tblExam_QE_OC!QE_App_Category1Received_Date = rst_tblExam_QE_OC!QE_App_Category1Received_Date
                End If
       
                    'Photo Date
                    If IsNull(rst_tblExam_QE_OC!QE_App_Photo) Then
                        rst_WEB_tblExam_QE_OC!QE_App_Photo = Null
                    Else
                        rst_WEB_tblExam_QE_OC!QE_App_Photo = rst_tblExam_QE_OC!QE_App_Photo
                    End If
    
                        'Approval Date
                        If IsNull(rst_tblExam_QE_OC!QE_App_Approval_date) Then
                            rst_WEB_tblExam_QE_OC!QE_App_Approval_date = Null
                        Else
                            rst_WEB_tblExam_QE_OC!QE_App_Approval_date = rst_tblExam_QE_OC!QE_App_Approval_date
                        End If
    
                            'QE Intent Date
                            If IsNull(rst_tblExam_QE_OC!QE_App_Intent_Date) Then
                                rst_WEB_tblExam_QE_OC!QE_App_Intent_Date = Null
                            Else
                                rst_WEB_tblExam_QE_OC!QE_App_Intent_Date = rst_tblExam_QE_OC!QE_App_Intent_Date
                            End If
    
    
'Save record changes
rst_WEB_tblExam_QE_OC.Update
     
'Update progress bar/counter
Me.PrgBarUploadAppItems.Value = Me.PrgBarUploadAppItems.Value + 1
Me.txtCounter.Value = Me.txtCounter - 1
DoEvents
 
'Move to next record
rst_tblExam_QE_OC.MoveNext
Loop Until rst_tblExam_QE_OC.EOF
 
'Close progress bar/counter
Me.PrgBarUploadAppItems.Visible = False
Me.txtCounter.Visible = False
Me.lblBuildingData.Visible = False
 
'Close recordsets
rst_tblExam_QE_OC.Close
rst_WEB_tblExam_QE_OC.Close
cnABOMS.Close
 
End If
 
Me.cmdUpload_Updated_AppItems.Caption = "Upload Update Application Items Dates"
MsgBox "Upload Complete.", vbInformation, "Candidate Upload"
 
'Exit_cmdUpload_Updated_AppItems_Click:
'    Exit Sub
'
'Err_cmdUpload_Updated_AppItems_Click:
'    MsgBox Err.Description
'    Resume Exit_cmdUpload_Updated_AppItems_Click
 
End Sub

Select allOpen in new window