Code Snippet "VBA Access"

Hilfsfunktionen und Hilfsroutinen, um Abhängigkeiten von Access-Abfragen aufzudröseln

Besser als die Anzeige von Abhängigkeiten in Access 2003, weil diese bei SELECTs in WHERE-Clauses versagt

Option Compare Database
Option Explicit

'Achtung: Diese Prozeduren benötigen einen Verweis auf Microsoft DAO!

'------------------------------------------------------------
'Prozedur zum Testen von Abhängigkeiten in einer DB
Sub procTestDBObjects()
  Dim objDBObjekt As AccessObject
  Dim strResult As String
  Dim objDictionaryFrm
  Dim objDictionaryRpt

  Set objDictionaryFrm = funFormsDatasources()
  Set objDictionaryRpt = funReportsDatasources()


  'Durch jede Tabelle loopen
  strResult = "Tabellen" & vbCrLf & "--------------------------" & vbCrLf & vbCrLf
  For Each objDBObjekt In Application.CurrentData.AllTables
    Debug.Print objDBObjekt.Name
    'Kommt diese Tabelle in Abfrage vor
    strResult = strResult & vbCrLf & funInQueriesVorhanden(objDBObjekt.Name)
    strResult = strResult & funInDictionaryItemVorhanden(objDBObjekt.Name, objDictionaryFrm)
    strResult = strResult & funInDictionaryItemVorhanden(objDBObjekt.Name, objDictionaryRpt)
    strResult = strResult & vbCrLf
  Next
  
  'Durch jede Abfrage loopen
  strResult = strResult & vbCrLf & vbCrLf & vbCrLf & "Abfragen" & vbCrLf & "--------------------------" & vbCrLf & vbCrLf
  For Each objDBObjekt In Application.CurrentData.AllQueries
    Debug.Print objDBObjekt.Name
    'Kommt diese Abfrage in Abfrage vor
    strResult = strResult & vbCrLf & funInQueriesVorhanden(objDBObjekt.Name)
    strResult = strResult & funInDictionaryItemVorhanden(objDBObjekt.Name, objDictionaryFrm)
    strResult = strResult & funInDictionaryItemVorhanden(objDBObjekt.Name, objDictionaryRpt)
    strResult = strResult & vbCrLf
  Next
  'Debug.Print strResult
  
  Call procWriteTextfile(Application.CurrentProject.Path & "\" & _
    Left(Application.CurrentProject.Name, Len(Application.CurrentProject.Name) - 4) & "_DBBeziehungen.txt", strResult)
  
End Sub


'------------------------------------------------------------
'Prozedur schreibt alle Queries in ein Textfile (Achtung: Unicode!)
Sub procTestSQL()
  Dim db As DAO.Database
  Dim objDBObjekt
  Dim objDictionary
  Dim strResult As String
  Dim strFeldtrennzeichen
  Dim strSatztrennzeichen
  Dim wrkJet As Workspace
  
  strFeldtrennzeichen = vbCrLf
  strSatztrennzeichen = vbCrLf & vbCrLf
  
  'Set db = CurrentDb
  Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)
  Set db = wrkJet.OpenDatabase("F:\_temp\Nordwind.mdb", True)


  Set objDictionary = funQueriesSQL(db)
  strResult = funDictionaryItemsToString(objDictionary, strFeldtrennzeichen, strSatztrennzeichen)
  
  Call procWriteTextfile(Left(db.Name, Len(db.Name) - 4) & "_SQL.txt", strResult)
  
  
  strResult = ""
  For Each objDBObjekt In db.TableDefs
    strResult = strResult & vbCrLf & objDBObjekt.Name & funInDictionaryItemVorhanden(objDBObjekt.Name, objDictionary) & vbCrLf
  Next
  Debug.Print strResult

End Sub


'------------------------------------------------------------
'Schreibt Textdatei
Sub procWriteTextfile(ByVal strFilenameAndPath As String, ByVal strContent As String)
  Dim objtextfile
  Dim objfs

  'FileSystemObject erzeugen
  Set objfs = CreateObject("Scripting.FileSystemObject")
  
  'Textdatei-Objekt erzeugen mit Überschreiben und mit Unicode
  Set objtextfile = _
    objfs.CreateTextFile(strFilenameAndPath, True, True)
  objtextfile.write (strContent)
  objtextfile.Close

End Sub


