We help IT Professionals succeed at work.

How to stop VBA code that is running

linder76
linder76 asked
on
4,608 Views
Last Modified: 2013-11-27
I am running code that is uploading.

I need to have a function that the user can click on to stop this routine.  Below is the code
'**********************************************************
'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

Open in new window

Comment
Watch Question

Infotrakker Software
CERTIFIED EXPERT
Most Valuable Expert 2012
Top Expert 2014
Commented:
This one is on us!
(Get your first solution completely free - no credit card required)
UNLOCK SOLUTION

Author

Commented:
Where would I put that in my code? And why would I move the record forward if I am stoppoing the code....This looks good I just confused where it should go?


 If mfStop Then Exit Sub
  rst.MoveNext
Unlock the solution to this question.
Join our community and discover your potential

Experts Exchange is the only place where you can interact directly with leading experts in the technology field. Become a member today and access the collective knowledge of thousands of technology experts.

*This site is protected by reCAPTCHA and the Google Privacy Policy and Terms of Service apply.

OR

Please enter a first name

Please enter a last name

8+ characters (letters, numbers, and a symbol)

By clicking, you agree to the Terms of Use and Privacy Policy.