VegBank

Option Compare Database

Option Explicit

''This functionality requires a set of tables that stores the values of the closed lists in the current database

''the tables are named like: aux_table_field where table is the name of the table and field is the name of the field that has a closed list

''There must also exist a Z_FieldDescription table in the database which documents which fields have closed lists

''As well as a query Z_FieldDescriptionOrd, which includes a table: misc_SQL_2AccTypes which translates "access" data types into "SQL" types

Function checkAux_tbls()

  'checks that aux_ tables have corresponding fields which access them in the Z_Field table

  ''and writes XML doc that describes the closed lists for vegBank

  Dim tdfCheck As Object

  Dim dbs As Object

  Set dbs = CurrentDb

  Dim strTbl As String, strFld As String, strTbl_Fld As String

  Dim cnnLocal As Connection

  Set cnnLocal = CurrentProject.Connection

  Dim rstCurr As New ADODB.Recordset

      Dim fs2 As Object

      Dim objWritefile As Object

      Dim objWriteRels As Object

      Set fs2 = CreateObject("Scripting.FileSystemObject")

      Dim strValues As String

      'creates file for writing XML

      Set objWritefile = fs2.CreateTextFile("C:\temp\closedLists.xml", True)

      Set objWriteRels = fs2.CreateTextFile("C:\temp\closedRelSQL.sql", True)

      'write header for XML

      objWritefile.writeLine "<!-- created with MS ACCESS VBA by Michael Lee " & Now() & "-->"

      objWritefile.writeLine "<tableDefns>"

  Dim intCount As Integer

  intCount = 0

  For Each tdfCheck In dbs.tabledefs

    If Left(tdfCheck.Name, 4) = "aux_" Then

      strTbl_Fld = Right(tdfCheck.Name, Len(tdfCheck.Name) - 4)

      If InStr(strTbl_Fld, "_") = 0 Then

        If strTbl_Fld <> "Aux_Role" Then  ''aux_role just is different

          MsgBox "no '_' in field name, error! " & tdfCheck.Name

        End If

      Else 'has "_"

        strTbl = Left(strTbl_Fld, InStr(strTbl_Fld, "_") - 1)

        strFld = Right(strTbl_Fld, Len(strTbl_Fld) - InStr(strTbl_Fld, "_"))

        'Debug.Print strTbl_Fld

        rstCurr.Open "SELECT tableName, FieldName, SQLtype, FieldSize FROM Z_FieldDescriptionORD WHERE tableName=""" & strTbl & _

          """ AND fieldName = """ & strFld & """;", cnnLocal, , , adCmdText

          Dim strDTFull As String

          strDTFull = ""

          'start SQL for this table

          Dim strSQLref As String

          intCount = intCount + 1

          objWriteRels.writeLine "ALTER TABLE [" & strTbl & "]"

          objWriteRels.writeLine "    ADD CONSTRAINT auxRel_" & intCount & strTbl_Fld & " FOREIGN KEY ([" & strFld & "]) "

          objWriteRels.writeLine "    REFERENCES [" & tdfCheck.Name & "] (values); "

          objWriteRels.writeLine ""

        'start XML for this table:

        objWritefile.writeLine "    <list>"

        objWritefile.writeLine "       <sourceTableName>" & tdfCheck.Name & "</sourceTableName>"

        objWritefile.writeLine "       <TableName>" & strTbl & "</TableName>"

        objWritefile.writeLine "       <FieldName>" & strFld & "</FieldName>"

        If rstCurr.EOF And rstCurr.BOF Then

          'no record matches

          Debug.Print strTbl_Fld & " has no records"

        Else

          'matches, write XML for type

          If rstCurr!SQLType = "varchar" Then

            'add length

            strDTFull = "varchar (" & rstCurr!FieldSize & ")"

          Else

            strDTFull = rstCurr!SQLType

          End If

          objWritefile.writeLine "       <tableDataType>" & strDTFull & "</tableDataType>"

        End If

        rstCurr.Close

        'open actual table to get values and print to XML

        rstCurr.Open tdfCheck.Name, cnnLocal, , , adCmdTable

        Do Until rstCurr.EOF

           strValues = rstCurr!values

           'vars for description and sort order

           Dim strDesc As String, lngSort As Long

           If fieldExistOnTbl("ValueDescription", tdfCheck.Name) Then

             strDesc = Nz(rstCurr!ValueDescription, "")

           Else

             strDesc = ""

           End If

           If fieldExistOnTbl("SortOrd", tdfCheck.Name) Then

             lngSort = Nz(rstCurr!SortOrd, 0)

           Else

             lngSort = 0

           End If

           If InStr(strValues, "&") > 0 Then

             'must replace & with "&", avoid recursive loop by replacing first with @amp;@

             strValues = substTextForText(strValues, "&", "@amp;@")

             'replace temp @amp;@ with &

             strValues = substTextForText(strValues, "@amp;@", "&")

           End If

           If InStr(strValues, "<") > 0 Then

             'must replace < with "&lt;"

             strValues = substTextForText(strValues, "<", "&lt;")

           End If

           If InStr(strValues, ">") > 0 Then

             'must replace < with "&lt;"

             strValues = substTextForText(strValues, ">", ">")

           End If

           ''--description

           If InStr(strDesc, "&") > 0 Then

             'must replace & with "&", avoid recursive loop by replacing first with @amp;@

             strDesc = substTextForText(strDesc, "&", "@amp;@")

             'replace temp @amp;@ with &

             strDesc = substTextForText(strDesc, "@amp;@", "&")

           End If

           If InStr(strDesc, "<") > 0 Then

             'must replace < with "&lt;"

             strDesc = substTextForText(strDesc, "<", "&lt;")

           End If

           If InStr(strDesc, ">") > 0 Then

             'must replace < with "&lt;"

             strDesc = substTextForText(strDesc, ">", ">")

           End If

           objWritefile.writeLine "       <record>"

           objWritefile.writeLine "         <values>" & strValues & "</values>"

           objWritefile.writeLine "         <valueDescription>" & strDesc & "</valueDescription>"

           objWritefile.writeLine "         <sortOrd>" & lngSort & "</sortOrd>"

           objWritefile.writeLine "       </record>"

           rstCurr.MoveNext

        Loop

        objWritefile.writeLine "    </list>"

        rstCurr.Close

      End If '"_"

    End If

  Next tdfCheck

objWritefile.writeLine "</tableDefns>"

End Function

Public Function substTextForText(strSource, strFind, strReplace) As String

'function takes a string (strSource), searches it for strFind

 ' and replaces strFind with strReplace

 Dim intLoop As Integer, intWhere As Integer, intLenWhole As Integer, intLenfind As Integer

  If (Nz(Len(strSource), 0) = 0) Or (Nz(Len(strSource), 0) = 0) Then

   'MsgBox "A search element is 0, error!"

   Exit Function

 End If

 If InStr(strReplace, strFind) <> 0 Then

   MsgBox "error, your replace element contains the search element!"

   Exit Function

 End If

 intLenfind = Len(strFind)

 intLoop = 0 'counter

 'Debug.Print strSource

 Do Until InStr(strSource, strFind) = 0

   intLoop = intLoop + 1

   'instr does not = 0

   intWhere = InStr(strSource, strFind)

   intLenWhole = Len(strSource)

   If intLenWhole = 0 Then GoTo Err0

   strSource = Left(strSource, intWhere - 1) & strReplace & _

    Right(strSource, intLenWhole - (intWhere + intLenfind) + 1)

   'Debug.Print strSource

   If intLoop / 500 = Int(intLoop / 500) Then

     'got out of control somehow

     Dim intGetAnswer As Integer

     intGetAnswer = MsgBox(intLoop & " iterations, not done, probably infinited loop.  Stop?", vbYesNo)

     If intGetAnswer = vbYes Then

       Exit Function

     End If

   End If

 Loop

   '"succeeded.  " & intloop & " replaced.  Now is:" & Chr(13) & strSource

   substTextForText = strSource

 Exit Function

Err0:  MsgBox "length is somehow 0"

End Function

Public Function fieldExistOnTbl(strFld As String, strTbl As String) As Boolean

''returns true if field is found on table/qry def

On Error GoTo Failed

Dim rstME As New ADODB.Recordset

rstME.Open "SELECT [" & strFld & "] FROM [" & strTbl & "];", _

  CurrentProject.Connection, adOpenForwardOnly, adLockReadOnly, adCmdText

'success!

fieldExistOnTbl = True

Exit Function

Failed:

fieldExistOnTbl = False

End Function