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.

Google Blogger / Blogspot Users: Beware Revert to Draft

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

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? 😁

Entropy in Everyday Life and Why Do Things Go Wrong

If you are looking for how entropy is an integral part of our lives, then you have found it. An alternate title for this page would be: The Reality of Entropy  - The Top 10 Ways Entropy Messes with Us.

Among other things, this page has two lists. There is a short-description list of examples as to ways entropy affects our daily lives. And then there is a long-description list of examples explaining exactly how entropy does this.


For some readers, this page will be humorous. For other readers, this page will be serious. Both perceptions are correct. And it should be noted there are more than 10 ways scattered around this page. Lucky us.

List of Examples of the Effects of Entropy in Our Daily Lives

  • Why do things break down? That's entropy.
  • Why is Murphy's Law so prevalent? That's entropy.
  • Why do things malfunction? That's entropy.
  • Why are we obstructed in everything we try to do? That's entropy.
  • Why are there a hundred times more mistakes than accomplishments? That's entropy.
  • Why are there a hundred times more failures than successes? That's entropy.

The Universe - Entropy Is the Built-in Randomness of Reality

What does entropy mean to humanity? Whenever a human or humankind in general tries to create order, entropy immediately begins to disassemble it. This is why any man-made object will immediately begin to deteriorate upon its completion. It does not matter if it's a newly manufactured stick of gum or a newly-constructed, 100-story skyscraper; the result is always the same. Entropy immediately begins doing everything in its power to render it useless, broken-down, and of no value.

Chaos and Entropy

"Most of the fundamental ideas of science are essentially simple, and may, as a rule, be expressed in a language comprehensible to everyone." - Albert Einstein in The Evolution of Physics

Why Things Break – List of Examples of How Entropy Works and Some of Its Methodologies

How Entropy Uses Oxidation

One of entropy's favorite methods. With any physical item humankind creates, whether made of most metals or other materials, entropy will immediately start to change the object's chemical structure. In due course the object's chemical composition becomes such that the object's original purpose is no longer viable; plain, ordinary rust being the most well-known example. Another common example are liquids. Pretty much any liquid, whether relating to food or industrial manufacturing, begins to decompose and becomes useless fairly quickly when not immediately used for its intended purpose.

How Entropy Uses Gravity

Another favorite tool of entropy. Quite simply, entropy will keep pulling on each and every object until the object comes crashing down, no matter how long it takes. Entropy never quits. And the larger the object, the more forceful the gravity and the more determined entropy becomes. Breakage and injuries, whether animate or inanimate, are the norm.

How Entropy Uses Friction

Another tool of entropy. The more often used term for "friction" is "wear-and-tear". Every time an object is used, it is subjected to wear-and-tear. Sooner or later, the wear-and-tear renders the object no longer usable. Cars and other vehicles being the most well-known examples. However, entropy's industriousness is also equally busy with all other manufactured machinery as well. There does happen to be one scenario where friction is a good thing, but this website is not going to go there.

How Entropy Uses Contamination

One of entropy's often used tools. This is where entropy uses one class of objects to destroy another class of objects. Probably the top categories of objects entropy uses to destroy other objects and entities are bacteria, viruses, and even plain, ordinary dust. In fact, when entropy isn't using oxidation to destroy all man made foods or industrially made liquids, contamination is what entropy then brings into play.

How Entropy Uses Heat

Otherwise known as an increase in temperature. For every degree increase in temperature, entropy accelerates decomposition, deterioration, destruction of the target object. Heat is entropy's favorite method for rendering any and all manufactured electronics useless. A decrease of temperature to .01 degrees Kelvin is minimum entropy. An increase of temperature to x millions/billions degrees is maximum entropy.

How Entropy Uses Synergy or Combinations of Destructive Methods

Combining methods from the above list is also an entropic standard procedure. Entropy really likes using the combination of methods where possible, because it accelerates the destruction; usually exponentially. The best example is where friction generates heat, which causes expansion, which causes more friction, which causes more heat, ad infinitum; the inevitable and sometimes quick result being the destruction of the victim object. Any manufactured item with moving parts is where this most often comes into play.

How Entropy Uses Cross-Purposes

Another often overlooked tool of entropy. Aside from the inherent cross-purposes designed into what we perceive as nature; we tend to forget humans are also a part of the same construct. So much so that humans are at cross-purposes more often than they are at equilibrium. The more disagreement, the more entropy. Taken to extreme, there is much more entropy during war than peace.

Randomness and Probability


Randomness – Entropy's Favorite Tool of All

Randomness can otherwise be defined as thermodynamics and/or quantum physics. The only difference between the two being the size of the objects entropy uses as its tools. In the case of thermodynamics, entropy uses atoms and molecules as its implementer. In the case of quantum physics, entropy uses subatomic particles. In both cases, whether they be molecules, atoms, or subatomic particles; the little critters immediately start randomly wandering around and going places where we don't want them to go.

Probability – Entropy Uses This Tool When It Just Wants to Have Fun

Two cars arriving at an intersection at the same time is an example of this. And then there are the asteroids, very large meteors, etc.... They can and do intersect Earth's orbit every now and again. And, of course, sooner or later Earth is just going to happen to be there. Probability is really just an attempt to understand the aforementioned category of randomness; with the additional factor of randomness using the much larger objects along with the smaller ones.

Entropy Is the Opposite of Order

