Showing posts with label Tech. Show all posts
Showing posts with label Tech. Show all posts

Visual Basic 6.0 Source Code Examples and Samples for VB6 and SQL Programming

]The author of this page has worked in the tech industry as a programmer analyst for over 20 years.]


Hello, all. After you have gotten what you came here for, you might want to drop by The Silent Majority: Why Visual Basic 6 Still Thrives. It's an article at Microsoft. Bottom line? You are not alone, VB6 still continues to be popular.

Surprisingly, employment opportunities still abound for Visual Basic 6.0. A simple search for "VB6" at a job search aggregator site brought up over 300 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 5,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 this code library will serve people well for many years.

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

Visual Basic 6.0 and SQL Code Examples Library One


VB6

'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

'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


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


Binary City

Hexadecimal images would have been more representative for this page; unfortunately, I couldn't find any decent ones that were public domain. The 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 reference link is a tutorial for the binary, quaternary, octal, and hexadecimal base numbering systems. When you've learned one, you've learned them all.

May all your programming adventures be prosperous ones.

Important Tip on How to Use Blogger aka Blogspot: Beware Revert to Draft

Here's an important tech SEO warning for webmasters who use Blogger aka Blogspot. A true Blogger booby trap and pitfall.

This happened to me.

If you revert a published web page or blog post to draft mode for whatever reason and then re-publish, Blogspot will change your URL and not tell you! At which point anyone arriving from a search engine or any other source will immediately get a 404-file-not-found. In other words, you've lost everything. That post (whether being used as a web page or a blog post) no longer exists to the search engines, social media, or anywhere else your former URL is listed. All gone, you are back to zero. Your former URL is gone and your new URL will have to be discovered and shared all over again.

To clarify, this is about what Blogger calls "posts"; I don't know if Blogger does the same thing to what Blogger calls "pages", nor do I intend to find out. Also, I'm not talking about the usual editing/updating routine we all do to our published posts (whether being used as a web page or a blog post). I'm talking about the reverting of a published post to draft mode and then republishing it. Don't ever do that. If you do, you have effectively just murdered your web page or blog post. If you have done it recently and been wondering why your traffic for that post suddenly cratered to zero, that is the reason.


Fortunately I found a way to at least partially salvage the situation. You can go to "Settings" and then "Search preferences". There you will find "Custom Redirects". You can put the former and new URLs there. So at least I got my traffic back, but I'm sure the search engines are thrilled, now that they will be thinking I've got duplicate pages on my website. And I'm wondering if my search ranking for that page is going to drop dead when the redirection is discovered.

Blogger needs to implement a warning prompt when a user is about to do something that will change an URL. I mean seriously, they are not idiots and know how serious an URL change can be.

Why couldn't this have happened to one of my low-traffic articles? No, it had to happen to one of my top performers. The life of an online writer..., where the adventures never end. Oh, well. At least I hope this post saves a few kindred souls from similar fates.

How to Remember Color Order of Spectrum and Rainbow

Remembering the list order of the rainbow and visible light color spectrum is easy: ROYGBIV.

Additional wavelength, rainbow, sunset, laser images and information resources were added afterwards for folks who might find them interesting. Images can be clicked to be enlarged. But first, The Quick and Easy Way to Remember Rainbow and Spectrum Colors...

An Introduction to Mr. Roy G. Biv


Mnemonic Trick to Remember Order of Colors in the Visible Light Spectrum and Rainbows

His name is Roy G. Biv.

Note the first letter of each color in the visible light color spectrum map above. If you can remember the name, Roy G. Biv, then you have accomplished your goal.

ROYGBIV - The Color List and Order of the Visible Light Spectrum and Rainbow

  • Red, Orange, Yellow, Green, Blue, Indigo, Violet.
If you are interested in more information about the visible spectrum, wavelengths, light, colors, etc.; there are all sorts of additional information and resources below.


The List and Order of Visible Spectrum Wavelengths


Visible light wavelengths.

Visible light wavelengths

  • Red: The lower and longer wavelengths.
  • Violet: The higher and shorter wavelengths.

An Expanded Electromagnetic Spectrum List

There really isn't that much more to it.
  • Gamma Rays
  • X-Rays
  • Infrared
  • Red Orange Yellow Green Blue Indigo Violet
  • Ultraviolet
  • Microwaves 
  • Radio Waves
Interesting how the visible spectrum is right in the middle.

An Expanded Electromagnetic Wavelength Image

This image came from a NASA page with all sorts of additional information and resources on it, well worth a visit.