'------------------------------------------------------------
'Testet, ob ein gesuchter String in einem Item des Dictionaries vorkommt
Function funInDictionaryItemVorhanden(ByVal strObjName As String, ByVal objDictionary) As String
  Dim objItem
  Dim strResult As String
  
  For Each objItem In objDictionary.Keys
    'Debug.Print objItem & vbCrLf & objDictionary.Item(objItem) & vbCrLf
    If InStr(objDictionary.Item(objItem), strObjName) > 0 Then
      strResult = strResult & vbCrLf & "  " & objItem
    End If
  Next
  
  If strResult = "" Then
    strResult = vbCrLf & "  -"
  End If
  
  funInDictionaryItemVorhanden = strResult
End Function


'------------------------------------------------------------
'Erzeugt aus einem Dictionary einen String mit Key und Item
Function funDictionaryItemsToString(ByVal objDictionary, ByVal strFeldtrennzeichen, ByVal strSatztrennzeichen) As String
  Dim objItem
  Dim strResult As String
  
  For Each objItem In objDictionary.Keys
    strResult = strResult & objItem & strFeldtrennzeichen & objDictionary.Item(objItem) & strSatztrennzeichen
  Next
  
  funDictionaryItemsToString = strResult
End Function


'------------------------------------------------------------
'Holt die Datasources der Formulare und füllt sie in Dictionary ab
'Hilfsprozedur, damit die Formulare nur einmal geöffnet werden müssen
Function funFormsDatasources()
  Dim objDictionary
  Dim objForm As AccessObject
  
  Set objDictionary = CreateObject("Scripting.Dictionary")

  For Each objForm In Application.CurrentProject.AllForms
    'Debug.Print objForm.Name
    
    DoCmd.OpenForm objForm.Name, acDesign, , , acFormPropertySettings
    'Debug.Print "  " & Forms(objForm.Name).RecordSource
    objDictionary.Add objForm.Name, Forms(objForm.Name).RecordSource
    DoCmd.Close acForm, objForm.Name
  Next
  
  Set funFormsDatasources = objDictionary
End Function


'------------------------------------------------------------
'Holt die Datasources der Reports und füllt sie in Dictionary ab
'Hilfsprozedur, damit die Reports nur einmal geöffnet werden müssen
Function funReportsDatasources()
  Dim objDictionary
  Dim objDBObjekt As AccessObject
  
  Set objDictionary = CreateObject("Scripting.Dictionary")

  For Each objDBObjekt In Application.CurrentProject.AllReports
    'Debug.Print objDBObjekt.Name
    
    DoCmd.OpenReport objDBObjekt.Name, acDesign
    'Debug.Print "  " & Reports(objDBObjekt.Name).RecordSource
    objDictionary.Add objDBObjekt.Name, Reports(objDBObjekt.Name).RecordSource
    DoCmd.Close acReport, objDBObjekt.Name
  Next
  
  Set funReportsDatasources = objDictionary
End Function


'------------------------------------------------------------
'Holt SQL-Statements einer DB und füllt sie in Dictionary ab
'Hilfsprozedur, damit die Formulare nur einmal geöffnet werden müssen
Function funQueriesSQL(ByVal db As DAO.Database)
  Dim objDictionary
  Dim qdf As DAO.QueryDef
  
  Set objDictionary = CreateObject("Scripting.Dictionary")
  For Each qdf In db.QueryDefs
    objDictionary.Add qdf.Name, qdf.SQL
  Next qdf
  
  Set funQueriesSQL = objDictionary
End Function


'------------------------------------------------------------
'Kommt ein bestimmtes DB-Objekt, d.h. Tabelle oder Abfrage, in einer Abfrage vor
Function funInQueriesVorhanden(ByVal strObjName As String) As String
  Dim db As DAO.Database
  Dim qdf As DAO.QueryDef
  Dim strResult As String
  
  Set db = CurrentDb
  
  For Each qdf In db.QueryDefs
    If InStr(qdf.SQL, strObjName) > 0 Then
      strResult = strResult & vbCrLf & "  " & qdf.Name
    End If
  Next qdf
  
  Set db = Nothing
  If strResult = "" Then
    strResult = vbCrLf & "  -"
  End If
  funInQueriesVorhanden = strObjName & ": " & strResult
End Function


'------------------------------------------------------------
'Zeigt SQL einer beliebigen Abfrage an, ohne dass sie geöffnet werden muss
Function showSQLOfQuery(ByVal strObjName As String) As String
  Dim db As DAO.Database
  Dim qdf As DAO.QueryDef
  Dim strResult As String
  
  Set db = CurrentDb
  
  strResult = strObjName & vbCrLf & db.QueryDefs(strObjName).SQL
  
  showSQLOfQuery = strResult
End Function