Showing posts with label VB6. Show all posts
Showing posts with label VB6. Show all posts

Free Visual Basic 6 Source Code Applications Examples for VB6 and SQL Programming - Both for the Beginner and Advanced

Latest update: June 10, 2024. Page URL indicates original publication date; meanwhile, times change and the updates continue.

[Mobile Note: this article is a very large file, recommend using desktop computer for viewing.]

The author of this page has worked in the tech, software industry as a programmer/analyst for over 20 years. There's a lot of code here, both for beginners and advanced; file will take a awhile to load.


Apparently, VB is finally dead. The older posts follow. Conflicting comments are appreciated.

[Just a pandemic side note. Government agencies are desperate for anyone who has ever programmed in COBOL; they don't care if you are retired or what age you are.]

Surprisingly, employment opportunities still abound for Visual Basic 6.0. A simple search for "VB6" at a job search aggregation site still brings up lots of them.

About The VB6 and SQL Programming Code Libraries

This extensive page contains debugged MS Visual Basic 6.0 ( VB6 ) source code examples from business applications I have written over the years. You will find standalone blocks of SQL, record set processing, data manipulation (field and character level), and some useful GUI routines. Other items include:
  • All sorts of string functions
  • All sorts of while loops
  • Shell command
  • All sorts of date format and other date functions
  • Message box, msgbox
  • Printing
  • File exists
  • Call command
  • Execute
  • Records delete command
  • Queries
  • Select records
  • Select variables
  • Creating and chaining together subroutines
  • And more
An alternative title for this page might be SQL Source Code Examples. VB6's ability to integrate SQL is one of its major strengths. There is also VBA relevancy.

You will notice occasional code snippets that have been commented, purpose being to temporarily hide them from from the compiler for whatever reason. Even though temporarily commented, the snippets are also production, debugged code.

This page has over 13,000 words of VB6 and SQL source code snippets, examples, samples, etc. A lot of the syntax remains eternal in the land of Visual Basic. Hopefully these code libraries will serve people well for many years.

Hexadecimal images would have been more representative for this page; unfortunately, I couldn't find any decent ones that were public domain. This code is copyrighted and not available for publication elsewhere; however, copying segments for your personal use as starting templates for your own applications is fine; after all, the objective of this page is to help fellow VB6-SQL programmer folks. The hexadecimal link is actually a tutorial for the binary, quaternary, octal, and hexadecimal base numbering systems. When you've learned one, you've learned them all.

If looking for a particular command, syntax, etc.; the F3 or Ctrl-F browser search function will come in mighty handy.

May all your programming adventures be prosperous ones.

Visual Basic 6.0 and SQL Code Examples Library One - Beginner and Advanced


VB6 - Visual Basic 6.0

'TO RUN WORD OR ANY OTHER SOFTWARE FROM WITHIN A VISUAL BASIC APPLICATION.

Private Sub cmdDocumentation_Click()
    Dim RetVal
    RetVal = Shell("C:\Program Files\Microsoft Office\Office\WINWORD.EXE XYZ.DOC", 1)
End Sub

Private Sub cmdDBpicture_Click()
    frmDBpicture.Show 1
End Sub

Private Sub cmdTechDoc_Click()
    Dim RetVal
    RetVal = Shell("C:\Program Files\Microsoft Office\Office\WINWORD.EXE XYZtech.DOC", 1)
End Sub

Private Sub cmdUserDoc_Click()
    Dim RetVal
    RetVal = Shell("C:\Program Files\Microsoft Office\Office\WINWORD.EXE XYZuser.DOC", 1)
End Sub



VB6 - Visual Basic

'OBTAINING USER DATE RANGE and
'DATE MANIPULATION CODE

'frmDATERANGE screen
'Notes:
'   Variables declared as public in Module1
'   Public procedures can be found in Module1

Private Sub Form_Load()

    varSTARTDATE = Format(Date, "mm/01/yy")
    varENDDATE = DateAdd("d", -1, DateAdd("m", 1, varSTARTDATE))

    txtSTARTDATE.Text = varSTARTDATE
    txtENDDATE.Text = varENDDATE

End Sub

Private Sub cmdMONTH_Click(Index As Integer)

    varSTARTDATE = CDate(Trim(Str(Index)) + "/01/" + Format(Date, "yy"))
    varENDDATE = CDate(DateAdd("d", -1, DateAdd("m", 1, varSTARTDATE)))

    txtSTARTDATE.Text = varSTARTDATE 'global
    txtENDDATE.Text = varENDDATE 'global

End Sub

Private Sub cmdProceed_Click()

    varDR = True

    varSTARTDATE = CStr(txtSTARTDATE.Text)
    varENDDATE = CStr(txtENDDATE.Text)

    varPROCEED = True
    varCANCEL = False

    Me.Hide

End Sub

Private Sub cmdCancel_Click()

    varDR = False
    varPROCEED = False
    varCANCEL = True

    Unload Me

End Sub



VB6 - SQL

Private Sub cmdPrintReport_Click()
'CREATE DATA AND PRINT REPORT USING A SPECIFIED DATE RANGE

Dim dbs As Database
Dim strSQL As String
Dim TheSelectedMonth As String

'FIRST WE DETERMINE WHAT DATE RANGE THE USER WANTS
varCANCEL = False
frmDATERANGE.Show 1
Me.Refresh

If varCANCEL Then Exit Sub

supervarS = CStr(varSTARTDATE)
supervarE = CStr(varENDDATE)

Set dbs = OpenDatabase(gsDatabase)

'NEXT WE SELECT OUT THOSE RECORDS FROM THE RELEVANT TABLE
'TABLES TEMP X,Y,Z ARE INTERMEDIATE STEP TABLES THE USER CAN VIEW
On Error Resume Next
dbs.Execute "DROP TABLE [TEMPX];"
Err.Clear
    strSQL = "SELECT ACCOUNTNOFLD, DATEFLD INTO TEMPX " _
             & "From THETABLE WHERE " _
             & "(((THETABLE.DATEFLD)>=#" & supervarS & "#)) AND " _
             & "(((THETABLE.DATEFLD)<=#" & supervarE & "#)) AND " _
             & "(THETABLE.ANOTHERFLD) ='N';"
    dbs.Execute (strSQL)

'THEN WE GET MORE DATA FROM ANOTHER TABLE
'BY USING THE IN-COMMON ACCOUNTNOFLD USING JOIN
On Error Resume Next
dbs.Execute "DROP TABLE [TEMPY];"
Err.Clear
    strSQL = "SELECT * INTO TEMPY " _
             & "From ANOTHERTBL INNER JOIN TEMPX ON " _
             & "ANOTHERTBL.ACCOUNTNOFLD=TEMPX.ACCOUNTNOFLD;"
    dbs.Execute (strSQL)

'NEXT WE ADD SOME NEW FIELDS
dbs.Execute ("ALTER TABLE TEMPY ADD COLUMN CUSTSUBSETFLD text")
dbs.Execute ("ALTER TABLE TEMPY ADD COLUMN ORDERSUBSETFLD text")

dbs.Close

'THEN POPULATE FIELDS WITH CUSTSUBSETFLD AND ORDERSUBSETFLD DATA
Set dbs = OpenDatabase(gsDatabase)
Set rstTEMPY = dbs.OpenRecordset("TEMPY")

Me.Refresh
Counter = 1
With rstTEMPY
    .MoveFirst
    While Not .EOF
        .Edit
        If Not IsNull(.THELARGERFLD) Then
            .CUSTSUBSETFLD = CStr(Mid(.THELARGERFLD, 1, 11))
            .ORDERSUBSETFLD = CStr(Mid(.THELARGERFLD, 15, 20))
        Else
            .CUSTSUBSETFLD = "None"
            .ORDERSUBSETFLD = "None"
        End If
        .Update
        Counter = Counter + 1
        Debug.Print CStr(Counter)
        .MoveNext
    Wend
End With

rstTEMPY.Close

'INDEX TABLES SO CRYSTAL REPORTS WILL WORK
dbs.Execute "CREATE INDEX NewIndexX ON TEMPX (ACCOUNTNOFLD);"
dbs.Execute "CREATE INDEX NewIndexY ON TEMPY (ACCOUNTNOFLD);"

dbs.Close
Set rstTEMPY = Nothing
Set dbs = Nothing

'DEFINE REPORT
CR1.ReportFileName = "THEREPORT.rpt"

'PUT REPORT TITLE AND MONTH IN FORMULA FOR CRYSTAL REPORTS TO USE.
'CR1.Formulas(0) = "USERMONTH= " _
                  & "'" & theCurrentMonth & "'"

'RUN REPORT
CR1.Action = 1

Close
Set dbs = Nothing
End Sub 'END OF CREATE DATA AND PRINT REPORT USING A SPECIFIED DATE RANGE



VB6 - SQL

Private Sub cmdAnotherRpt_Click()

Dim dbs As Database
Dim strSQL As String
Dim TheSelectedMonth As String

varCANCEL = False
frmDATERANGE.Show 1
Me.Refresh

If varCANCEL Then Exit Sub

theCurrentMonth = "Blah Blah Report for " _
                  & CStr(Format(varENDDATE, "mmmm"))
thePrevMonthX = DateAdd("m", -1, varENDDATE)
ThePrevMonth = CStr(UCase(CStr(Format(thePrevMonthX, "mmm"))))

Set dbs = OpenDatabase(gsDatabase)

On Error Resume Next
dbs.Execute "DROP TABLE [TEMPX];"
Err.Clear

'Gets the code 2 data WITH THE APPROPRIATE MONTH FIELD
strSQL = "SELECT FLDA, FLDB, FLDC, FLDD, " _
         & ThePrevMonth _
         & " INTO TEMPX From SOURCETABLE " _
         & "WHERE CODE = '2' AND OTHERFLD = 'Y';"
dbs.Execute (strSQL)
       
'create new field for the standard report
dbs.Execute ("ALTER TABLE Tempx ADD COLUMN PrevMonth integer")

'move thePrevMonth to new PrevMonth field
strSQL = "UPDATE TEMPX " _
         & "SET PREVMONTH = " _
         & ThePrevMonth _
         & ";"
    dbs.Execute (strSQL)
   
'PUT NAME OF MONTH IN TABLE FOR CRYSTAL REPORTS TO USE.

CR1.ReportFileName = "THEREPORT.rpt"
CR1.Formulas(0) = "USERMONTH= " _
                  & "'" & theCurrentMonth & "'"
CR1.Action = 1

Close
Set dbs = Nothing

End Sub 'end of cmdAnotherRpt button



VB6 - SQL

Private Sub cmdMonthEndDetailRpt_Click()
'DETAIL REPORT USING MULTIPLE TABLES

Dim dbs As Database
Dim strSQL As String
Dim TheSelectedMonth As String

varCANCEL = False
frmDATERANGE.Show 1
Me.Refresh

If varCANCEL Then Exit Sub

theCurrentMonth = "Month End Detail Report for " _
                  & CStr(Format(varENDDATE, "mmmm"))
thePrevMonthX = DateAdd("m", -1, varENDDATE)
ThePrevMonth = CStr(UCase(CStr(Format(thePrevMonthX, "mmm"))))

Set dbs = OpenDatabase(gsDatabase)

On Error Resume Next
dbs.Execute "DROP TABLE [TEMPX];"
Err.Clear

'Gets INVENFILE data WITH THE APPROPRIATE MONTH FIELD
strSQL = "SELECT SKU, DESC, ISSUEUNIT, VENDOR, CURR_BAL, " _
         & ThePrevMonth _
         & " INTO TEMPX From INVENFILE;"
dbs.Execute (strSQL)
       
'create new field for the standard report
dbs.Execute ("ALTER TABLE Tempx ADD COLUMN PrevMonth integer")

'move thePrevMonth to new PrevMonth field
strSQL = "UPDATE TEMPX " _
         & "SET PREVMONTH = " _
         & ThePrevMonth _
         & ";"
    dbs.Execute (strSQL)
   
'WE'VE CREATED THE TEMPX TABLE THAT CONTAINS THE INVENTORYFILE DATA.
'NOW WE CREATE THE ASSOCIATED TRANSACTION DATA.

supervarS = CStr(varSTARTDATE)
supervarE = CStr(varENDDATE)
   
'WE SELECT OUT THE MTD TRANSACTION RECORDS
On Error Resume Next
dbs.Execute "DROP TABLE [TEMPY];"
Err.Clear
    strSQL = "SELECT SKU, TRANS_NUMBER, ORDERDATE, QTY, THETYPE, TRCODE INTO TEMPY " _
             & "From TRANSACTION WHERE " _
             & "(((TRANSACTION.ORDERDATE)>=#" & supervarS & "#)) AND " _
             & "(((TRANSACTION.ORDERDATE)<=#" & supervarE & "#));"
    dbs.Execute (strSQL)


'NOW WE PLOP IN THE REASON DESCRIPTIONS.

'create new field for the reason description.
dbs.Execute ("ALTER TABLE Tempy ADD COLUMN REASON text")

Set wrkJET = CreateWorkspace("", "admin", "", dbUseJet)
Set dbsCurrent = wrkJET.OpenDatabase(gsDatabase, True)
Set rstTEMPY = dbsCurrent.OpenRecordset("TEMPY")

Me.Refresh

With rstTEMPY
   
    .MoveFirst
   
    While Not .EOF
   
        .Edit
       
    Select Case .theTYPE  'Evaluate WMSCODE.
       
        Case "A1"
            .reason = "(+) Positive Adjustment"
           
        Case "A2"
            If .TRCODE = "62" Then .reason = "(-) Negative Adjustment"
            If .TRCODE = "64" Then .reason = "(-) Broken/Damaged"
            If .TRCODE = "61" Then .reason = "(-) Repackaging Adjustment"
           
        Case "C1"
            .reason = "(+) Customer Return"
           
        Case "M2"
            If .TRCODE = "82" Then .reason = "(-) Issue to Customer"
            If .TRCODE = "80" Then .reason = "(-) Exception Order"
           
        Case "P1"
            .reason = "(+) Repack Finished Stock"
           
        Case "P2"
            .reason = "(-) Repack Bulk Stock"
           
        Case "R1"
            .reason = "(+) Receiving"
           
        Case "R2"
            .reason = "(-) Receiving Adjustment"
           
        Case "V2"
            .reason = "(-) Return to Vendor"
           
        Case "V1"
            .reason = "(+) Exchange from Vendor"
             
        Case Else
            .reason = "Unknown"
           
    End Select
   
    .Update
     
    .MoveNext
   
    Wend
   
End With

rstTEMPY.Close
dbsCurrent.Close
wrkJET.Close
Set rstTEMPY = Nothing
Set dbsCurrent = Nothing
Set wrkJET = Nothing

dbs.Execute "CREATE INDEX NewIndexX ON TEMPX (SKU);"
dbs.Execute "CREATE INDEX NewIndexY ON TEMPY (SKU);"

'DEFINE REPORT
CR1.ReportFileName = "MEDETAIL.rpt"

'PUT REPORT TITLE AND MONTH IN FORMULA FOR CRYSTAL REPORTS TO USE.
CR1.Formulas(0) = "USERMONTH= " _
                  & "'" & theCurrentMonth & "'"

'RUN REPORT
CR1.Action = 1

Close
Set dbs = Nothing
End Sub 'END OF cmdMonthEndDetailRpt



VB6 - SQL

'CODE FOR A MULTIPLE QUERIES FORM

Private Sub cmdClose_Click()
Me.Hide
End Sub

'USE ANOTHER FORM TO GET DATE RANGE
Private Sub cmdDR_Click()
frmDATERANGE.Show
Me.Refresh
End Sub

Private Sub cmdReceipt_Click()
If varRO = "R" Then
    varRO = ""
    cmdReceipt.Caption = "Click for &Receipts Only (TR30 and TR36)"
Else
    varRO = "R"
    cmdReceipt.Caption = "Receipts Only Option Selected"
    cmdOrder.Caption = "Click for &Orders Only   (TR80 and TR82)"
    cmdWorkOrder.Caption = "Click for &Work Orders Only   (TR40)"
    End If
End Sub

Private Sub cmdOrder_Click()
If varRO = "O" Then
    varRO = ""
    cmdOrder.Caption = "Click for &Orders Only   (TR80 and TR82)"
Else
    varRO = "O"
    cmdOrder.Caption = "Orders Only Option Selected"
    cmdReceipt.Caption = "Click for &Receipts Only (TR30 and TR36)"
    cmdWorkOrder.Caption = "Click for &Work Orders Only   (TR40)"
End If
End Sub

Private Sub cmdWorkOrder_Click()
If varRO = "W" Then
    varRO = ""
    cmdWorkOrder.Caption = "Click for &Work Orders Only   (TR40)"
Else
    varRO = "W"
    cmdWorkOrder.Caption = "Work Orders Only Option Selected"
    cmdReceipt.Caption = "Click for &Receipts Only (TR30 and TR36)"
    cmdOrder.Caption = "Click for &Orders Only   (TR80 and TR82)"
End If
End Sub
Private Sub cmdReset_Click()

varRO = ""
    cmdReceipt.Caption = "Click for &Receipts Only (TR30 and TR36)"
    cmdOrder.Caption = "Click for &Orders Only   (TR80 and TR82)"
    cmdWorkOrder.Caption = "Click for &Work Orders Only   (TR40)"
   
varDR = False

varSingleSKU = ""
    txtSKU.Text = ""

varSingleAcctCode = ""
    txtACCOUNTCODE.Text = ""
   
varSinglePOnumber = ""
    txtPOnumber.Text = ""

End Sub

Private Sub cmdSEARCH_click(x)
End Sub

Private Sub cmdSEARCHX_Click()

Dim dbs As Database
Set dbs = OpenDatabase(gsDatabase)

cmdSEARCHX.Caption = "Working..."

'First we select out the user requested date range.

Me.Refresh
On Error Resume Next
dbs.Execute "DROP TABLE [TEMPX];"
Err.Clear

If varDR Then 'get the specified date range

    supervarS = CStr(varSTARTDATE)
    supervarE = CStr(varENDDATE)
   
    strSQL = "SELECT * INTO TEMPX " _
        & "From TRANSACTION WHERE " _
        & "(((TRANSACTION.THEDATE)>=#" & supervarS & "#)) AND " _
        & "(((TRANSACTION.THEDATE)<=#" & supervarE & "#));"
    dbs.Execute (strSQL)

Else 'make copy of entire transaction file
   
    strSQL = "SELECT * INTO TEMPX From TRANSACTION;"
    dbs.Execute (strSQL)
   
End If

'Next we check if user wants Receipt-Only, Orders-Only, Work Orders-Only or all.

On Error Resume Next
dbs.Execute "DROP TABLE [TEMPY];"
Err.Clear

If varRO = "R" Then 'get receipts only

    strSQL = "SELECT * INTO TEMPY " _
        & "From TEMPX WHERE " _
        & "TEMPX.TRCODE = '30' OR TEMPX.TRCODE = '36';"
    dbs.Execute (strSQL)

Else
End If

If varRO = "O" Then 'get orders only

    strSQL = "SELECT * INTO TEMPY " _
        & "From TEMPX WHERE " _
        & "TEMPX.theTYPE = 'M2' OR TEMPX.theTYPE = 'M3';"
    dbs.Execute (strSQL)

Else
End If

If varRO = "W" Then 'get work orders only

    strSQL = "SELECT * INTO TEMPY " _
        & "From TEMPX WHERE " _
        & "TEMPX.TRCODE = '40';"
    dbs.Execute (strSQL)

Else
End If

If varRO = "" Then 'keep everything
    strSQL = "SELECT * INTO TEMPY From TEMPX;"
    dbs.Execute (strSQL)
Else
End If

'We've taken care of the dateRange and the R vs O scenarios
'Next let's do the Single Account

On Error Resume Next
dbs.Execute "DROP TABLE [TEMPZ];"
Err.Clear

If txtACCOUNTCODE.Text = "" Then 'user doesn't want a single account
    strSQL = "SELECT * INTO TEMPZ From TEMPY;"
    dbs.Execute (strSQL)
Else 'user wants data only for a single account
    varSingleAcctCode = CStr(txtACCOUNTCODE.Text)
    strSQL = "SELECT * INTO TEMPZ " _
        & "From TEMPY WHERE " _
        & "(((TEMPY.ACCTCODE)='" & varSingleAcctCode & "'));"
    dbs.Execute (strSQL)
End If

'Now let's do the single P.O.

On Error Resume Next
dbs.Execute "DROP TABLE [TEMPX];"
Err.Clear

If txtPOnumber.Text = "" Then 'user doesn't want a single P.O. number
    strSQL = "SELECT * INTO TEMPX From TEMPZ;"
    dbs.Execute (strSQL)
Else 'user wants data only for a P.O.
    varSinglePOnumber = CStr(txtPOnumber.Text)
    strSQL = "SELECT * INTO TEMPX " _
        & "From TEMPZ WHERE " _
        & "(((TEMPZ.PO_NUMBER)='" & varSinglePOnumber & "'));"
    dbs.Execute (strSQL)
End If

'Last is the single SKU scenario,
'this calls for a different output than the rest
If txtSKU.Text = "" Then 'processing is done, show output to user
    frmX.Show
Else 'this is the single SKU scenario, processing continues
    'first we get the records for the requested SKU
    On Error Resume Next
    dbs.Execute "DROP TABLE [TEMPY];"
    Err.Clear
    varSingleSKU = CStr(txtSKU.Text)
    strSQL = "SELECT * INTO TEMPY " _
        & "From TEMPX WHERE " _
        & "(((TEMPX.SKU)='" & varSingleSKU & "'));"
    dbs.Execute (strSQL)
    'next we get the SKU description, etc. data
    On Error Resume Next
    dbs.Execute "DROP TABLE [TEMPZ];"
    Err.Clear
    strSQL = "SELECT * INTO TEMPZ " _
             & "From TEMPY INNER JOIN THESKUFILE ON " _
             & "TEMPY.SKU=THESKUFILE.SKU;"
    dbs.Execute (strSQL)
    frmZ.Show
End If

endOfJobHK:
cmdSEARCH.Caption = "Search and Display Results"
dbs.Close
Set dbs = Nothing
End Sub

Private Sub Form_Load()
varRO = ""
    cmdReceipt.Caption = "Click for &Receipts Only (TR30 and TR36)"
    cmdOrder.Caption = "Click for &Orders Only   (TR80 and TR82)"
    cmdWorkOrder.Caption = "Click for &Work Orders Only   (TR40)"

varDR = False

varSingleSKU = ""
    txtSKU.Text = ""

varSingleAcctCode = ""
    txtACCOUNTCODE.Text = ""
   
varSinglePOnumber = ""
    txtPOnumber.Text = ""

End Sub 'END OF CODE FOR A QUERIES FORM



VB6

Private Sub cmdOPTIMIZE_Click() 'COMPACT THE ACCESS DATABASE

Dim tempvar As String
Dim tempvarX As String
Dim fileName As String
Dim dirFileName As String
Dim SourceFile, DestinationFile

Close
Set dbs = Nothing
Set SourceFile = Nothing
Set DestinationFile = Nothing
'Set status bar.
    With sbStatusBar
      'This text will be displayed when the StatusBar is in Simple style.
       .Style = sbrNormal  ' Normal style.
       .SimpleText = "Working..."
       .Style = sbrSimple  ' Simple style.
       Refresh
    End With

'Create backup file name.
    tempvar = "XX"
    tempvarX = Trim(Str(Format(Date, "mmddyy")))
    fileName = tempvar + tempvarX + ".mdb"
    dirFileName = "XXXBU\" + fileName
       
'Make sure there isn't already a file with the name of the compacted database.
    On Error GoTo errorRTN2
    If Dir(dirFileName) <> "" Then Kill dirFileName
   
'Makes temp backup before optimization.
    On Error GoTo errorRTN2
    If Dir("tempBU.mdb") <> "" Then Kill "tempBU.mdb"
    SourceFile = "XXX.mdb"          'Define source file name.
    DestinationFile = "tempBU.mdb"  'Define target file name.
    On Error GoTo errorRTN2
    FileCopy SourceFile, DestinationFile    ' Copy source to target.

'Compacts (optimizes) the database.
    On Error GoTo errorRTN2
    DBEngine.CompactDatabase "XXX.mdb", dirFileName
   
'Copies optimized database over the original.
    On Error GoTo errorRTN2
    If Dir("XXX.mdb") <> "" Then Kill "CST.mdb"
    SourceFile = dirFileName        'Define source file name.
    DestinationFile = "XXX.mdb"     'Define target file name.
    On Error GoTo errorRTN2
    FileCopy SourceFile, DestinationFile    ' Copy source to target.
    MsgBox ("Database optimized and a " + dirFileName + " backup copy made.")

Close
tempvar = ""
tempvarX = ""
fileName = ""
dirFileName = ""
Set SourceFile = Nothing
Set DestinationFile = Nothing

Exit Sub

errorRTN2:
    MsgBox ("File conflict problem.  Exit/Restart application and try again.")

End Sub 'END OF OPTIMIZE/COMPACT PROGRAM



VB6

Private Sub cmdBACKUPdatabase_Click() 'BACKUP THE DATABASE

Dim tempvar As String
Dim tempvarX As String
Dim fileName As String
Dim dirFileName As String
Dim SourceFile, DestinationFile

Close
tempvar = ""
tempvarX = ""
fileName = ""
dirFileName = ""

Set dbs = Nothing
Set SourceFile = Nothing
Set DestinationFile = Nothing

'Set status bar.
    With sbStatusBar
      ' This text will be displayed when the StatusBar is in Simple style.
       .Style = sbrNormal  ' Normal style.
       .SimpleText = "Working..."
       .Style = sbrSimple  ' Simple style.
       Refresh
    End With
 
'Create backup file name.
    tempvar = "XX"
    tempvarX = Trim(Str(Format(Date, "mmddyy")))
    fileName = tempvar + tempvarX + ".mdb"
    dirFileName = "XXBU\" + fileName
   
'Make sure there isn't already a file with the name of the backup file.
    If Dir(dirFileName) <> "" Then Kill dirFileName

' Make the Backup.
    SourceFile = "XX.mdb"             'Define source file name.
    DestinationFile = dirFileName      'Define target file name.
    On Error GoTo errorRTN
    FileCopy SourceFile, DestinationFile    ' Copy source to target.

    Me.sbStatusBar.Style = sbrNormal  ' Normal style.
    MsgBox ("A Backup copy named " + dirFileName + " has been made.")

Close
tempvar = ""
tempvarX = ""
fileName = ""
dirFileName = ""
Set SourceFile = Nothing
Set DestinationFile = Nothing
'Me.Hide
'Me.Show

Exit Sub

errorRTN:
    MsgBox ("File conflict problem.  Exit/Restart application and try again.")
   
End Sub 'END OF DATABASE BACKUP PROGRAM



VB6
'=======================================================
'PRINT FORM CODE
Private Sub cmdPrintScreen_Click()
    Me.PrintForm
End Sub
'=======================================================
'EXIT APPLICATION CODE
Private Sub cmdEXIT_Click() 'EXIT APPLICATION
    End
End Sub 'END OF EXIT AP
'=======================================================
'LOGIN AND PASSWORD CODE
'Use Wizard
'=======================================================



Visual Basic 6.0 and SQL Code Examples Library Two - Beginner and Advanced


VB6

Private Sub cmdWMSupdate_Click() 'CHAINING TOGETHER SUBROUTINES, ETC.

    Dim Uchoice As Integer
   
    XX = Trim(InputBox("Please enter date.", "THE TARGET DATE", "mm/dd/yy"))
    If XX <> "" And XX <> "mm/dd/yy" Then
        theLatestDate = CDate(XX)
    Else
        MsgBox ("Invalid Date. Process cancelled.")
        varCANCEL = True
        GoTo NeverMind
    End If
       
    theEarliestDate = DateAdd("d", -1, Format(theLatestDate, "mm") + "/01/" + Format(theLatestDate, "yy"))

    varSTARTDATE = CDate(theEarliestDate) 'global save for later use.
    varENDDATE = CDate(theLatestDate) 'global save for later use.

   
    Uchoice = MsgBox("Please insert the PCfile.txt disk into drive A:", vbOKCancel)
    Me.Refresh
    If Uchoice = 2 Then
        Uchoice = MsgBox("No disk, but will update database totals.", vbOKCancel)
        If Uchoice = 2 Then
            GoTo NeverMind  'ie: bail out of this procedure
        Else
            GoTo JustUpdateTotals
        End If
    Else
        'Proceed...
        varCANCEL = False
        varPROCEED = True
    End If
   
    Me.Refresh
    theMSG = "Emptying old data from TEMPUP table."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh
    Call cmdWMSupdate1  'EMPTY'S TEMPUP TABLE
   
    theMSG = "Importing data from diskette in A:drive."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh
    Call cmdWMSupdate2 '  IMPORTS DISKETTE DATA INTO TEMPUP

    If varCANCEL Then  '  INVALID DATE.
        MsgBox ("Invalid Date. Process cancelled.")
        GoTo NeverMind
    Else
    End If
   
    theMSG = "Checking for duplicate records."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh
    Call cmdWMSupdate3 'CHECK FOR DUPLICATE RECORDS

    If varCANCEL Then  'THERE WERE DUPS OR USER CANCELED FOR SOME REASON.
        MsgBox ("Process canceled.")
        GoTo NeverMind
    Else
    End If

    theMSG = "Doing this, that, and the other in the TEMPUP table."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh
    Call cmdWMSupdate4  'MAKES ALL THE SPECIFIED CHANGES IN TEMPUP
                        'AND CHECKS FOR NEW SKU'S.
   
    If varCANCEL Then
        GoTo NeverMind 'THERE ARE MISSING SKU NUMBERS
    Else
    End If
   
    theMSG = "Data review mode."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh

'    Call cmdWMSupdateShow '  VIEWS IMPORTED/PROCESSED TEMPUP.
'
'    'USER GIVEN CHANCE TO BAIL OUT BEFORE MERGING DATA WITH PRODUCTION FILES
'    Uchoice = MsgBox("Ready to merge with Production Files.  Continue?", vbYesNoCancel, "Decision Point")
'    If Uchoice <> "6" Then '"6" means "yes"
'        MsgBox ("Process canceled. Production files still not touched.")
'        GoTo NeverMind
'    End If

    theMSG = "Updating production files."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh
    Call cmdWMSupdate5 'TRANSFER DATA FROM TEMPUP TO PRODUCTION

JustUpdateTotals:

    Call cmdWMSupdate6 'UPDATE SKU FILE QUANTITY TOTALS

    MsgBox ("Production files updated.")

NeverMind:
    With sbStatusBar
        .Style = sbrNormal  ' Normal style.
    End With
    Close
    Me.Refresh

End Sub 'END OF MAIN IMPORT PROGRAM THAT CALLS ALL THE OTHER RELATED SUBPROGRAMS.



VB6 and SQL

Private Sub cmdWMSupdate1() 'EMPTY TEMPUP TABLE
   
Dim dbs As Database

Set dbs = OpenDatabase(gsDatabase)

dbs.Execute "DELETE * FROM TEMPUP;"
   
dbs.Close

Set dbs = Nothing

End Sub 'END OF EMPTY TEMPUP TABLE PROGRAM.



VB6

Private Sub cmdWMSupdate2() 'Import text data from disk in A:drive into the TEMPUP table.

Dim theRecord As Record  ' "Record" defined in DECLARATIONS section of MODULE1.bas
Dim theRecNo As Integer

Open "A:\PCFILE.TXT" For Random As #1 Len = Len(theRecord) + 2
theRecNo = 1

'    Record 'Description of record content
'    theTYPE As String * 2
'    SKU As String * 6
'    QTY As String * 5
'    PO_NUMBER As String * 10
'    VEND As String * 4
'    XYZ_NUMBER As String * 24
'    ABCNO As String * 10
'    theDATE As String * 8
'    VVV_NUMBER As String * 11
'    TRCODE As String * 2
'    SCRAP As String * 174

Set wrkJET = CreateWorkspace("", "admin", "", dbUseJet)
Set dbsCurrent = wrkJET.OpenDatabase(gsDatabase, True)
Set rstTEMPUP = dbsCurrent.OpenRecordset("tempup")

Do While Not EOF(1) ' Loop until end of file.
    Get #1, theRecNo, theRecord
    With rstTEMPUP
        If theRecord.SKU > "111" Or theRecord.theTYPE > "a" Then
            .AddNew
            .theTYPE = theRecord.theTYPE
            .SKU = theRecord.SKU
            .QTY = theRecord.QTY
            .PO_NUMBER = theRecord.PO_NUMBER
            .VEND = theRecord.VEND
            .XYZ_NUMBER = theRecord.XYZ_NUMBER
            .ABCNO = theRecord.ABCNO
            .theDATE = varENDDATE
            .Update
        Else
        End If
    End With
    theRecNo = theRecNo + 1
Loop

'With rstTEMPUP
'    .MoveLast
'    If .SKU < "111" Or .theTYPE < "a" Then
'        .Edit      'Gets rid of
'        .Delete    'blank record at end
'        .MovePrevious
'    Else
'    End If
'End With

'With rstTEMPUP
'    .MoveLast
'    If .SKU < "111" Or .theTYPE < "a" Then
'        .Edit      'Gets rid of
'        .Delete    'blank record at end
'        .MovePrevious
'    Else
'    End If
'End With

Close #1            ' Close text file.
   
rstTEMPUP.Close     ' Close Access file.
dbsCurrent.Close    ' Close Access database.
wrkJET.Close
Set rstTEMPUP = Nothing
Set dbsCurrent = Nothing
Set wrkJET = Nothing

NeverMind:

End Sub 'END OF IMPORT TEXT DATA INTO TEMPUP



VB6 and SQL

Private Sub cmdWMSupdate3() 'CHECK FOR DUPS

    Dim dbs As Database
    Dim supervar As Date
    Dim strSQL As String
    Dim rst As Recordset
   
Set dbs = OpenDatabase(gsDatabase)
   
'do some insurance cleanup, sometimes drop table doesn't work
On Error Resume Next
dbs.Execute "DELETE * FROM TRANSDUPCHECK;"
Err.Clear
On Error Resume Next
dbs.Execute "DELETE * FROM TRANSDUPCHECK2;"
Err.Clear
On Error Resume Next
dbs.Execute "DELETE * FROM DUPSLIST;"
Err.Clear

dbs.Close
Set dbs = Nothing
Set dbs = OpenDatabase(gsDatabase)
 
    supervar = varSTARTDATE
   
    'FIRST WE SELECT OUT THE MTD TRANSACTION RECORDS
    On Error Resume Next
    dbs.Execute "DROP TABLE [TRANSDUPCHECK];"
    Err.Clear
   
    strSQL = "SELECT XXX_NUMBER, SKU, QTY INTO TRANSDUPCHECK " _
             & "From TRANSACTION WHERE " _
             & "(((TRANSACTION.THEDATE)>#" & supervar & "#)) AND " _
             & "(TRANSACTION.TRCODE) <>'40';"
    dbs.Execute (strSQL)

    'NEXT WE SELECT OUT THE SAME THREE CHECK FIELDS FROM TEMPUP
    On Error Resume Next
    dbs.Execute "DROP TABLE [TRANSDUPCHECK2];"
    Err.Clear

    strSQL = "SELECT XXX_NUMBER, SKU, QTY INTO TRANSDUPCHECK2 " _
             & "From TEMPUP WHERE TRCODE <>'40';"
    dbs.Execute (strSQL)
       
    'NEXT WE COMBINE THE TWO TABLES INTO ONE
    strSQL = "INSERT INTO TRANSDUPCHECK " _
             & "SELECT * FROM TRANSDUPCHECK2;"
    dbs.Execute (strSQL)
   
    'NOW WE CHECK FOR DUPLICATE RECORDS AND PUT DUPLICATES IN DUPLIST TABLE.
    On Error Resume Next
    dbs.Execute "DROP TABLE [DUPSLIST];"
    Err.Clear

    strSQL = "SELECT DISTINCTROW " _
             & "First(TRANSDUPCHECK.XXX_NUMBER) AS [XXX_NUMBER Field], " _
             & "First(TRANSDUPCHECK.SKU) AS [SKU Field], " _
             & "First(TRANSDUPCHECK.QTY) AS [QTY Field], " _
             & "Count(TRANSDUPCHECK.XXX_NUMBER) AS NumberOfDups " _
             & "INTO DUPSLIST From TRANSDUPCHECK " _
             & "GROUP BY TRANSDUPCHECK.XXX_NUMBER, " _
             & "TRANSDUPCHECK.SKU, TRANSDUPCHECK.QTY " _
             & "HAVING (((Count(TRANSDUPCHECK.XXX_NUMBER))>1) " _
             & "AND ((Count(TRANSDUPCHECK.QTY))>1));"
    dbs.Execute (strSQL)

    'GIVE USER CHANCE TO VIEW DUPS (IF ANY).

    With dbs
        ' Open table-type Recordset and show RecordCount
        ' property.
        Set rst = .OpenRecordset("DUPSLIST")
        If rst.RecordCount > 0 Then
            On Error Resume Next
            Call cmdWMSduplicateShow
            Err.Clear
        Else
        End If
        On Error Resume Next
        rst.Close
        Err.Clear
   End With

   
NeverMind3:
Close
Set dbs = Nothing

End Sub 'END OF DUPLICATES SEARCH



VB6

Private Sub cmdWMSupdateShow() ' GIVE USER CHANCE TO VIEW TEMPUP AND BAIL OUT IF NEEDED.

    Dim f As New frmTEMPUP
    Dim ff As New frmDataGrid
    f.Show
    Set ff.Data1.Recordset = f.Data1.Recordset
    ff.Caption = "Processed TEMPUP(pcfile.txt) data"
    ff.Show 1
    ff.Hide
    f.Hide
   
End Sub 'TEMPUP FORM


Private Sub cmdWMSduplicateShow() 'GIVES USER VIEW OF DUPLICATES

    Dim f As New frmDUPLIST
    Dim ff As New frmDataGrid
    f.Show
    Set ff.Data1.Recordset = f.Data1.Recordset
    ff.Caption = f.Caption
    ff.Show 1
    ff.Hide
    f.Hide
    f.Show 1
    f.Hide
    Unload f
    Unload ff
   
End Sub 'DUPLIST FORM SHOWING DUPSFOUND TABLE



VB6

Private Sub cmdWMSupdate4() '  MAKES ALL THE SPECIFIED CHANGES IN TEMPUP

Dim thedate As Date
Dim IBmsg As String
Dim IBtitle As String
Dim IBdefault As String

ICSdate = varENDDATE 'SETS XXX DATE FROM EARLIER USER INPUT.

Set wrkJET = CreateWorkspace("", "admin", "", dbUseJet)
Set dbsCurrent = wrkJET.OpenDatabase(gsDatabase, True)
Set rstTEMPUP = dbsCurrent.OpenRecordset("TEMPUP")
Set rstSKU = dbsCurrent.OpenRecordset("THEGFILE")

theMSG = "Modifying the TEMPUP table with all the changes,fixes, etc."
    With sbStatusBar
        'This text will be displayed when the StatusBar is in Simple style.
        .Style = sbrNormal  ' Normal style.
        .SimpleText = theMSG
        .Style = sbrSimple  ' Simple style.
    End With
    Me.Refresh

Counter = 0

With rstTEMPUP
   
    .MoveFirst
   
    While Not .EOF
        Counter = Counter + 1
        Debug.Print CStr(Counter)
        .Edit
       
        'PUTS THE PROC DATE IN DATE FIELD.
        .theDATE = xxxdate
 
        'UPDATES ALL TYPE XYZ ORDERS TO CODE 80.
        If .theTYPE = "M2" And Mid(.XXX_NUMBER, 19, 1) <> "1" Then
            .TRCODE = "80"
        End If
       
        'UPDATES the M2 RECORDS WITH CODE "82".
        If .theTYPE = "M2" And Mid(.XXX_NUMBER, 19, 1) = "1" Then
            .TRCODE = "82"
        End If
       
        'EXTRACTS ACCOUNT CODE AND UPDATES M2 RECORDS.
        If .theTYPE = "M2" And IsNull(.ACCTCODE) Then
           .ACCTCODE = Left(.XXX_NUMBER, 13)
        Else
        End If
           
        'UPDATES THE RECEIVING RECORDS TO CODES 30 AND 36.
        If .theTYPE = "R1" Then
            .TRCODE = "30"
        End If
        If .theTYPE = "R2" Then
            .TRCODE = "36"
        End If
       
        'UPDATES THE WORKORDERS TO CODE 40
        If .theTYPE = "P1" Or .theTYPE = "P2" Then
            .TRCODE = "40"
        End If
           
        'UPDATES THE WORKORDER'S WORKORDER# FROM THE WWW NUMBER FIELD.
        If .TRCODE = "40" Then
            .wo_number = Trim(.WWW_NUMBER)
            .WWW_NUMBER = Null
        Else
        End If
       
        'UPDATES THE CLAIM CODE
        If .theTYPE = "C1" Or .theTYPE = "C2" Then
            .TRCODE = "50"
            .ACCTCODE = Trim(.XXX_NUMBER)
            .XXX_NUMBER = Null
        Else
        End If
       
        'CODE 62 ADJUSTMENTS
        If .theTYPE = "A1" Or .theTYPE = "A2" Then
            .TRCODE = "62"
        Else
        End If
       
        'V2 update
        If theTYPE = "V2" Then
            .TRCODE = "72"
        Else
        End If
       
        'V1 update
        If theTYPE = "V1" Then
            .TRCODE = "75"
        Else
        End If
       
       
        'CHECK FOR ANY NEW SKU'S.
         SKUtransVar = Trim(CStr(.SKU))
         'strCountry = "Country = '" & strCountry & "'"
        With rstSKU
                .Index = "PrimaryKey"
                .Seek "=", SKUtransVar
                If .NoMatch Then
                    theMSGX = "SKU " + CStr(SKUtransVar) + " NOT FOUND! UPDATE SKUFILE FILE AND RERUN PROGRAM."
                    MsgBox (theMSGX)
                    varCANCEL = True
                Else
                End If
         End With
        .Update
        .MoveNext
        If varCANCEL Then
            GoTo theNext
        End If
    Wend
End With

theNext:
rstTEMPUP.Close
rstSKU.Close
dbsCurrent.Close
wrkJET.Close
Set rstTEMPUP = Nothing
Set rstSKU = Nothing
Set dbsCurrent = Nothing
Set wrkJET = Nothing

End Sub 'END OF UPDATING TRCODES AND CHECKING FOR MISSING(NEW) SKU'S



VB6 and SQL

Private Sub cmdWMSupdate5()
 'TRANSFER DATA FROM TEMPUP TO:
                            'TRANSACTION AND QQQ FILES
                            'PUT VEND NUMBER FROM SKU FILE INTO TRANSACTION FILE

Dim Counter As Integer

'OPEN DATABASE AND TABLES
Set wrkJET = CreateWorkspace("", "admin", "", dbUseJet)
Set dbsCurrent = wrkJET.OpenDatabase(gsDatabase)

Set rstTEMPUP = dbsCurrent.OpenRecordset("TEMPUP")
Set rstTRANSACTION = dbsCurrent.OpenRecordset("TRANSACTION")
Set rstMANFILE = dbsCurrent.OpenRecordset("PPPFILE")
Set rstCUSTOMER = dbsCurrent.OpenRecordset("CUSTOMER")
Set rstTRANCODE = dbsCurrent.OpenRecordset("TRANCODE")
Set rstVENDOR = dbsCurrent.OpenRecordset("VENDOR")
Set rstSKU = dbsCurrent.OpenRecordset("SKUFILE")

'FIRST WE TRANSFER TEMPUP DATA TO TRANSACTION

'On Error GoTo theNext
Counter = 0
With rstTEMPUP
    .MoveFirst
    While Not .EOF
        Counter = Counter + 1
        'FIRST WE TRANSFER TEMPUP DATA TO TRANSACTION TABLE
        rstTRANSACTION.MoveLast
        rstTRANSACTION.Edit
        rstTRANSACTION.AddNew
        rstTRANSACTION.XXX_NUMBER = .XXX_NUMBER
        rstTRANSACTION.PPP = .PPPNO
        rstTRANSACTION.SKU = .SKU
        rstTRANSACTION.QTY = .QTY
        rstTRANSACTION.ZZZDATE = .theDATE
        rstTRANSACTION.theTYPE = .theTYPE
        rstTRANSACTION.QQQ_NUMBER = .QQQ_NUMBER
        rstTRANSACTION.TRCODE = .TRCODE
        rstTRANSACTION.VEND = .VEND
        rstTRANSACTION.ACCTCODE = .ACCTCODE
        rstTRANSACTION.wo_number = .wo_number
        rstTRANSACTION.PO_NUMBER = .PO_NUMBER
        'NEXT WE FIGURE OUT THE VEND NUMBER AND
        'PLUG IT INTO THE TRANSACTION FILE
        If rstTRANSACTION.VEND < "1" Then
            SKUtransVar = Trim(CStr(rstTRANSACTION.SKU))
            With rstSKU
                .Index = "PrimaryKey"
                .Seek "=", SKUtransVar
                '.FindFirst SKUtransVar
                If .NoMatch Then
                    MsgBox ("SKU STILL NOT FOUND! VENDOR SET TO 9999.")
                    rstTRANSACTION.VEND = "9999"
                Else
                    rstTRANSACTION.VEND = Trim(CStr(.VENDOR))
                End If
            End With
        Else
        End If
        rstTRANSACTION.Update
        .MoveNext
    Wend
End With

rstTEMPUP.Close     ' Close files.
rstTRANSACTION.Close
rstVVVFILE.Close
rstCUSTOMER.Close
rstTRANCODE.Close
rstVENDOR.Close
rstSKU.Close
Set rstTEMPUP = Nothing
Set rstTRANSACTION = Nothing
Set rstEEEFILE = Nothing
Set rstCUSTOMER = Nothing
Set rstTRANCODE = Nothing
Set rstVENDOR = Nothing
Set rstSKU = Nothing

'LAST WE TRANSFER SAME TEMPUP DATA TO OTHERFILE
    strSQL = "INSERT INTO OTHERFILE " _
             & "(XNO, YDATE) " _
             & "SELECT DISTINCT " _
             & "TEMPUP.XNO, TEMPUP.YDATE " _
             & "FROM TEMPUP WHERE " _
             & "(((TEMPUP.XNO) Is Not Null));"
    dbsCurrent.Execute (strSQL)
   
theNext:
'Err.Clear

dbsCurrent.Close    ' Close database.
wrkJET.Close
Set dbsCurrent = Nothing
Set wrkJET = Nothing

End Sub 'END OF MOVING TEMPUP DATA TO TRANSACTION AND OTHERFILE, AND MOVING SKU VEND TO TRANSACTION



VB6 and SQL

Private Sub cmdWMSupdate6() 'UPDATE SKU TOTALS

    Dim dbs As Database
    Dim supervar As Date
    Dim strSQL As String
   
    Set dbs = OpenDatabase(gsDatabase)
   
thePrevMonthX = DateAdd("m", -1, varENDDATE)
ThePrevMonth = CStr(UCase(CStr(Format(thePrevMonthX, "mmm"))))
   
    On Error Resume Next
    dbs.Execute "DROP TABLE [TEMPX];"
    Err.Clear
    On Error Resume Next
    dbs.Execute "DROP TABLE [TEMPY];"
    Err.Clear

    supervar = varSTARTDATE

    'FIRST WE SELECT OUT THE MTD TRANSACTION RECORDS
    strSQL = "SELECT THEDATE, theTYPE, SKU, QTY INTO TEMPX " _
             & "From TRANSACTION WHERE " _
             & "(((TRANSACTION.THEDATE)>#" & supervar & "#));"
    dbs.Execute (strSQL)
   
    'NEXT WE CONVERT ALL THE INVENTORY REDUCTION
    'TRANSACTIONS QTY'S TO NEGATIVE NUMBERS.
    strSQL = "UPDATE TEMPX " _
             & "SET QTY = QTY*(-1) " _
             & "WHERE MID(theTYPE,2,1) = 2;"
    dbs.Execute (strSQL)
   
    'NEXT WE ADD UP ALL THE QTYS PER SKU.
    strSQL = "SELECT DISTINCTROW TEMPX.SKU, " _
             & "SUM(TEMPX.QTY) AS [QTYTTLS] " _
             & "INTO TEMPY " _
             & "FROM TEMPX GROUP BY TEMPX.SKU;"
    dbs.Execute (strSQL)
   
    'reset current balance to start of month
   strSQL = "UPDATE SKUFILE " _
         & "SET CURR_BAL = " _
         & ThePrevMonth _
         & ";"
    dbs.Execute (strSQL)
   
    'LAST WE ADD THESE TOTALS TO THE SKU CURRENT BALANCE.
    strSQL = " UPDATE SKUFILE LEFT JOIN " _
             & "TEMPY ON SKUFILE.SKU = TEMPY.SKU " _
             & "SET SKUFILE.CURR_BAL = [CURR_BAL] + [QTYTTLS] " _
             & "WHERE (((TEMPY.QTYTTLS) Is Not Null));"
    dbs.Execute (strSQL)

    dbs.Close
   
    Set dbs = Nothing
    strSQL = ""
    'DATA IMPORT AND ALL PROCESSING DONE.

End Sub 'END OF UPDATE SKU CURRENT BALANCE TOTALS



MESSING AROUND VB6 STATISTICAL CODE - Mostly beginner, excepting maybe for arrays

Binary City
This third segment you are now on has mostly beginner stuff, plus the not-so-beginner usage of arrays. This is some code I wrote and used awhile back for some fun statistical analysis work; is not work code; is not professional standard code; this segment is just fun, messing around code. This is programmer "worker-code", in that snippets were constantly being moved around and alternated to try different scenarios, thus the plethora of commented lines that you will see. The purpose of this page is to give lots and lots of examples of debugged syntax, nothing more.


Private Sub Form_Load()
Comparator = inputComparator
Comparator2 = inputComparator2
Comparator3 = inputComparator3
Comparator4 = inputComparator4
End Sub

Private Sub inputComparator_Change()
Comparator = inputComparator
Comparator2 = inputComparator2
Comparator3 = inputComparator3
Comparator4 = inputComparator4
End Sub
Private Sub inputComparator2_Change()
Comparator = inputComparator
Comparator2 = inputComparator2
Comparator3 = inputComparator3
Comparator4 = inputComparator4
End Sub
Private Sub inputComparator3_Change()
Comparator = inputComparator
Comparator2 = inputComparator2
Comparator3 = inputComparator3
Comparator4 = inputComparator4
End Sub
Private Sub inputComparator4_Change()
Comparator = inputComparator
Comparator2 = inputComparator2
Comparator3 = inputComparator3
Comparator4 = inputComparator4
End Sub
Private Sub InputEraseYN_Change()
If InputEraseYN = "y" Or InputEraseYN = "Y" Then
    EraseYN = True
Else
    EraseYN = False
End If

End Sub


Public Comparator As Integer
Public Comparator2 As Integer
Public Comparator3 As Integer
Public Comparator4 As Integer
Public cvara, cvarb, cvarc, cvard, cvare, cvarf As Integer
Public fvara, fvarb, fvarc, fvard, fvare, fvarf As Field
Public EraseYN As Boolean

Private Sub ComboND_Click()

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\combo\combo2010.mdb")
Set rstTEMPY = dbs.OpenRecordset("ff")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If

If EraseYN Then
ai = 0
While ai < 55
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
.MoveFirst

If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank

        .Update
        .MoveNext
    Wend
End If

cvara = 5
cvarb = 3
cvarc = 1
cvard = 1111
cvare = 1111
cvarf = 1111

.MoveFirst
'.Move 1180


'.Move 365

While Not .EOF  'combo NEXT DAY

'If .d3da = 9 Or .d3db = 9 Or .d3dc = 9 Or .d3na = 9 Or .d3nb = 9 Or .d3nc = 9 Then

'If .d3da = cvara Then
'If .d3db = cvarb Then 'predicted A of daily derby
'If .d3dc = cvarc Then 'predicted 2 of the fantasy 5's

'If .d3da = cvara And .d3db = cvarb Then  'predicted B of daily derby, 'kind of predicted C of daily derby
'If .d3da = cvara And .d3dc = cvarc Then
'If .d3db = cvarb And .d3dc = cvarc Then
'If .d3da = cvara And .d3db = cvarb And .d3dc = cvarc Then

'If .d3da = cvara Or .d3db = cvarb Then 'kind of predicted A of daily derby
'If .d3da = cvara Or .d3dc = cvarc Then
'If .d3db = cvarb Or .d3dc = cvarc Then  'kind of predicted B of daily derby
'If .d3da = cvara Or .d3db = cvarb Or .d3dc = cvarc Then 'kind of predicted B of daily derby

'If .f5b > 15 And .f5d < 25 Then
'If .f5b = .f5a + 1 And .f5d = .f5c + 1 Then
'If .f5b = .f5a + 1 Then
'If .f5d = .f5c + 1 Then

'If .f5c = .f5b + 1 And .f5d = .f5c + 1 Then
'If .f5c > 32 Then
'If .d3nc = 1 Then
'If True Then
'DAILY DERBY COMPARE
'If .dda = Comparator Then

'If (.dda = Comparator Or .DDB = Comparator Or .DDc = Comparator) Then
'If (ddd = Comparator Or .dde = Comparator Or .ddf = Comparator) Then
'If (ddd = Comparator And .dde = Comparator And .ddf = Comparator) Then
'If (.dda = Comparator Or .DDB = Comparator Or .ddc = Comparator Or .ddd = Comparator Or .dde = Comparator) Then
'If (.dda = Comparator Or .ddb = Comparator Or .ddc = Comparator Or .ddd = Comparator Or .dde = Comparator) And (.dda = Comparator2 Or .ddb = Comparator2 Or .ddc = Comparator2 Or .ddd = Comparator2 Or .dde = Comparator2) Then
'If (.dda = Comparator Or .ddb = Comparator Or .ddc = Comparator Or .ddd = Comparator Or .dde = Comparator) And (.dda = Comparator2 Or .ddb = Comparator2 Or .ddc = Comparator2 Or .ddd = Comparator2 Or .dde = Comparator2) And (.dda = Comparator3 Or .ddb = Comparator3 Or .ddc = Comparator3 Or .ddd = Comparator3 Or .dde = Comparator3) Then

'If .dde = 2 And .ddf = 0 Then

'If .f5c = 18 Then

'FANTASY FIVE COMPARE
'If (.f5a = Comparator Or .f5B = Comparator Or .f5c = Comparator Or .f5d = Comparator Or .f5e = Comparator) Then
'If (.f5a = Comparator Or .f5B = Comparator Or .f5c = Comparator Or .f5d = Comparator Or .f5e = Comparator) And (.f5a = Comparator2 Or .f5B = Comparator2 Or .f5c = Comparator2 Or .f5d = Comparator2 Or .f5e = Comparator2) Then
If (.f5a = Comparator Or .f5B = Comparator Or .f5c = Comparator Or .f5d = Comparator Or .f5e = Comparator) And (.f5a = Comparator2 Or .f5B = Comparator2 Or .f5c = Comparator2 Or .f5d = Comparator2 Or .f5e = Comparator2) And (.f5a = Comparator3 Or .f5B = Comparator3 Or .f5c = Comparator3 Or .f5d = Comparator3 Or .f5e = Comparator3) Then

    txtCounter(49) = txtCounter(49) + 1
   
    If Not .EOF Then   'combo NEXT DAY
       .Edit
       .fldprev = Comparator
           .Update
           .MoveNext
           On Error GoTo wrapitup
       
           'txtCounter(.d3na) = txtCounter(.d3na) + 1   'Daily 3 Night predictor
           'txtCounter(.d3nb) = txtCounter(.d3nb) + 1   'Daily 3 Night predictor
           'txtCounter(.d3nc) = txtCounter(.d3nc) + 1   'Daily 3 Night predictor
       
           'txtCounter(.d4a) = txtCounter(.d4a) + 1   'Daily 4 predictor
           'txtCounter(.d4b) = txtCounter(.d4b) + 1   'Daily 4 predictor
           'txtCounter(.d4c) = txtCounter(.d4c) + 1   'Daily 4 predictor
           'txtCounter(.d4d) = txtCounter(.d4d) + 1   'Daily 4 predictor
       
           'txtCounter(.dda) = txtCounter(.dda) + 1   'Daily Derby predictor
           'txtCounter(.DDB) = txtCounter(.DDB) + 1   'Daily Derby predictor
           'txtCounter(.DDc) = txtCounter(.DDc) + 1   'Daily Derby predictor
           'txtCounter(.ddd) = txtCounter(.ddd) + 1   'Daily Derby predictor
           'txtCounter(.dde) = txtCounter(.dde) + 1   'Daily Derby predictor
           'txtCounter(.ddf) = txtCounter(.ddf) + 1   'Daily Derby predictor
           '.MoveNext
           'txtCounter(.dda) = txtCounter(.dda) + 1   'Daily Derby predictor
           'txtCounter(.DDB) = txtCounter(.DDB) + 1   'Daily Derby predictor
           'txtCounter(.DDc) = txtCounter(.DDc) + 1   'Daily Derby predictor
           'txtCounter(.ddd) = txtCounter(.ddd) + 1   'Daily Derby predictor
           'txtCounter(.dde) = txtCounter(.dde) + 1   'Daily Derby predictor
           'txtCounter(.ddf) = txtCounter(.ddf) + 1   'Daily Derby predictor
     
           txtCounter(.f5a) = txtCounter(.f5a) + 1   'F5 predictor
           txtCounter(.f5B) = txtCounter(.f5B) + 1   'F5 predictor
           txtCounter(.f5c) = txtCounter(.f5c) + 1   'F5 predictor
           txtCounter(.f5d) = txtCounter(.f5d) + 1   'F5 predictor
           txtCounter(.f5e) = txtCounter(.f5e) + 1   'F5 predictor
           .MoveNext
           txtCounter(.f5a) = txtCounter(.f5a) + 1   'F5 predictor
           txtCounter(.f5B) = txtCounter(.f5B) + 1   'F5 predictor
           txtCounter(.f5c) = txtCounter(.f5c) + 1   'F5 predictor
           txtCounter(.f5d) = txtCounter(.f5d) + 1   'F5 predictor
           txtCounter(.f5e) = txtCounter(.f5e) + 1   'F5 predictor
       
           .Move -1
    End If


Else

   .MoveNext

End If

Wend
End With
wrapitup:
rstTEMPY.Close


End Sub


Private Sub ComboSD_Click()

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\combo\combo.mdb")
Set rstTEMPY = dbs.OpenRecordset("combo")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If

If EraseYN Then
ai = 0
While ai < 55
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
.MoveFirst

If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank

        .Update
        .MoveNext
    Wend
End If

cvara = 5
cvarb = 3
cvarc = 1
cvard = 1111
cvare = 1111
cvarf = 1111

.MoveFirst
.Move 365

While Not .EOF

If .DDc = 7 Then

'If .d3da = cvara Then
'If .d3db = cvarb Then 'predicted A of daily derby
'If .d3dc = cvarc Then 'predicted 2 of the fantasy 5's

'If .d3da = cvara And .d3db = cvarb Then  'predicted B of daily derby, 'kind of predicted C of daily derby
'If .d3da = cvara And .d3dc = cvarc Then
'If .d3db = cvarb And .d3dc = cvarc Then
'If .d3da = cvara And .d3db = cvarb And .d3dc = cvarc Then

'If .d3da = cvara Or .d3db = cvarb Then 'kind of predicted A of daily derby
'If .d3da = cvara Or .d3dc = cvarc Then
'If .d3db = cvarb Or .d3dc = cvarc Then  'kind of predicted B of daily derby
'If .d3da = cvara Or .d3db = cvarb Or .d3dc = cvarc Then 'kind of predicted B of daily derby

    txtCounter(49) = txtCounter(49) + 1
   
    If Not .EOF Then
       .Edit
       .fldprev = Comparator
           .Update
           On Error GoTo wrapitup
       
           'txtCounter(.d3na) = txtCounter(.d3na) + 1   'Daily 3 Night predictor
           'txtCounter(.d3nb) = txtCounter(.d3nb) + 1   'Daily 3 Night predictor
           'txtCounter(.d3nc) = txtCounter(.d3nc) + 1   'Daily 3 Night predictor
       
           'txtCounter(.d4a) = txtCounter(.d4a) + 1   'Daily 4 predictor
           'txtCounter(.d4b) = txtCounter(.d4b) + 1   'Daily 4 predictor
           'txtCounter(.d4c) = txtCounter(.d4c) + 1   'Daily 4 predictor
           'txtCounter(.d4d) = txtCounter(.d4d) + 1   'Daily 4 predictor
       
           'txtCounter(.dda) = txtCounter(.dda) + 1   'Daily Derby predictor
           'txtCounter(.DDB) = txtCounter(.DDB) + 1   'Daily Derby predictor
           'txtCounter(.DDc) = txtCounter(.DDc) + 1   'Daily Derby predictor
           txtCounter(.ddd) = txtCounter(.ddd) + 1   'Daily Derby predictor
           'txtCounter(.dde) = txtCounter(.dde) + 1   'Daily Derby predictor
           'txtCounter(.ddf) = txtCounter(.ddf) + 1   'Daily Derby predictor
     
           'txtCounter(.f5a) = txtCounter(.f5a) + 1   'F5 predictor
           'txtCounter(.f5b) = txtCounter(.f5b) + 1   'F5 predictor
           'txtCounter(.f5c) = txtCounter(.f5c) + 1   'F5 predictor
           'txtCounter(.f5d) = txtCounter(.f5d) + 1   'F5 predictor
           'txtCounter(.f5e) = txtCounter(.f5e) + 1   'F5 predictor
     
           .MoveNext
    End If


Else

   .MoveNext

End If

Wend
End With
wrapitup:
rstTEMPY.Close





End Sub


Private Sub Command1_Click() 'F5 predictor

' ab, ac, cd

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\combo\combo.mdb")
Set rstTEMPY = dbs.OpenRecordset("combo")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 55
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank

        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 2377

'binary processes


While Not .EOF

.Edit
GoTo zork

'binary totals process

vc = 0 'varcomp
.fldAbin = 0
.fldBbin = 0
.fldCbin = 0
.fldDbin = 0
.fldEbin = 0

vc = .flda
If vc = 1 Or vc = 2 Or vc = 4 Or vc = 8 Or vc = 16 Or vc = 32 Then
.fldAbin = 1
End If
If vc = 3 Or vc = 5 Or vc = 6 Or vc = 9 Or vc = 10 Or vc = 12 Or vc = 17 Or vc = 18 Or vc = 20 Or vc = 24 Or vc = 33 Or vc = 34 Or vc = 36 Then
.fldAbin = 2
End If
If vc = 7 Or vc = 11 Or vc = 13 Or vc = 14 Or vc = 19 Or vc = 21 Or vc = 22 Or vc = 25 Or vc = 26 Or vc = 28 Or vc = 35 Or vc = 37 Or vc = 38 Then
.fldAbin = 3
End If
If vc = 15 Or vc = 23 Or vc = 27 Or vc = 29 Or vc = 30 Or vc = 39 Then
.fldAbin = 4
End If
If vc = 31 Then
.fldAbin = 5
End If




vc = .fldb
If vc = 1 Or vc = 2 Or vc = 4 Or vc = 8 Or vc = 16 Or vc = 32 Then
.fldBbin = 1
End If
If vc = 3 Or vc = 5 Or vc = 6 Or vc = 9 Or vc = 10 Or vc = 12 Or vc = 17 Or vc = 18 Or vc = 20 Or vc = 24 Or vc = 33 Or vc = 34 Or vc = 36 Then
.fldBbin = 2
End If
If vc = 7 Or vc = 11 Or vc = 13 Or vc = 14 Or vc = 19 Or vc = 21 Or vc = 22 Or vc = 25 Or vc = 26 Or vc = 28 Or vc = 35 Or vc = 37 Or vc = 38 Then
.fldBbin = 3
End If
If vc = 15 Or vc = 23 Or vc = 27 Or vc = 29 Or vc = 30 Or vc = 39 Then
.fldBbin = 4
End If
If vc = 31 Then
.fldBbin = 5
End If


vc = .fldc
If vc = 1 Or vc = 2 Or vc = 4 Or vc = 8 Or vc = 16 Or vc = 32 Then
.fldCbin = 1
End If
If vc = 3 Or vc = 5 Or vc = 6 Or vc = 9 Or vc = 10 Or vc = 12 Or vc = 17 Or vc = 18 Or vc = 20 Or vc = 24 Or vc = 33 Or vc = 34 Or vc = 36 Then
.fldCbin = 2
End If
If vc = 7 Or vc = 11 Or vc = 13 Or vc = 14 Or vc = 19 Or vc = 21 Or vc = 22 Or vc = 25 Or vc = 26 Or vc = 28 Or vc = 35 Or vc = 37 Or vc = 38 Then
.fldCbin = 3
End If
If vc = 15 Or vc = 23 Or vc = 27 Or vc = 29 Or vc = 30 Or vc = 39 Then
.fldCbin = 4
End If
If vc = 31 Then
.fldCbin = 5
End If



vc = .fldd
If vc = 1 Or vc = 2 Or vc = 4 Or vc = 8 Or vc = 16 Or vc = 32 Then
.fldDbin = 1
End If
If vc = 3 Or vc = 5 Or vc = 6 Or vc = 9 Or vc = 10 Or vc = 12 Or vc = 17 Or vc = 18 Or vc = 20 Or vc = 24 Or vc = 33 Or vc = 34 Or vc = 36 Then
.fldDbin = 2
End If
If vc = 7 Or vc = 11 Or vc = 13 Or vc = 14 Or vc = 19 Or vc = 21 Or vc = 22 Or vc = 25 Or vc = 26 Or vc = 28 Or vc = 35 Or vc = 37 Or vc = 38 Then
.fldDbin = 3
End If
If vc = 15 Or vc = 23 Or vc = 27 Or vc = 29 Or vc = 30 Or vc = 39 Then
.fldDbin = 4
End If
If vc = 31 Then
.fldDbin = 5
End If


vc = .flde
If vc = 1 Or vc = 2 Or vc = 4 Or vc = 8 Or vc = 16 Or vc = 32 Then
.fldEbin = 1
End If
If vc = 3 Or vc = 5 Or vc = 6 Or vc = 9 Or vc = 10 Or vc = 12 Or vc = 17 Or vc = 18 Or vc = 20 Or vc = 24 Or vc = 33 Or vc = 34 Or vc = 36 Then
.fldEbin = 2
End If
If vc = 7 Or vc = 11 Or vc = 13 Or vc = 14 Or vc = 19 Or vc = 21 Or vc = 22 Or vc = 25 Or vc = 26 Or vc = 28 Or vc = 35 Or vc = 37 Or vc = 38 Then
.fldEbin = 3
End If
If vc = 15 Or vc = 23 Or vc = 27 Or vc = 29 Or vc = 30 Or vc = 39 Then
.fldEbin = 4
End If
If vc = 31 Then
.fldEbin = 5
End If

.flagbin1 = Null
If .fldAbin = 1 Or .fldBbin = 1 Or .fldCbin = 1 Or .fldDbin = 1 Or .fldEbin = 1 Then
.flagbin1 = 1
End If

.flagbin2 = Null
If .fldAbin = 2 Or .fldBbin = 2 Or .fldCbin = 2 Or .fldDbin = 2 Or .fldEbin = 2 Then
.flagbin2 = 2
End If

.flagbin3 = Null
If .fldAbin = 3 Or .fldBbin = 3 Or .fldCbin = 3 Or .fldDbin = 3 Or .fldEbin = 3 Then
.flagbin3 = 3
End If

.flagbin4 = Null
If .fldAbin = 4 Or .fldBbin = 4 Or .fldCbin = 4 Or .fldDbin = 4 Or .fldEbin = 4 Then
.flagbin4 = 4
End If

.flagbin5 = Null
If .fldAbin = 5 Or .fldBbin = 5 Or .fldCbin = 5 Or .fldDbin = 5 Or .fldEbin = 5 Then
.flagbin5 = 5
End If

.flagbin = Null
If .flagbin1 = 1 Or .flagbin4 = 4 Or .flagbin5 = 5 Then
.flagbin = 99
End If

.fldbintotal = .fldAbin + .fldBbin + .fldCbin + .fldDbin + .fldEbin

'end binary totals process
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'-----------------------------------------------------------------------------
'binary positional process

vc = 0 'varcomp
.fldAbinpos = 0
.fldBbinpos = 0
.fldCbinpos = 0
.fldDbinpos = 0
.fldEbinpos = 0

'If vc = 1 Or vc = 6 Or vc = 7 Or vc = 10 Or vc = 11 Or vc = 12 Or vc = 13 Or vc = 18 Or vc = 19 Or vc = 21 Or vc = 36 Or vc = 37 Then
'vc = 1 Or vc = 3 Or vc = 9 Or vc = 27

'If vc <> 20 And vc <> 21 And vc <> 22 And vc <> 23 And vc <> 24 And vc <> 25 And vc <> 26 And vc <> 27 And vc <> 28 And vc <> 29 And vc <> 30 And vc <> 31 Then
'If vc < 20 And vc > 31 Then

vc = .flda
If vc < 8 Or vc > 23 Then
'If (vc > 8 And vc < 18) Or (vc > 35 And vc < 40) Then
'If vc = 1 Or vc = 4 Or vc = 7 Or vc = 10 Or vc = 13 Or vc = 16 Or vc = 19 Or vc = 22 Or vc = 25 Or vc = 28 Or vc = 31 Or vc = 34 Or vc = 37 Then
.fldAbinpos = 1
End If

vc = .fldb
If vc < 8 Or vc > 23 Then
'If (vc > 8 And vc < 18) Or (vc > 35 And vc < 40) Then
'If vc = 1 Or vc = 4 Or vc = 7 Or vc = 10 Or vc = 13 Or vc = 16 Or vc = 19 Or vc = 22 Or vc = 25 Or vc = 28 Or vc = 31 Or vc = 34 Or vc = 37 Then
.fldBbinpos = 1
End If

vc = .fldc
If vc < 8 Or vc > 23 Then
'If (vc > 8 And vc < 18) Or (vc > 35 And vc < 40) Then
'If vc = 1 Or vc = 4 Or vc = 7 Or vc = 10 Or vc = 13 Or vc = 16 Or vc = 19 Or vc = 22 Or vc = 25 Or vc = 28 Or vc = 31 Or vc = 34 Or vc = 37 Then
.fldCbinpos = 1
End If

vc = .fldd
If vc < 8 Or vc > 23 Then
'If (vc > 8 And vc < 18) Or (vc > 35 And vc < 40) Then
'If vc = 1 Or vc = 4 Or vc = 7 Or vc = 10 Or vc = 13 Or vc = 16 Or vc = 19 Or vc = 22 Or vc = 25 Or vc = 28 Or vc = 31 Or vc = 34 Or vc = 37 Then
.fldDbinpos = 1
End If

vc = .flde
If vc < 8 Or vc > 23 Then
'If (vc > 8 And vc < 18) Or (vc > 35 And vc < 40) Then
'If vc = 1 Or vc = 4 Or vc = 7 Or vc = 10 Or vc = 13 Or vc = 16 Or vc = 19 Or vc = 22 Or vc = 25 Or vc = 28 Or vc = 31 Or vc = 34 Or vc = 37 Then
.fldEbinpos = 1
End If

.flagbinpos = Null
.fldbinpostotal = 0
.fldbinpostotal = .fldAbinpos + .fldBbinpos + .fldCbinpos + .fldDbinpos + .fldEbinpos
'If .fldAbinpos = 1 Or .fldBbinpos = 1 Or .fldCbinpos = 1 Or .fldDbinpos = 1 Or .fldEbinpos = 1 Then
If .fldbinpostotal = 5 Then
.flagbinpos = 99
End If

'end binary positional process





.Update

.MoveNext
Wend
'End If

'END BINARY PROCESS
zork:

    .MoveFirst

    '.Move 365 * 3

   While Not .EOF
    'If True Then

    'If .p5 > 0 Then
    'txtCounter(50) = txtCounter(50) + 1
    'End If

    'If .p5 < 1 Then
    'txtCounter(51) = txtCounter(51) + 1
    'End If

    'If True Then

    'If .p1 > 0 And .p4 = 0 And .p5 = 0 Then

    'If (.fldb = .flda + 1) And .flde = .fldd + 10 Then

    'If .p1 + .p2 + .p3 + .p4 + .p5 > 0 Then

    'If .fldd = .fldc + 4 And .fldc = .fldb + 4 Then

    'If .fldc = .fldb * 2 Then

    'If .flde - .fldc = 5 Then
    'If .fldc = 26 And .flde = 33 Then   '
    'If True Then
    'If .fldc = 18 Or .fldc = 19 Or .fldc = 23 Or .fldc = 24 Then

    'If .fldc = 7 Then
    'If .flde = 35 Then

    'If (.flda < 16 Or .flda > 24) And (.fldb < 16 Or .fldb > 24) And (.fldc < 16 Or .fldc > 24) And (.fldd < 16 Or .fldd > 24) And (.flde < 16 Or .flde > 24) Then
   
    'If (.fldc = .fldb + 1 And .fldb = .flda + 1) Or (.fldd = .fldc + 1 And .fldc = .fldb + 1) Or (.flde = .fldd + 1 And .fldd = .fldc + 1) Then

    'If .flde = .flda + .fldd Then

    'If True Then

    'If (.flagbinpos = 99) Then
    'S = 2

    'If .flde - .flda = S Then

    'If ((.fldb - .flda = S) Or (.fldc - .flda = S) Or (.fldd - .flda = S) Or (.flde - .flda = S)) Or ((.fldc - .fldb = S) Or (.fldd - .fldb = S) Or (.flde - .fldb = S)) Or ((.fldd - .fldc = S) Or (.flde - .fldc = S)) Or ((.flde - .fldd = S)) Then

    'If .flde < 31 Then

    'If .flda > 9 And .flde < 22 Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3 Or .fldd = Comparator3 Or .flde = Comparator3) Then

    'If .flda + .fldb + .fldc + .fldd + .flde = 88 Then '#($)
 
     'If .flda > 8 And .flde < 31 Then
 
    'If (.flde = .flda + .fldc) Then
    'If .fldc = 32 Then  '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 40 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(49) = txtCounter(49) + 1
   
        If .flagbinpos = 99 Then
        txtCounter(48) = txtCounter(48) + 1
        End If

        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                '.fldcalc1 = .flda + .fldb + .fldc + .fldd + .flde
                .Update
                On Error GoTo wrapitup
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                txtCounter(.fldd) = txtCounter(.fldd) + 1
                txtCounter(.flde) = txtCounter(.flde) + 1
                .MoveNext  'loopy
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                txtCounter(.fldd) = txtCounter(.fldd) + 1
                txtCounter(.flde) = txtCounter(.flde) + 1
                .MoveNext  'loopy
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                txtCounter(.fldd) = txtCounter(.fldd) + 1
                txtCounter(.flde) = txtCounter(.flde) + 1
                .Move -2
           
         
              'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    Else
        .MoveNext
    End If
    Wend
End With
wrapitup:
rstTEMPY.Close

End Sub


Private Sub cmdD3_Click()

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("placebo")

Me.Refresh


If EraseYN Then
ai = 0
While ai < 41
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator2
txtCN2 = Comparator3

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = 0
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst

    While Not .EOF
    'If .flda = Comparator Then
    'If .fldb = Comparator Then
    If .fldc = Comparator Then
        .MoveNext
        If Not .EOF Then
            .Edit
            .fldprev = Comparator
            .Update
            txtCounter(.flda) = txtCounter(.flda) + 1
            'txtCounter(.fldb) = txtCounter(.fldb) + 1
            'txtCounter(.fldc) = txtCounter(.fldc) + 1
        End If
    Else
        .MoveNext
    End If

    Wend
End With

rstTEMPY.Close

End Sub


Private Sub cmdD3pred_Click() 'D3 predictor Dim TheLoop As Integer Set dbs = OpenDatabase("d:\F5\F5.mdb") Set rstTEMPY = dbs.OpenRecordset("D3") Me.Refresh If InputEraseYN = "y" Then EraseYN = True Else EraseYN = False End If If EraseYN Then ai = 0 While ai < 48 txtCounter(ai) = 0 ai = ai + 1 Wend End If txtCN = Comparator txtCN2 = Comparator2  txtCN2 = Comparator3 With rstTEMPY .MoveFirst If EraseYN Then While Not .EOF .Edit .fldprev = blank .Update .MoveNext Wend End If .MoveFirst While Not .EOF 'If Not True Then 'If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Then 'If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Then 'If .fldc = Comparator Then If (.flda = 7 And .fldb = 1) Then           'If .flda = .fldb Then '# 'If .flda < .fldb Then '# 'If .flda > .fldb Then '#7 'If .flda = .fldc Then '# 'If .flda < .fldc Then '# 'If .flda > .fldc Then '# 'If .fldb = .fldc Then '# 'If .fldb < .fldc Then '#0 'If .fldb > .fldc Then '# 'If .flda + .fldb = 11 Then '# 'If .flda + .fldb < .fldc Then '# 'If .flda + .fldb = .fldc Then '# 'If .flda + .fldb > .fldc Then '#0 'If .flda + .fldc = 13 Then '#7 'If .flda + .fldc < .fldb Then '# 'If .flda + .fldc = .fldb Then '# 'If .flda + .fldc > .fldb Then '# 'If .fldb + .fldc = 8 Then '# 'If .fldb + .fldc < .flda Then '# 'If .fldb + .fldc = .flda Then '#8 'If .fldb + .fldc > .flda Then '# 'If .flda + .fldb + .fldc = 16 Then '#0 'If .flda = 8 And (.flda + .fldb + .fldc = 16) And (.flda + .fldb > .fldc) And (.flda + .fldc > .fldb) And (.fldb + .fldc = .flda) Then '#1,8 'If .flda = .fldb + .fldc Then '#8 'TheLoop = 1 'While Not .EOF .MoveNext If Not .EOF Then .Edit .fldprev = Comparator .Update txtCounter(.flda) = txtCounter(.flda) + 1 txtCounter(.fldb) = txtCounter(.fldb) + 1 txtCounter(.fldc) = txtCounter(.fldc) + 1 .MoveNext txtCounter(.flda) = txtCounter(.flda) + 1 txtCounter(.fldb) = txtCounter(.fldb) + 1 txtCounter(.fldc) = txtCounter(.fldc) + 1 .MovePrevious txtCounter(47) = txtCounter(47) + 1 'TheLoop = TheLoop + 1 End If 'Wend 'If Not .EOF Then ' .Move 1 'End If Else .MoveNext End If Wend End With rstTEMPY.Close End Sub



Private Sub cmdDDTA_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("DD2006")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 60
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator2
txtCN2 = Comparator3

With rstTEMPY
    .MoveFirst
    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 2000
    While Not .EOF
    'If .flda = Comparator Then
    'If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Then
    If .fldb = 12 Then
        'TheLoop = 4
        'While TheLoop < 5 And Not .EOF
            '.Move 1
            'If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .Update
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                'txtCounter(.fldf) = txtCounter(.fldf) + 1
           
                TheLoop = TheLoop + 1
            'End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    Else
        '.MoveNext
    End If
    .MoveNext
    Wend
End With

rstTEMPY.Close
End Sub



Private Sub cmdSLP_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("SLP2007")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 59
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        '.fldcalc1 = blank
        '.fldcalc2 = blank
        '.fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 2377

    While Not .EOF

    'If True Then

    If .fldBN = Comparator Then

    'If .flde = 41 Then   'And .flde = 41

    'If .fldb - .flda = .fldc - .fldb Then

    'If (.flda > 14) And (.flde < 38) And ((.fldb = .flda + 1) Or (.fldc = .fldb + 1) Or (.fldd = .fldc + 1) Or (.flde = .fldd + 1)) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3 Or .fldd = Comparator3 Or .flde = Comparator3) Then

    'If .flda + .fldb + .fldc + .fldd + .flde = 130 Then '#($)
 
    'If (.flda < 20) And (.fldb < 20) And (.fldc < 20) And (.fldd < 20) And (.flde < 20) Then
    'If .flda = 2 Then  '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 51 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        'While TheLoop < 2 And Not .EOF
       
            'SeqCompVar = .flda
            '.MoveNext
            'If .flda = SeqCompVar Then
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                '.fldcalc1 = .flda + .fldb + .fldc + .fldd + .flde
                .Update
                txtCounter(.fldBN) = txtCounter(.fldBN) + 1
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                txtCounter(59) = txtCounter(59) + 1
           
            'TheLoop = TheLoop + 1
            End If
            .Move -1
            'End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
        .MoveNext
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close

End Sub




Private Sub cmdSLPTA_Click() Dim TheLoop As Integer Set dbs = OpenDatabase("d:\F5\F5.mdb") Set rstTEMPY = dbs.OpenRecordset("SLP2005") Me.Refresh If InputEraseYN = "y" Then EraseYN = True Else EraseYN = False End If If EraseYN Then ai = 0 While ai < 48 txtCounter(ai) = 0 ai = ai + 1 Wend End If txtCN = Comparator txtCN2 = Comparator2 txtCN2 = Comparator3 With rstTEMPY .MoveFirst If EraseYN Then While Not .EOF .Edit .fldprev = blank .Update .MoveNext Wend End If .MoveFirst '.Move 2000 While Not .EOF If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator Then 'If .flda = 10 And .flde = 47 Then 'TheLoop = 4 'While TheLoop < 5 And Not .EOF '.Move 1 'If Not .EOF Then .Edit .fldprev = Comparator .Update 'txtCounter(.fldBN) = txtCounter(.fldBN) + 1 txtCounter(.flda) = txtCounter(.flda) + 1 txtCounter(.fldb) = txtCounter(.fldb) + 1 txtCounter(.fldc) = txtCounter(.fldc) + 1 txtCounter(.fldd) = txtCounter(.fldd) + 1 txtCounter(.flde) = txtCounter(.flde) + 1 TheLoop = TheLoop + 1 'End If 'Wend 'If Not .EOF Then ' .Move 1 'End If Else '.MoveNext End If .MoveNext Wend End With rstTEMPY.Close End Sub



Private Sub cmdSuper_Click()

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("placebo")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 49
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator2
txtCN2 = Comparator3

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst

    While Not .EOF
    If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator Then
    'If .fldm = Comparator Then
        .MoveNext
        If Not .EOF Then ' And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then
            TheLoop = 1
            txtCounter(48) = txtCounter(48) + 1
            While TheLoop < 2 And Not .EOF
                '.Move 1
                If Not .EOF Then
                    .Edit
                    .fldprev = Comparator
                    .Update
                    'txtCounter(.fldm) = txtCounter(.fldm) + 1
           
                    txtCounter(.flda) = txtCounter(.flda) + 1
                    txtCounter(.fldb) = txtCounter(.fldb) + 1
                    txtCounter(.fldc) = txtCounter(.fldc) + 1
                    txtCounter(.fldd) = txtCounter(.fldd) + 1
                    txtCounter(.flde) = txtCounter(.flde) + 1
                   TheLoop = TheLoop + 1
                End If
            Wend
        End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close

End Sub



Private Sub Command10_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("MM")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 60
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        '.fldcalc1 = blank
        '.fldcalc2 = blank
        '.fldcalc3 = blank
        '.fldtrack39 = blank
        '.fldtrack4 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 2377


    .MoveNext
    While Not .EOF

    'If True Then

    If .fldBN = Comparator Then

    'If .fldc > 47 Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3 Or .fldd = Comparator3 Or .flde = Comparator3) Then

    'If .flda + .fldb + .fldc + .fldd + .flde = 161 Then '#($)
 
    'If (.fldc = .fldb * 2) And (.fldb = .flda * 2) Then
    'If .flda = 9 Then '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 40 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(59) = txtCounter(59) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .fldcalc1 = .flda + .fldb + .fldc + .fldd + .flde
                .Update
                txtCounter(.fldBN) = txtCounter(.fldBN) + 1
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                .MoveNext
                txtCounter(.fldBN) = txtCounter(.fldBN) + 1
                .Edit
                .fldprev = Comparator
                .fldcalc1 = .flda + .fldb + .fldc + .fldd + .flde
                .Update
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                .MoveNext
                txtCounter(.fldBN) = txtCounter(.fldBN) + 1
                .Edit
                .fldprev = Comparator
                .fldcalc1 = .flda + .fldb + .fldc + .fldd + .flde
                .Update
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                'TheLoop = TheLoop + 1
                '.MoveNext
       
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close

End Sub



Private Sub Command11_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("DT2005")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .fldcalc1 = blank
        .fldcalc2 = blank
        .fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 2377



    While Not .EOF

    'If True Then

    'If (.fldb = .fldc) And .flda = .fldb * 2 Then

     'If (.fldc = .flda - 1) Then

   'If .fldc = (.fldb * .fldb) + 1 Then
   
    'If (.fldb = .fldc + 1) Or (.fldb = .fldc - 1) Then

    'If (.flda = 2) And (.fldb = 1) And (.fldc = 1) Then

    'If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3) Then

    If .flda + .fldb + .fldc = 4 Then '#($) very promising!
 
    'If (.flda < 20) And (.fldb < 20) And (.fldc < 20) And (.fldd < 20) And (.flde < 20) Then
    'If .flda = 2 Then  '#
    'If .flda - .fldb = .fldb - .fldc Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 51 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(47) = txtCounter(47) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .fldcalc1 = .flda + .fldb + .fldc
                .Update
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    '.MoveNext
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close
End Sub



Private Sub Command6_Click() 'F5 tag along

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\combo\combo2010.mdb")
Set rstTEMPY = dbs.OpenRecordset("ff")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator2
txtCN2 = Comparator3

With rstTEMPY
    .MoveFirst
    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 2000
    While Not .EOF
    'If .fldc = 18 Or .fldc = 19 Or .fldc = 23 Or .fldc = 24 Then

    If .f5a = Comparator Or .f5B = Comparator Or .f5c = Comparator Or .f5d = Comparator Or .f5e = Comparator Then
    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then
    'If True Then

    'If .flda = 4 And .fldb = 18 Then
        'TheLoop = 4
        'While TheLoop < 5 And Not .EOF
            '.Move 1
            'If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .Update
                txtCounter(.f5a) = txtCounter(.f5a) + 1
                txtCounter(.f5B) = txtCounter(.f5B) + 1
                txtCounter(.f5c) = txtCounter(.f5c) + 1
                txtCounter(.f5d) = txtCounter(.f5d) + 1
                txtCounter(.f5e) = txtCounter(.f5e) + 1
                TheLoop = TheLoop + 1
            'End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    Else
        '.MoveNext
    End If
    .MoveNext
    Wend
End With

rstTEMPY.Close
End Sub



Private Sub Command7_Click() 'F5 seq predictor

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("placebo")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator2
txtCN2 = Comparator3

With rstTEMPY
    .MoveFirst
    
    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .fldtrack39 = blank
        .fldtrack4 = blank
        .fldcalc1 = blank
        .fldcalc2 = blank
        .fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If
    
    .MoveFirst
    
    While Not .EOF
    If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator Then
   
        If Not .EOF Then
            .MoveNext
        End If
        On Error Resume Next
        If Not .EOF And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then
            .MoveNext
            If Not .EOF And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3 Or .fldd = Comparator3 Or .flde = Comparator3) Then
                TheLoop = 1
                txtCounter(47) = txtCounter(47) + 1
                While TheLoop < 2 And Not .EOF
                    .Move 1
                    If Not .EOF Then
                        .Edit
                        .fldprev = Comparator
                        .Update
                        txtCounter(.flda) = txtCounter(.flda) + 1
                        txtCounter(.fldb) = txtCounter(.fldb) + 1
                        txtCounter(.fldc) = txtCounter(.fldc) + 1
                        txtCounter(.fldd) = txtCounter(.fldd) + 1
                        txtCounter(.flde) = txtCounter(.flde) + 1
                       TheLoop = TheLoop + 1
                    End If
                Wend
            End If
        End If
    Else
        If Not .EOF Then
            .MoveNext
        End If
    End If
    Wend