Rainbows - Nature's Natural Prisms

This NOAA/NASA page will tell you everything you would ever want to know about rainbows, how they are formed, etc. Rainbow images are free, public domain.

Symmetric rainbow


Double rainbow

Rainbow over the Gardner River Canyon near Mammoth NPS photo by Neal Herbert


Light Show Sunsets

This NOAA/NWS page explains the causes for the vivid sunsets we sometimes see. Sunset images are free, public domain.

Sunset image

Sunset image

Sunset image

Sunset image


Lasers - Otherwise Known as Light With an Attitude

Here is an introductory page on How Lasers Work. Laser images are free, public domain.

Ground-to-Space Laser Calibration System
NASA page on ground-based systems to calibrate Earth observing sensors
measuring reflected radiance in low and geostationary orbits.

Simulation of Laser-Plasma Interaction
ALCF page on laser-plasma interactions and current projects.

Lasers Used in Duel Atomic Clock
NIST page on how lasers are used in atomic clocks.


The End

I hoped you liked the images and additional information resources. Feel free to use the images as desktop or other screen backgrounds, Pinterest pinning or other social media uses, etc.

So. What is the order of colors in a rainbow or the visible light spectrum? 😁

MasterCool Evaporative Cooler Customer Review - Negative

Here is an unfortunately negative product reliability customer review of MasterCool evaporative coolers, plus water cooler pump installation and replacement instructions.

It should be noted that water cooler pumps are the least of MasterCool's poor quality control and reliability problems.

The primary purpose of this page is a review of the MasterCool and same-company other brands of evaporative coolers. The detailed How-to-Replace-Water-Cooler-Pump segment was included simply because it is such a frequent problem. The pump failure is a side issue, it is the other poor quality standards and reliability issues of MasterCool evaporative coolers that resulted in the publishing of this negative review. These issues are addressed immediately following the water cooler pump segment.

MasterCool window evaporative cooler.

My personal experience and what this review specifically is referring to is the the MasterCool MCP44E Evaporative Cooler. However, the same company that makes MasterCool also makes the Champion and Essick brands of evaporative coolers. If a company makes a poorly manufactured one brand or model, it's a pretty good bet their other brands are of equally poor quality. That's a decision only you can make. At minimum, you definitely want to at least avoid MasterCool.

The first problem was the failed water pump, it lasted a little more than a year. If you are only here for the review, you will find the first paragraph immediately below the cooler pump picture informative; then might as well skip past the numbered list to the next section where things really get interesting.There are also pictures after the review showing what the inside of the MasterCool window evaporative cooler looks like.

About and a Detailed How to Replace or Install the MCP44 Series MasterCool Evaporative Water Cooler Pump (instructions will probably work equally well with many other brands and models)


Model ESK5500 Cooler Pump.
There is additional information and pictures of the MasterCool evaporative cooler with the back panel removed following the review.

I acquired the new MasterCool MCP series evaporative cooler unit a little less than four years ago. The water pump lasted a little longer than a year. If you think getting the back panel off the evaporative cooler unit is a major project, just wait until it's time to correctly put the thing back on. There sat the water pump; "Made in China" it duly informed me. Water pumps are the known weak link when it comes to evaporative coolers, the manufacturers know this and so try to make the component fairly easy to replace. Here is the procedure, don't forget to check out the additional pictures and warnings following the main review.

