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 "&amp;", avoid recursive loop by replacing first with @amp;@
             strValues = substTextForText(strValues, "&", "@amp;@")
             'replace temp @amp;@ with &amp;
             strValues = substTextForText(strValues, "@amp;@", "&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, ">", "&gt;")
           End If
           ''--description
           If InStr(strDesc, "&") > 0 Then
             'must replace & with "&amp;", avoid recursive loop by replacing first with @amp;@
             strDesc = substTextForText(strDesc, "&", "@amp;@")
             'replace temp @amp;@ with &amp;
             strDesc = substTextForText(strDesc, "@amp;@", "&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, ">", "&gt;")
           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