End With

rstTEMPY.Close

End Sub


Private Sub Command8_Click() 'D3 Seq Pred
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("D3")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator2
txtCN2 = Comparator3

With rstTEMPY
    .MoveFirst
    
    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        '.fldcalc1 = blank
        '.fldcalc2 = blank
        '.fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If
    
    .MoveFirst
    
    While Not .EOF
    'If .flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Then
    'If .flda = Comparator Or .flda = Comparator2 Or .flda = Comparator3 Or .flda = Comparator4 Then
     If .fldc = Comparator Or .fldc = Comparator2 Or .fldc = Comparator3 Or .fldc = Comparator4 Then
        '.MoveNext
        'On Error Resume Next
        'If Not .EOF And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) Then
        'If Not .EOF And (.flda = Comparator Or .flda = Comparator2 Or .flda = Comparator3 Or .flda = Comparator4) Then
        'If Not .EOF And (.fldc = Comparator Or .fldc = Comparator2 Or .fldc = Comparator3 Or .fldc = Comparator4) Then
            '.MoveNext
        'If Not .EOF And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3) Then
        'If Not .EOF And (.flda = Comparator Or .flda = Comparator2 Or .flda = Comparator3 Or .flda = Comparator4) Then
        'If Not .EOF And (.fldc = Comparator Or .fldc = Comparator2 Or .fldc = Comparator3 Or .fldc = Comparator4) Then
         '   .MoveNext
            
            'If Not .EOF And (.flda = Comparator4 Or .fldb = Comparator4 Or .fldc = Comparator4) Then
            'If Not .EOF And (.flda = Comparator Or .flda = Comparator2 Or .flda = Comparator3 Or .flda = Comparator4) Then
             If Not .EOF And (.fldc = Comparator Or .fldc = Comparator2 Or .fldc = Comparator3 Or .fldc = Comparator4) Then
               'TheLoop = 1
                txtCounter(47) = txtCounter(47) + 1
                While Not .EOF
                    .Move 1
                    If Not .EOF Then
                        .Edit
                        .fldprev = Comparator
                        .Update
                        txtCounter(.flda) = txtCounter(.flda) + 1
                        txtCounter(.fldb) = txtCounter(.fldb) + 1
                        txtCounter(.fldc) = txtCounter(.fldc) + 1
                       TheLoop = TheLoop + 1
                    End If
                Wend
            End If
        'End If
        'End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close

