In Datenherkunft von Formularen und Berichten Textteile austauschen

Bei Änderungen an der Datenbankstruktur sollen auch Tabellen- und Feldnamen geändert werden. In Modulen geht das einfach durch STRG + H (Ersetzen). Die in Access-Objekten eingebetteten SQL-Anweisungen werden so nicht erwischt. Hierzu folgende Funktion, die zweckmäßigerweise aus einem Makro (s. Abb.) aufgerufen werden kann.

Argumente:

1. oldString: das alte Textstück (z.B. "Länderschlüssel")
2. newString: das stattdessen einzusetzende (z.B. "Laenderschluessel")
3. findInForms: Ersetze in RecordSource jedes Formulars und Berichts (nur FALSE, falls nicht gewünscht)
   
4. findInControls: Ersetze in RowSource aller Listen- und Kombinationsfelder (nur FALSE, falls nicht gewünscht)

---

Public Function RenamePartInRSources(oldString As String, newString As String, _
Optional findInForms As Boolean = True, Optional findInControls As Boolean = True)
'ersetzt in der Datenherkunft von Form/Control ein Wort durch ein anderes
On Error GoTo Er
Debug.Print "Ersetze " & oldString & " durch " & newString
If oldString = "" Then Err.Raise 10001, , "Parameterfehler oldString"
If newString = "" Then Err.Raise 10002, , "Parameterfehler newString"
If Not (findInForms Or findInControls) Then Err.Raise 10003, , "Parameterfehler findIn*"

Dim AO As AccessObject
Dim F As Form
Dim R As Report

Dim o As String
Dim s As String
Dim i As Integer

For Each AO In Application.CurrentProject.AllForms
DoCmd.OpenForm AO.Name, acDesign, , , acFormEdit, acHidden
Set F = Forms(AO.Name)
If findInForms Then 'in Formular ersetzen
o = F.RecordSource
' Debug.Print F.Name & ": " & F.RecordSource
s = Replace(o, oldString, newString)
F.RecordSource = s
If s <> o Then Debug.Print F.Name & ": " & F.RecordSource
s = ""
End If

If findInControls Then 'in Steuerelement ersetzen
For i = 0 To F.Controls.Count - 1
On Error Resume Next
o = F(i).RowSource
' Debug.Print F.Name & "." & F(i).Name & ": " & F(i).RowSource
s = Replace(o, oldString, newString)
F(i).RowSource = s
If s <> o Then Debug.Print F.Name & "." & F(i).Name & ": " & F(i).RowSource
On Error GoTo Er
s = ""
Next i
End If
DoCmd.Close acForm, AO.Name, acSaveYes
Next AO

For Each AO In Application.CurrentProject.AllReports
DoCmd.OpenReport AO.Name, acDesign, , , acHidden
Set R = Reports(AO.Name)
If findInForms Then 'in Bericht ersetzen
o = R.RecordSource
s = Replace(o, oldString, newString)
R.RecordSource = s
If s <> o Then Debug.Print R.Name & ": " & R.RecordSource
s = ""
End If

If findInControls Then 'in Steuerelement ersetzen
For i = 0 To R.Controls.Count - 1
On Error Resume Next
o = R(i).RowSource
s = Replace(o, oldString, newString)
R(i).RowSource = s
If s <> o Then Debug.Print R.Name & "." & R(i).Name & ": " & R(i).RowSource
On Error GoTo Er
s = ""
Next i
End If
DoCmd.Close acReport, AO.Name, acSaveYes
Next AO
Ex:
Set AO = Nothing
Set F = Nothing
Set R = Nothing
Debug.Print "RenamePartInRSources beendet."
Exit Function
Er: MsgBox "Fehler " & Err.Number & " in Tools.RenamePartInRowSource" _
& vbCrLf & Err.Description
Resume Ex
End Function

Die ausgewählten Items einer Listbox in String sichern

Public Sub SelectedFromStringToListBox(ByVal gesamtString As String, Liste As ListBox)
    On Error GoTo Er
    Dim v
    Dim i As Integer
    Dim j As Integer
    With Liste
        For Each v In .ItemsSelected
            .Selected(v) = False
        Next v
        v = Split(gesamtString, "; ")
        For i = 0 To UBound(v)
            For j = 0 To .ListCount - 1
                If v(i) = .ItemData(j) Then
                    .Selected(j) = True
                    Exit For
                End If
            Next j
        Next i
    End With
Ex: Exit Sub
Er: MsgBox "Fehler " & Err.Number & " in SelectedFromStringToListBox" _
    & vbCrLf & Err.Description
    Resume Ex
End Sub


Public Function SelectedFromListbox(ByVal Liste As ListBox) As String
    On Error GoTo Er
    Dim s As String
    Dim v
    s = ""
    For Each v In Liste.ItemsSelected
        If s > "" Then s = s & "; "
        s = s & Liste.ItemData(v)
    Next v
Ex:
    SelectedFromListbox = s
    Exit Function
Er: MsgBox "Fehler " & Err.Number & " in SelectedFromListbox" _
    & vbCrLf & Err.Description
    s = ""
    Resume Ex
End Function