Read the entire list and and check out the additional pictures and information a few times before beginning the actual step-by-step pump replacement process. You will then have a pretty good idea of the overall procedure and there will be fewer surprises. In other words, now that you know the hazard points, things will go a lot quicker and easier. In fact, once that back panel is off, the whole procedure will pretty much be intuitive. All the information and pictures makes it sound a lot more complicated than it really is. "Check list" might be a better description than "step-by-step".
  1. Check the electrical info on the replacement water pump and plug into a wall socket for a couple seconds to be sure the new pump works. Note if the new pump already has a protective screen wrapped around the bottom of it.
  2. Unplug the entire evaporative unit from the wall socket and turn off the water feed. 
  3. Read the manual. Among other things, it tells you how to remove the back panel and about the water hose you need to disconnect at the top and inside of the unit before you can completely remove the back panel. The additional pictures further down this page have more info.
  4. Drain/siphon water from tray.
  5. Very carefully retrieve the water-protected water pump electrical power cord from the enclosure. Definitely peruse the additional pictures and information further down the page before attempting this, otherwise you might accidentally unplug the cord while it is still in the protected enclosure. If that happens, retrieval of the inside cord could be a major problem. Once the plugin part is reached and extracted, do NOT unplug yet.
  6. Unbolt and/or unscrew the clamps/brackets/etc. that are holding the pump in place.
  7. Pull off the water hose from the pump. There may or may not be a clamp you have to undo first.
  8. Remove the still plugged in old pump and set aside elsewhere on the tray. If no new screen was provided with the new pump, retrieve and clean the filter screen wrapped around the bottom of the old pump.
  9. More than likely, the entire bottom of the evaporative unit is filled with peeled paint and other debris. Now is a good time to clean up and get rid of all that. You'll have to move the old pump around while doing this, maybe place it on top of the bracket. Do not unplug it.
  10. Bring out the new pump. It will also be made in China, apparently no other options are  available for this unit. If needed, wrap old screen around new pump as it was on the old pump.
  11. Place the new pump where the old pump originally was.
  12. Make sure the water hose, electrical cord, and bracket(s) are all completely untangled from each other. Review pictures.
  13. Unplug the old pump. Do not let go of the cord coming from inside of the evaporative cooler, otherwise it might slip back inside the housing; you do not want that to happen. Plug in the new pump. Reinsert electrical cord back into the water-protected location. Don't reattach plastic cap yet.
  14. Reconnect the water hose.
  15. Position everything as you want it to be and attach pump to all the previous bracket and other connection points.
  16. Check tray. Remove all tools, parts, rags, the old pump if it is still laying there, and everything else that doesn't belong.
  17. Turn the water feed back on and confirm the water level rises to the level you wish it to be, give it at least 15 minutes. The higher, the better; but not above the overflow drain height. Adjust float if necessary.
  18. Time for the test. Unhook/Pull away the water hose from the plastic holders on the evaporative cooler and make sure the hose is pointed at the ground and well away from the pump and tray. The absolute last thing you want to do is spray either of those pumps with water. Plug the evaporative cooler back in the wall socket; turn the pump on for several seconds to check that everything works. Give the fan a couple seconds as well. Turn everything off and re-unplug the cooler.
  19. Push the water hose back into the plastic holders on the swamp cooler. Review pictures and accompanying information. Reattach plastic cap. Give everything one last, good look over.
  20. Time to reinstall the back panel. Brute strength and ingenuity will be required to get that thing setting back on top of the tray. Reconnect the hose at the top. You should be able to get your hand in there; grab the rubber hose; and force it back to the top of the tube. Twist and turn the hose as needed to remove any kinks.
  21. Time for more brute strength, ingenuity, and persistence. You will need to lift the panel about an inch or two above the tray; line it up with the sliders on the sides of the cooler; then shove panel flat against the cooler and pull down, hooking the panel back onto the sliders. Multiple attempts will probably be required. When there are no gaps on the sides and between the tray and panel, it probably means you succeeded. I didn't bother putting the two screws back in, that panel wasn't going anywhere. Recheck the water feed valve is still on.
  22. Plug the unit back in the wall socket; ponder that switch panel for a moment before reaching for it... Check the back panel that all the pads are getting wet. If they are, then it looks like you were successful in reinstalling the back panel correctly. Good luck.
If the water cooler pump had been the only incident, I would not have written this negative review. It is what happened next that pretty much made this review mandatory.

The Day the MasterCool Died...

Everything worked fine for another year or two. Then came that fateful morning...

It was going to be a hot one, temps in the 90's were on the way. I turned the water pump on to soak the pads as usual for five minutes before turning on the fan. The little, green light benignly glowed and the pump happily whirred.

I then went back and turned on the fan. The fan started up. Then the whole unit suddenly shut down. The fan. The pump. The switch lights. Everything.

I tried again. Everything shut down again. I tried different combinations of turning on the various switches. Self-shutdown every time. I tried using the remote instead. Same results.

I somehow sensed and knew I was already doomed. But I went through the motions and checked the house circuitry and fuse/switch box six ways from Sunday. There were no problems, that cooler was getting uninterrupted power.

I tried messing with the switches again, same results. Then the symptoms changed. At first, the pump and the fan worked fine when each was turned on alone. But whenever I turned the second one on, that's when the whole system would shut down.

Suddenly though, now with each attempt, the switch lights would flicker on and off at random for a few seconds before shutdown occurred. In other words, the lights would start doing a strange, little dance; water pump and blower fan sometimes automatically responding accordingly, sometimes not.