End Sub



Private Sub Command9_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("placebo")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .fldcalc1 = blank
        .fldcalc2 = blank
        .fldcalc3 = blank
        .fldtrack39 = blank
        .fldtrack4 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
   '.Move 2000



    While Not .EOF
    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then

    If .flda + .fldb + .fldc = 8 Then   '#($) seems to work

    'If (.flda + .fldb = 7) And (.fldb + .fldc = 14) Then
    'ab and bc doesn't work
    'If .flda + .fldb = 28 Then '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 51 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(47) = txtCounter(47) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .fldcalc3 = .flda + .fldb + .fldc
                .Update
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close

End Sub



Private Sub D4research_Click()

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("D3")

Me.Refresh

With rstTEMPY

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 55
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator


    .MoveFirst



   While Not .EOF
    'If True Then

    'If .p5 > 0 Then
    'txtCounter(50) = txtCounter(50) + 1
    'End If

    'If .p5 < 1 Then
    'txtCounter(51) = txtCounter(51) + 1
    'End If

    'If True Then

    'If .p1 > 0 And .p4 = 0 And .p5 = 0 Then

    'If (.fldb = .flda + 1) And .flde = .fldd + 10 Then

    'If .p1 + .p2 + .p3 + .p4 + .p5 > 0 Then

    'If .fldd = .fldc + 4 And .fldc = .fldb + 4 Then

    'If .fldc = .fldb * 2 Then

    'If .flde - .fldc = 5 Then
    'If .fldc = 26 And .flde = 33 Then   '
    'If True Then
    'If .fldc = 18 Or .fldc = 19 Or .fldc = 23 Or .fldc = 24 Then

    'If .fldc = 7 Then
    'If .flde = 35 Then

    'If (.flda > 10 And .flda < 20) And (.fldb > 20 And .fldd < 30) Then
   
    'If (.fldc = .fldb + 1 And .fldb = .flda + 1) Or (.fldd = .fldc + 1 And .fldc = .fldb + 1) Or (.flde = .fldd + 1 And .fldd = .fldc + 1) Then

    'If .flde = .flda + .fldd Then

    'If True Then

    'If .fldb = 12 And .flde = 24 Then

    'If .flda > 10 And .fldd < 20 Then

    'If .fldc < 9 And .flde < 33 Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) Then

    If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3) Then

    'If .flda + .fldb + .fldc + .fldd + .flde = 88 Then '#($)

     'If .flda > 8 And .flde < 31 Then

    'If (.flde = .flda + .fldc) Then
    'If .fldc = 32 Then  '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 40 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(49) = txtCounter(49) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .Update
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                .MoveNext  'loopy
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                .MoveNext  'loopy
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
'                 .MoveNext  'loopy
'                txtCounter(.flda) = txtCounter(.flda) + 1
'                txtCounter(.fldb) = txtCounter(.fldb) + 1
'                txtCounter(.fldc) = txtCounter(.fldc) + 1
                 .Move -2
           
         
              'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close
