Option Compare Database
Option Explicit

'SRNO Flatfile data scrubbing routine

'Ed Reynolds
'Glenn Fullerton
'Dave Chamberlain
'Jan Lohoff 

'srn.bat -  is a Windows batch file which launches a file transfer from the KGPETSO mainframe to the local drive/fileserver share

'srn.ftp - is a text file containing the ftp line commands that are piped to the ftp process (via the batch file)

'srn.txt is the resulting flatfile, imported into a Microsoft Access database table

' This module was developed by John "Slowly" Bonifas
' and was completed 11-24-99.
' ====================================================================================================
' ====================================================================================================
'

Public Const ftp_exe = "[d:][path]\ftp.exe"
Public Const ftp_opts = "-v -w:16384 "
Public Const ftp_script = "-s:[d:][path]\srn.ftp"
Public Const TheTable = "SRN1"
Public Const TheImportSpec = "Srn Import Specification"

' ATTENTION!! - Because people insist on putting spaces in their directory names and files, I have had
' to hard code the path to the flat file in the TransferText and outputto methods,
' because there apparently is a bug in these routines that make them have a hard time with spaces in
' filenames and folders. Ye have been warned. >:(

Public Const TheFileSpec = "[d:][path]\srn.txt"
Public Const TheSpreadsheet = "[d:][path]\SRN_OUTPUT.XLS"

Public Const QueryID = "APPEND"
Public Const QueryIDLength = 6
Public Const CodeTitle = "SRN Database Update"
Public Const TheExcelExec = "[d:][path]\excel.exe "
Public Const TheExportTable = "OUTPUT_TO_EXCEL"

Public Const ThisName = "Update Querydefs Table Routine"

Private Type SQLStringRecord

    PositionPtr As Integer
    StringValue As String
        
End Type

Private SQLString(4) As SQLStringRecord

Function SRN_data_update()

Dim qry As QueryDef, tdf As TableDef, RstExcel As Recordset, RstCurrQuery As Recordset
Dim ToUser As Variant, RunLoop As Integer

' turn off warnings
   
DoCmd.SetWarnings False
   
' download flat file

ToUser = SysCmd(acSysCmdSetStatus, "Downloading Flat File...")

Call Shell(ftp_exe & ftp_opts & ftp_script, vbNormalFocus)
   
ToUser = MsgBox("Waiting for download to finish.", vbInformation, CodeTitle)

ToUser = SysCmd(acSysCmdClearStatus)
   
' clear SRN1 and OUTPUT_TO_EXCEL tables of old data

DoCmd.RunSQL "delete * from " & TheTable & ";"
DoCmd.RunSQL "delete * from " & TheExportTable & ";"

' import new data into the table

DoCmd.TransferText acImportFixed, TheImportSpec, TheTable, "[d:][path]\srn.txt", False
     
ToUser = SysCmd(acSysCmdSetStatus, "Import Complete. Building export table...")

' run the APPEND query set

Set RstExcel = CurrentDb.OpenRecordset("OUTPUT_TO_EXCEL", dbOpenTable, dbAppendOnly)

For Each qry In CurrentDb.QueryDefs

    If right$(qry.Name, QueryIDLength) = QueryID Then

        Set RstCurrQuery = qry.OpenRecordset

        If RstCurrQuery.RecordCount = 0 Then
    
            With RstExcel
    
                .AddNew
    
                ![SumOfCountOfPart Number] = 0
                !OwningGroup = "-"
                !Query = RstCurrQuery.Name
    
                .Update
    
            End With
    
        Else

            RstCurrQuery.MoveFirst
    
            With RstExcel
    
                .AddNew
    
                Select Case RstCurrQuery.Fields(0).Name
        
                    Case "SumOfCountOfPart Number"
        
                        ![SumOfCountOfPart Number] = RstCurrQuery.Fields("SumOfCountOfPart Number").Value
        
                    Case "CountOfPart Number"
        
                        ![SumOfCountOfPart Number] = RstCurrQuery.Fields("CountOfPart Number").Value
            
                    Case Else
        
                        ToUser = MsgBox("ERROR: first field name has been changed from either 'SumOfCountOfPart Number'" & vbCrLf & _
                                "or 'CountOfPart Number'. Please change it back on the query: " & _
                                RstCurrQuery.Name & vbCrLf & " and run the Update routine again.", _
                                vbCritical, CodeTitle)
            
                        Exit Function
            
                End Select
        
                !OwningGroup = RstCurrQuery.Fields("OwningGroup").Value
                !Query = RstCurrQuery.Name
    
                .Update
    
            End With
    
        End If 'RstCurrQuery.RecordCount = 0

    End If 'Right$(qry.Name, QueryIDLength) = QueryID

Next qry

' export the data to Excel

ToUser = SysCmd(acSysCmdSetStatus, "Build Complete. Exporting Data to Excel...")

DoCmd.OutputTo acTable, TheExportTable, "MicrosoftExcel(*.xls)", "[d:][path]\SRN_OUTPUT.XLS", True, ""

' clean up

