Free Visual Basic / in VB / in SQL / MS Access Computer Programming Code Examples II of II (Learn / Do)

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.

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.

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

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

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

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

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

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