End Sub



Private Sub DD_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("DD2006")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 60
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        '.fldcalc1 = blank
        '.fldcalc2 = blank
        '.fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst


   Counter = 1
   While Not .EOF

    'If True Then
    'If Counter < 145 Then
    'Counter = Counter + 1

    'If (.flda > 7 And .fldb > 7 And .fldc > 7) And (.fldb = .fldd) Then

    'If .flda = 1 And .fldd = 5 Then

    'If .flda > 6 And .fldb > 6 And .fldc > 6 Then

    'If .flda = .fldb + 1 And .fldb = .fldc + 1 Then

    'If .fldb = .flde And .fldd = 5 Then  'works to predict flda?

     'If .fldb = .fldf * 2 And .flde = 3 Then

     'If .fldc = .fldd And .fldb = 2 Then

    'If .fldb = 2 And .flde = 5 And .fldd = 3 Then

    'If .fldc = .fldd Then

    'If .fldb = .flde * 2 Then

    'If .fldc = 12 And .fldf = 0 Then

     'If (.fldc = .fldf) Then 'predicts #7

     'If .flda >= .fldb And .fldb <= .fldc And .fldc >= .fldd And .fldd <= .flde And .flde <= .fldf Then

     'If .flda >= .fldb And .fldb <= .fldc And .fldc >= .fldd And .fldd >= .flde And .flde <= .fldf Then

     'If .fldc = .flda + .fldb Or .fldf = .fldd + .flde Then

     'If .fldb = 2 And .fldf = 8 Then

     'If .fldd = 3 Then

     'If .fldc = .flde * 2 Then

     'If .fldb = 6 And .fldf = 3 Then

     'If .flda < 9 And .fldb > 9 And .fldc < 5 Then

     'If True Then

     'If .flda = .fldb + 1 And .fldb = .fldc + 1 Then

     'If .flda > 9 And .fldc > 9 And .fldb < 10 Then

     'If .fldc = .fldf / 2 Then

     'If .fldc = .fldd + .fldf Then

     'If .flda - .fldb = .flde Then

     'If (.flda <> .fldb And .flda <> .fldc And .flda <> .fldd And .flda <> .flde And .flda <> .fldf And .fldb <> .fldc And .fldb <> .fldd And .fldb <> .flde And .fldb <> .fldf And .fldc <> .fldd And .fldc <> .flde And .fldc <> .fldf And .fldd <> .flde And .fldd <> .fldf And .flde <> .fldf) Then   'And (.fldd = .flda * .flda)

      'If (.flda = .fldb * 2) And (.fldb = .fldc * 2) Then

     'If True Then

     'If .fldc = .fldd Then

     'If (.flda = .fldd - .fldb) And (.flde = .fldd - .fldb) Then

   'If .flda * .flda = .fldc Then
 
    'If (.fldb = .fldc + 1) Or (.fldb = .fldc - 1) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) Then

    'If (.fldc = 3) Then

    'If (.flda > 6 And .flda < 10) And (.fldb > 6 And .fldb < 10) And (.fldc > 6 And .fldc < 10) Then

    'If (.flda = 4) And (.fldd = Comparator Or .flde = Comparator Or .fldf = Comparator) Then

    'If .flda = 4 And (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) Then

    'If (.fldd = Comparator Or .flde = Comparator Or .fldf = Comparator) And (.fldd = Comparator2 Or .flde = Comparator2 Or .fldf = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator Or .fldf = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2 Or .fldf = Comparator2) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3) Then

    If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.fldd = Comparator Or .flde = Comparator Or .fldf = Comparator) Then

    'If .flda + .fldb + .fldc = 30 Then '#($) very promising!

    'If (.flda < 20) And (.fldb < 20) And (.fldc < 20) And (.fldd < 20) And (.flde < 20) Then
    'If .flda = 2 Then  '#
    'If .flda - .fldb = .fldb - .fldc Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 51 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(47) = txtCounter(47) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                '.fldcalc1 = .flda + .fldb + .fldc
                .Update
                On Error GoTo wrapitup
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                txtCounter(.fldf) = txtCounter(.fldf) + 1
                .MoveNext
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                txtCounter(.fldf) = txtCounter(.fldf) + 1
                .MoveNext
                'txtCounter(.flda) = txtCounter(.flda) + 1
                'txtCounter(.fldb) = txtCounter(.fldb) + 1
                'txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                txtCounter(.fldf) = txtCounter(.fldf) + 1
                .Move -2
                'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    '.MoveNext
    Else
        .MoveNext
    End If
    Wend