Set qry = Nothing: Set tdf = Nothing

End Function 'RunQueries

Function CreateQueryDefs()

Dim tdf As TableDef, rst As Recordset, WriteLoop As QueryDef, TableName As String
Dim TableFlag As Boolean, ShowTable As Boolean, BatchMode As Boolean
Dim ToUser As Variant, RCount As Long, Temp As String, TempFlag As Boolean

ShowTable = True: BatchMode = False: TableName = "querydefs": TableFlag = False

For Each tdf In CurrentDb.TableDefs
    
    If (tdf.Name = TableName) Then TableFlag = True
       
Next

If TableFlag = True Then

On Error Resume Next
DoCmd.RunSQL ("delete * from " & TableName & ";")
If Err.Number <> 0 Then
        ToUser = MsgBox("Tablename: " & TableName & "generated an error: " & vbCrLf & _
                 Err.Description & vbCrLf & Err.source & vbCrLf, vbExclamation, ThisName)
        On Error GoTo 0
        Exit Function
Else
        On Error GoTo 0
End If

Else

    On Error Resume Next
    DoCmd.CopyObject "", TableName, acTable, "template"
    If Err.Number <> 0 Then
        ToUser = MsgBox("Missing template table. Please create it.", _
        vbExclamation, ThisName): Exit Function
    Else
        On Error GoTo 0
    End If
    
End If

Set rst = CurrentDb.OpenRecordset(TableName, dbOpenDynaset)

' Write out the contents of the FileRecord array into the output table

For Each WriteLoop In CurrentDb.QueryDefs

    With rst

        TempFlag = False
        
        If left$(WriteLoop.Name, 2) = "1_" Then TempFlag = True
        If (left$(WriteLoop.Name, 3) = "11_" Or left$(WriteLoop.Name, 3) = "12_" Or _
            left$(WriteLoop.Name, 3) = "13_" Or left$(WriteLoop.Name, 3) = "14_") = _
            True Then TempFlag = True
        
        If TempFlag = True Then
                    
            .AddNew
           
            !QueryName = WriteLoop.Name
            !FullSqlString = WriteLoop.SQL
        
            ' 1 = select, 2 = from, 3 = group, 4 = having
        
            SQLString(1).PositionPtr = InStr(1, WriteLoop.SQL, "SELECT", vbTextCompare)
            SQLString(2).PositionPtr = InStr(1, WriteLoop.SQL, "FROM", vbTextCompare)
            SQLString(3).PositionPtr = InStr(1, WriteLoop.SQL, "GROUP BY", vbTextCompare)
            SQLString(4).PositionPtr = InStr(1, WriteLoop.SQL, "HAVING", vbTextCompare)
            
            SQLString(1).StringValue = Mid$(WriteLoop.SQL, SQLString(1).PositionPtr, _
            SQLString(2).PositionPtr - SQLString(1).PositionPtr)
            
            SQLString(2).StringValue = Mid$(WriteLoop.SQL, SQLString(2).PositionPtr, _
            SQLString(3).PositionPtr - SQLString(2).PositionPtr)
            
            SQLString(3).StringValue = Mid$(WriteLoop.SQL, SQLString(3).PositionPtr, _
            SQLString(4).PositionPtr - SQLString(3).PositionPtr)
            
            SQLString(4).StringValue = Mid$(WriteLoop.SQL, SQLString(4).PositionPtr, _
            Len(WriteLoop.SQL) - SQLString(4).PositionPtr - 1)
        
            On Error GoTo truncation
        
            !Select = SQLString(1).StringValue
            !From = SQLString(2).StringValue
            !Group = SQLString(3).StringValue
            !Having = SQLString(4).StringValue
            
            .Update
        
        End If
        
    End With           'add one record

Next WriteLoop    'add the records loop

GoTo skiptruncation

truncation:

    Select Case Err.Number
    
        Case 3163
    
            Debug.Print "Warning: On record number: " & rst.RecordCount & vbCrLf & _
            "Certain data was too long for a field and was truncated."
            Resume Next
    
        Case 3265
        
            Debug.Print "Warning: On record number: " & rst.RecordCount & vbCrLf & _
            "A field being requested is missing from the existing table. " & _
            "The field will not be output."
            Resume Next
        
        Case Else
    
        ToUser = MsgBox("I blew up. <:( " & vbCrLf & "The error is: " & _
        Err.Number & ":" & Err.Description & "," & Err.source, vbExclamation, ThisName)
        
        Set tdf = Nothing: Set rst = Nothing
        Exit Function
        
    End Select
    
skiptruncation:

' close the recordset and open the table for viewing if the user requested it

RCount = rst.RecordCount
rst.Close

If BatchMode = False Then
    If ShowTable = True Then
        DoCmd.OpenTable (TableName)
    Else
        ToUser = MsgBox("Done. :) Number of queries processed = " & RCount, _
        vbExclamation, ThisName)
    End If
End If

' clean up

Set tdf = Nothing: Set rst = Nothing

' that's all, folks

End Function 'CreateQueryDefs