Entropy is change, invariably for the worse. Entropy is constant. The proverb, "Change is constant", is true. Entropy is the antithesis and enemy of order. Energy and matter are in constant flux. Entropy's favorite concepts, quite simply, are: decomposition, destruction, deterioration, and chaos.

How does one compensate for and accept entropy? Keeping the following premises in mind will help.
  •  Entropy is not our friend.
  • Entropy can be slowed, but never stopped.
  • Entropy can be postponed, but never defeated.
  • Nothing lasts forever.
  • The universe doesn't care.

Entropy takes it all, whether you want it to or not, entropy takes it all. Entropy bears it away, and in the end, there is only darkness.*
*A paraphrased quote from Stephen King.

Have a nice day.

Google Privacy Issues and You - What It Is and Always Will Be

2018, the untold story... Warning, some humor may be present; as well as the political aspect. But also lots of informational items and resources. In truth, Google does seem to be one of the more benign corporations out there. And they certainly have answered every question I've ever thrown at their search engine.

I Love Google. Well, Maybe "Fond" Is a Better Word.

Google. All Seeing. All Knowing. All Powerful.


If you really are concerned about privacy invasion, be sure to read the last section of this page. What you are concerned about has been going on long before the internet and Google arrived on the scene. In other words, on the private-sector side, George Orwell's 1984 scenario showed up a long time ago. As for the public-sector side, more about that later.)

Wherever I Go, There Is Google...

No matter which website I visit, there's the Google API's scattered across my screen. Google knows I've been there.

Whenever I search for something, Google knows and Google saves. And then Google follows me around, telling me all about it for the next month (they really do).

Google knows where I've been. Google knows where I am. Google knows where I want to go. But wait, there's more...
  • Google knows my name.
  • Google knows my gender.
  • Google knows my age.
  • Google knows my ethnicity.
  • Google knows my education level.
  • Google knows what I do for a living.
  • Google knows what I do for fun.
  • Google knows what I buy.
  • Google knows the companies I love.
  • Google knows the companies I hate.
  • Google knows what financial institution I use.
  • Google knows where I live.
  • Google knows the YouTube song I listened to six times a a row.

We Are Being Watched...

Not only does Google want to know, and does know, everything about me; they want to watch me.

So much so, they even send driverless cars with cameras that follow me around wherever I go. Sure, they say it is for their Google Maps; but I know better.

And if the cars weren't bad enough, now Google is launching satellites to watch over me. I mean seriously, satellites!?! They claim it's for their Google Earth, but then they took a picture of me in front of my house. [Yes, they really did. The technology is that good. No, I'm not posting the link; I'm already paranoid enough as it is.]

And then, of course, there's the whole GPS thing...

Google Headquarters

But Wait! There's Even More.

Google isn't happy just knowing everything about us and where we are at any given moment.

Google is gradually buying up the entire planet. If you doubt this, check out acquisitions and partnerships. Not only is Google buying up everything in sight, they have even partnered with the NASA Ames Research Center.

The NSA certainly loved Google and what they do. So much so, they were busily stealing all of Google's information about us from the Google data centers; leastwise until Google wised-up and encrypted it.

The CIA certainly loved Google. Apparently, they've been stealing everyone's user data from Google's Chrome browser. Fortunately, Google announced in March 2017 that they've finally been able to put a stop to most of it.

Do you use web-based email? Someone is probably thumbing through your letters as we speak.

Do you use Google Docs? Best not to put anything there that some law enforcement agency or your spouse's divorce lawyer might be interested in...

It Gets Worse... Google Has a Sense of Humor and Can Strike at Any Time...

...and without warning.

Depending on which browser you use:
This is only the tip of the iceberg. You can find more at Google Hoaxes and Easter Eggs.

Where Will Google Be in a 100 Years? They'll Still Be Around.


Other companies that have survived over 100 years include ExxonMobil, IBM, General Electric, Chevron, McKesson, and many others.

IBM is the most notable of these. Even though they are in the cutthroat technology industry, and even though they have seriously messed up at times, they are still around. And even prospering.

Will Google still be around in a 100 years? Probably. As long as Google continues to keep hiring the smartest people on the planet; and as long as Google continues its company charter policy of "Do no evil", and thus avoiding perturbing the general population; the odds of Google's continuing prosperity are good.

When some new company does come along with a threatening new technology, Google will no doubt do the corporate usual; buy them or stomp on them. Capitalism is capitalism...

One of Google's Data Centers

Though this page is sometimes humorous of intent, it somehow also kind of turned into an informational article and a review of Google and of internet life in general. I'm fine with that. All in all, I am fond of Google. One really does have to admire what Google has accomplished since its inception. And as far as corporations go, Google really does seem to be less evil than most.

The Privacy Controversy


There has been a lot of media coverage concerning privacy issues. The thing is, all the other corporations and companies out there have been doing the exact, same thing. And not just tech companies; any company that has any interaction with the public is busily snooping into your private life in every way they can. Admittedly, Google is probably better at it than most.

It gets worse. This has been going on long before the internet came along. Try decades and decades and decades; probably somewhere between 50 to a 100 years or even longer.

If you really want an eye-opener as to privacy invasion, try checking out the Credit Report Guide for Beginners page; this has likewise been going on for decades and decades and decades.

As previously mentioned, the private-sector side of privacy invasion arrived a long time ago. As for the public-sector side of things, both George Orwell's 1984 and Ray Bradbury's Fahrenheit 451 officially arrived the day after September 11, 2001.