End With
wrapitup:
rstTEMPY.Close

End Sub



Private Sub DDsums_Click()
Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("placebo")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .fldcalc1 = blank
        .fldcalc2 = blank
        .fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
   '.Move 2000



    While Not .EOF
    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator Or .fldd = Comparator Or .flde = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2 Or .fldd = Comparator2 Or .flde = Comparator2) Then

    If .fldc = 12 And .flda + .fldb + .fldc = 21 Then  '#($) seems to work

    'If (.flda + .fldb = 7) And (.fldb + .fldc = 14) Then
    'ab and bc doesn't work
    'If .flda + .fldb = 28 Then '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 51 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(47) = txtCounter(47) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .fldcalc3 = .flda + .fldb + .fldc
                .Update
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                'txtCounter(.fldd) = txtCounter(.fldd) + 1
                'txtCounter(.flde) = txtCounter(.flde) + 1
                'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close
End Sub



Private Sub DT2005_Click()

Dim TheLoop As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("DT2005")

Me.Refresh

If InputEraseYN = "y" Then
EraseYN = True
Else
EraseYN = False
End If


If EraseYN Then
ai = 0
While ai < 48
    txtCounter(ai) = 0
    ai = ai + 1
Wend
End If

txtCN = Comparator
txtCN2 = Comparator