As for checking for loose wire connections, chip creep, or anything else a non-expert might be able to fix; forget it. The switch panel circuit board location was completely inaccessible.

I'm standing there looking at the thing after it had done its little dance and shutting itself off for the 30th time or whatever. Then MasterCool decided it was time to perform the coup de grâce to any remaining hopes of repair. It turned itself on. That's right. The unit started itself, all the lights happily flickering back and forth for several seconds with the fan and pump sometimes joining in, and then once again shutting itself down . That control circuit board was not only toast, it was unsafe.

"And that truly is indeed that," thought I. I unplugged the unit for the last time.

I'm sitting at my desk, pondering my next move, when I happened to glance down and notice the back page of the owner's manual (printed in China by the way). It proudly informed me the Essick, Champion, MasterCool family of evaporative coolers are designed, assembled, and serviced in the USA. What they don't mention is all the components were made in China or elsewhere.

As far as I'm concerned, lying by omission is still lying. I put the odds at 99.9% that circuit board switch panel was made in China. Even if it wasn't; it was still a low quality, poorly manufactured component no matter where it was made. And you can bet Champion, Essick, MasterCool brands all use the same supplier(s). That's when I decided to write this review.

Bottom, back page of MasterCool manual.

This page is just my opinion. However, evaporative coolers are an expensive proposition. Please really do your homework and research before making that final decision. Suddenly having your cooling system malfunction during a hot, summer day is not a pleasant experience.

Side note. Here's a video review (opens in new tab or window) from a new buyer of the MasterCool MCP44 series brand. He has both positive and negative things to say about it. He also mentions one very serious flaw. Basically, every insect in the neighborhood will end up inside your home; he'll tell you all about that. I'd wondered where all those moths and gnats were coming from, I even had an indoor mosquito. Now I know.

I would avoid MasterCool evaporative coolers at all costs. And since Essick and Champion are made by the same company with the same poor quality standards, I would seriously try to avoid those as well. Unfortunately, there seems to be some sort of monopoly situation in play. Other brands are hard to find. If anyone can recommend another brand, there are probably a whole lot of people who would very seriously appreciate it.

An Update. A contractor recently told me how to get the front panel off to access the circuit board(s). Basically, you scrape off the plastic at certain points and the screws are underneath. We will see how that goes.

[End of Review. Pictures follow.]

Here Are Some Pictures of What You Will Find When You Remove the Back Panel of the MCP44 Series Evaporative Cooler


There are two more screw holes at the base. Both were covered with silicon dry gel.
When I removed the gel, no screws were present. Your results may vary.

Once the screws are removed, slide the back panel up off the side slots (remember about those side slots, they'll be your nemesis when reinstalling the panel) and pull panel away from the cooler just a little bit. Do not try to remove the panel yet, the water hose is still attached. Using a flat edge screwdriver will help pry/pull the thing off. Won't be that difficult.

Success. The panel can now be removed. Brute strength and ingenuity will be required.

Welcome to the inside of the MasterCool evaporative cooler.
Note the water hose running along the length of the left side, it is easily detachable and re-attachable to the three plastic holders you see. You'll be doing that when you do your quick test at the end.
The two pumps you see in the tray are the water pump and the purge pump. Note the two electrical wires running from the pumps to the square, black hole at the bottom, left of the fan housing.
At lower, right, on the outside, is the water feed.

Where the pump wires go. That black, square aperture in the previous picture was originally covered with the white, square, plastic cover you see. You will need to remove the two screws and plastic cover. These three items are prime candidates for getting lost, so I put them in my empty, front pants pocket.

Now comes the risky business part. You need to fish those wires out of that hole. Do it slowly, carefully, and gently jiggle the wires whenever feeling any resistance. Pulling the wires too hard will unplug them while they are still inside the housing. You do not want that.

You will eventually end up with the two plugs on the outside. Keeping in mind the warning in the first set of instructions, pull out the old cooler pump plug and plug in the new one at the appropriate time and as described.
Reinsert the wires back into the housing; and adjust everything the way you want it to be. Then finally put the plastic cover and two screws back on the electrical access aperture.


Everything re-attached and ready to go. Time to do the test as described in the first segment.


After the test, refasten the hose back into the plastic holders. Check entire length for kinks.

A side note picture of the floater, controlling the water level in the tray. Slightly bending the floater rod up or down will change the water level accordingly.


A side note, example picture close up of how the water feed and valve might be connected to the water supply. Configurations vary.
© On this particular article, images are also copyrighted by websitewithnoname.com.