With rstTEMPY
    .MoveFirst

    If EraseYN Then
    While Not .EOF
        .Edit
        .fldprev = blank
        .fldcalc1 = blank
        .fldcalc2 = blank
        .fldcalc3 = blank
        .Update
        .MoveNext
    Wend
    End If

    .MoveFirst
    '.Move 1071



    While Not .EOF

    'If True Then

    'If ((.flda = .fldb) Or (.flda = .fldc) Or (.fldb = .fldc)) And (.flda = 5) Then

    'If (.flda + .fldc = 13) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) Then

    'If (.flda = Comparator Or .fldb = Comparator Or .fldc = Comparator) And (.flda = Comparator2 Or .fldb = Comparator2 Or .fldc = Comparator2) And (.flda = Comparator3 Or .fldb = Comparator3 Or .fldc = Comparator3) Then

    If .flda + .fldb + .fldc = 9 Then '#($)

    'If (.flda < 20) And (.fldb < 20) And (.fldc < 20) And (.fldd < 20) And (.flde < 20) Then
    'If .fldc = Comparator Then  '#
    'If .flda + .fldc = 30 Then '#
    'If .flda + .fldd = 22 Then '#13
    'If .flda + .flde = 51 Then '#

    'If .fldb + .fldc = 34 Then '#($)
    'If .fldb + .fldd = 40 Then '#
    'If .fldb + .flde = 41 Then '#

    'If .fldc + .fldd = 37 Then
    'If .fldc + .flde = 43 Then '#

    'If .fldd + .flde = 44 Then '#

    'If .flda + .fldb + .fldc = 46 Then '#
    'If .flda + .fldb + .fldd = 47 Then '($)#
    'If .flda + .fldb + .flde = 36 Then '#($)14,15,17

    'If .fldb + .fldc + .fldd = 53 Then '#
    'If .fldb + .fldc + .flde = 59 Then '#

    'If .fldc + .fldd + .flde = 58 Then '#20

    '-If .fldb + .fldc = 17 And .fldb + .fldc + .flde = 55 Then '#
    '-If .fldb + .flde = .flda + .fldb + .fldd Then '#
    '-If .flda + .fldb + .flde = .fldb + .fldc + .fldd Then '#
    '-If .fldtrack39 = 888 Then


        'TheLoop = 1
        txtCounter(47) = txtCounter(47) + 1
        'While TheLoop < 2 And Not .EOF
            .MoveNext
            If Not .EOF Then
                .Edit
                .fldprev = Comparator
                .fldcalc1 = .flda + .fldb + .fldc
                .Update
                txtCounter(.flda) = txtCounter(.flda) + 1
                txtCounter(.fldb) = txtCounter(.fldb) + 1
                txtCounter(.fldc) = txtCounter(.fldc) + 1
                'TheLoop = TheLoop + 1
            End If
        'Wend
        'If Not .EOF Then
        '    .Move 1
        'End If
    'End If
    Else
        .MoveNext
    End If
    Wend
End With

rstTEMPY.Close

End Sub



Private Sub DTsort_Click()

Dim TheLoop As Integer

Dim TS As Integer

Set dbs = OpenDatabase("d:\F5\F5.mdb")
Set rstTEMPY = dbs.OpenRecordset("DTsortproject")

Me.Refresh

With rstTEMPY
    .MoveFirst

    While Not .EOF

    .Edit

    If .flda > .fldb Then
        TS = .flda
        .flda = .fldb
        .fldb = TS
    End If

    If .fldb > .fldc Then
        TS = .fldb
        .fldb = .fldc
        .fldc = TS
    End If

    If .flda > .fldb Then
        TS = .flda
        .flda = .fldb
        .fldb = TS
    End If

    .Update

    .MoveNext

    Wend
End With

rstTEMPY.Close
End Sub


Private Sub F5sort_Click()
Dim TheLoop As Integer

Dim TS As Integer

Set dbs = OpenDatabase("d:\combo\combo2010.mdb")
Set rstTEMPY = dbs.OpenRecordset("ff")

Me.Refresh

With rstTEMPY
    .MoveFirst
    .Move 1180

    While Not .EOF

    .Edit

    If .f5a > .f5B Then
        TS = .f5a
        .f5a = .f5B
        .f5B = TS
    End If

    If .f5B > .f5c Then
        TS = .f5B
        .f5B = .f5c
        .f5c = TS
    End If

    If .f5c > .f5d Then
        TS = .f5c
        .f5c = .f5d
        .f5d = TS
    End If

    If .f5d > .f5e Then
        TS = .f5d
        .f5d = .f5e
        .f5e = TS
    End If


    .Update

    .MoveNext

    Wend
End With

rstTEMPY.Close
End Sub

- End of Article -


Re: Using Mobile?
Home: site intro and featured articles/resources.
View Web Version: displays Main Menu article categories (will be located below), additional site info (below and side), search function, translation function.