mdlSprache

'---------------------------------------------------------------------------------------
' Modul : mdlSprache 1.30
' Autor : Günter Gerold
' Datum : 16.11.2008
' Text :
'
'
' 2 Sprachen werden automatisch erzeugt. Sind weitere Sprachen gewünscht, diese in
' tblSprachen eintragen und die Suchen erneut starten.
'
' Abhängigkeiten:
' Der Verweis "Microsoft Basic for Applications Extensibility 5.3" muss gesetzt sein
'
'---------------------------------------------------------------------------------------

Option Compare Database
Option Explicit

Public m_db As DAO.Database
Public Const cMaxTextFeldlaengeAccess As Integer = 255
Public Enum eDataType
dtText = 1
dtmemo = 2
End Enum
Public Enum eSuchBereich
dtRowSource = 1
dtRecordSource = 2
dtControlSource = 3
dtSQL = 4
End Enum
Public Property Get CurrentDbC() As DAO.Database
'Code courtesy of MichKa
10 On Error GoTo CurrentDbC_Error

20 If (m_db Is Nothing) Then
30 Set m_db = CurrentDb
40 End If

50 Set CurrentDbC = m_db

Ausgang:
60 On Error Resume Next
70 Exit Property

CurrentDbC_Error:
80 Select Case Err.Number
Case 0
90 Resume Ausgang
100 Case Else
110 Call fncErrorHandler("mdlSprache", "CurrentDbC")
120 Resume Ausgang
130 End Select

End Property

'---------------------------------------------------------------------------------------
' Prozedur : ggStart
' Autor : Günter Gerold
' Datum : 15.11.2008
' Text : Einstiegspunkt des Addins
'---------------------------------------------------------------------------------------

Public Function ggStart() As Boolean

10 On Error GoTo ggStart_Error

20 DoCmd.OpenForm ("ggfrmStart")

Ausgang:
30 On Error Resume Next
40 Exit Function

ggStart_Error:
50 Select Case Err.Number
Case 0
60 Resume Ausgang
70 Case Else
80 Call fncErrorHandler("mdlSprache", "ggStart")
90 Resume Ausgang
100 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncOptimizeStringForSQL
' Autor : Günter Gerold
' Datum : 15.11.2008
' Text : Falls im String ein Hochkomma vorkommt muß es verdoppelt werden, damit SQL es richtig interprätiert
'---------------------------------------------------------------------------------------

Public Function fncOptimizeStringForSQL(ByVal strSQL As String, Optional ByVal DataType As eDataType = dtText, Optional ByVal lngFeldLänge As Long = cMaxTextFeldlaengeAccess) As String
10 On Error GoTo fncOptimizeStringForSQL_Error

20 If DataType = eDataType.dtText Then
30 strSQL = Left$(strSQL, lngFeldLänge)
40 End If
50 fncOptimizeStringForSQL = Replace(strSQL, "'", "''")

Ausgang:
60 On Error Resume Next
70 Exit Function

fncOptimizeStringForSQL_Error:
80 Select Case Err.Number
Case 0
90 Resume Ausgang
100 Case Else
110 Call fncErrorHandler("mdlSprache", "fncOptimizeStringForSQL")
120 Resume Ausgang
130 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncSetFormBeschriftung
' Autor : Günter Gerold
' Datum : 01.11.2008
' Text : fügt "Formbeschriftung Me" in das Ereignis Öffnen jedes Formulars ein
'---------------------------------------------------------------------------------------

Public Function fncSetFormBeschriftung() As Boolean

Dim i As Long
Dim strZeile As String
Dim strFund As String
Dim lngStartZeile As Long
Dim bolGefunden As Boolean
Dim lngTeilnummer As Long
Dim intStartPos As Integer
Dim intEndPos As Integer
Dim StartColumn As Long
Dim EndColumn As Long
Dim boldirty As Boolean
Dim vbComp As vbide.VBComponent

10 On Error GoTo fncSetFormBeschriftung_Error

20 Application.VBE.MainWindow.Visible = False
30 If fncIsProtected = True Then Exit Function
40 For Each vbComp In Application.VBE.VBProjects(getProjectNumber).VBComponents 'Alle Formularnamen holen
50 If Not Left$(vbComp.Name, 11) = "Form_ggfrmS" And vbComp.Type = 100 And Left$(vbComp.Name, 4) = "Form" Then
60 i = vbComp.CodeModule.ProcBodyLine("Form_Open", vbext_pk_Proc)
70 StartColumn = 1
80 EndColumn = 255
90 lngTeilnummer = 1
100 i = i + 1
110 lngStartZeile = i
120 Do While vbComp.CodeModule.Find("Formbeschriftung", lngStartZeile, StartColumn, i + vbComp.CodeModule.ProcCountLines("Form_Open", vbext_pk_Proc), EndColumn) = True
130 strFund = vbComp.CodeModule.Lines(lngStartZeile, 1)
140 If Parser(strFund, lngTeilnummer, "FormBeschriftung", intStartPos, intEndPos) = True Then
150 bolGefunden = True
160 End If
170 StartColumn = EndColumn
180 EndColumn = 255
190 lngTeilnummer = lngTeilnummer + 1
200 Loop
210 If bolGefunden = False Then
220 strZeile = vbComp.CodeModule.Lines(i, 1)
230 strZeile = Trim$(strZeile)
240 Do While Left$(strZeile, 1) = "'" Or Left$(strZeile, 3) = "Rem" Or Left$(strZeile, 3) = "Dim" Or Nz(strZeile) = ""
250 i = i + 1
260 strZeile = vbComp.CodeModule.Lines(i, 1)
270 strZeile = Trim$(strZeile)
280 Loop
290 vbComp.CodeModule.InsertLines i, "FormBeschriftung Me 'Eingefügt vom Addin ggMehrsprachigkeit"
300 boldirty = True
310 End If
320 End If
330 If boldirty = True Then
340 Select Case vbComp.Type
Case 1, 2
350 DoCmd.Close acModule, vbComp.Name, acSaveYes
360 Case 100
370 If Left$(vbComp.Name, 4) = "Form" Then

380 DoCmd.Save acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5)
390 DoCmd.Close acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5), acSaveYes

400 ElseIf Left$(vbComp.Name, 6) = "Report" Then

410 DoCmd.Save acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7)
420 DoCmd.Close acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7), acSaveYes

430 Else
440 VBA.MsgBox "test"
450 End If
460 Case Else
470 VBA.MsgBox "test1"
480 End Select
490 boldirty = False
500 End If
510 Next
520 fncSetFormBeschriftung = True

Ausgang:
530 On Error Resume Next
540 Set vbComp = Nothing
550 Exit Function

fncSetFormBeschriftung_Error:
560 Select Case Err.Number
Case 0
570 Resume Ausgang
580 Case 35
590 vbComp.CodeModule.CreateEventProc "Open", "Form"
600 boldirty = True
610 Resume
620 Case Else
630 Call fncErrorHandler("mdlSprache", "fncSetFormBeschriftung")
640 Resume Ausgang
650 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncSetReportBeschriftung
' Autor : Günter Gerold
' Datum : 09.11.2008
' Text : fügt "Reportbeschriftung Me" in das Ereignis Öffnen jedes Berichts ein
'---------------------------------------------------------------------------------------

Public Function fncSetReportBeschriftung() As Boolean

Dim i As Long
Dim strZeile As String
Dim strFund As String
Dim lngStartZeile As Long
Dim bolGefunden As Boolean
Dim lngTeilnummer As Long
Dim intStartPos As Integer
Dim intEndPos As Integer
Dim StartColumn As Long
Dim EndColumn As Long
Dim boldirty As Boolean
Dim vbComp As vbide.VBComponent

10 On Error GoTo fncSetReportBeschriftung_Error

20 Application.VBE.MainWindow.Visible = False
30 If fncIsProtected = True Then Exit Function
40 For Each vbComp In Application.VBE.VBProjects(getProjectNumber).VBComponents
50 If Left$(vbComp.Name, 6) = "Report" And vbComp.Type = 100 Then
60 i = vbComp.CodeModule.ProcBodyLine("Report_Open", vbext_pk_Proc)
70 StartColumn = 1
80 EndColumn = 255
90 lngTeilnummer = 1
100 i = i + 1
110 lngStartZeile = i
120 Do While vbComp.CodeModule.Find("Reportbeschriftung", lngStartZeile, StartColumn, i + vbComp.CodeModule.ProcCountLines("Report_Open", vbext_pk_Proc), EndColumn) = True
130 strFund = vbComp.CodeModule.Lines(lngStartZeile, 1)
140 If Parser(strFund, lngTeilnummer, "ReportBeschriftung", intStartPos, intEndPos) = True Then
150 bolGefunden = True
160 End If
170 StartColumn = EndColumn
180 EndColumn = 255
190 lngTeilnummer = lngTeilnummer + 1
200 Loop
210 If bolGefunden = False Then
220 strZeile = vbComp.CodeModule.Lines(i, 1)
230 strZeile = Trim$(strZeile)
240 Do While Left$(strZeile, 1) = "'" Or Left$(strZeile, 3) = "Rem" Or Left$(strZeile, 3) = "Dim" Or Nz(strZeile) = ""
250 i = i + 1
260 strZeile = vbComp.CodeModule.Lines(i, 1)
270 strZeile = Trim$(strZeile)
280 Loop
290 vbComp.CodeModule.InsertLines i, "ReportBeschriftung Me 'Eingefügt vom Addin ggMehrsprachigkeit"
300 boldirty = True
310 End If
320 End If
330 If boldirty = True Then
340 Select Case vbComp.Type
Case 1, 2
350 DoCmd.Close acModule, vbComp.Name, acSaveYes
360 Case 100
370 If Left$(vbComp.Name, 4) = "Form" Then

380 DoCmd.Save acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5)
390 DoCmd.Close acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5), acSaveYes

400 ElseIf Left$(vbComp.Name, 6) = "Report" Then

410 DoCmd.Save acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7)
420 DoCmd.Close acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7), acSaveYes

430 Else
440 VBA.MsgBox "test3"
450 End If
460 Case Else
470 VBA.MsgBox "test4"
480 End Select
490 boldirty = False
500 End If
510 Next
520 fncSetReportBeschriftung = True
Ausgang:
530 On Error Resume Next
540 Set vbComp = Nothing
550 Exit Function

fncSetReportBeschriftung_Error:
560 Select Case Err.Number
Case 0
570 Resume Ausgang
580 Case 35
590 vbComp.CodeModule.CreateEventProc "Open", "Report"
600 boldirty = True
610 Resume
620 Case Else
630 Call fncErrorHandler("mdlSprache", "fncSetReportBeschriftung")
640 Resume Ausgang
650 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : ggfncFormControlsEinlesen
' Autor : Günter Gerold
' Datum : 11.11.2008
' Text : Es werden alle gewünschten Controls und ihre Inhalte aus allen
' Formularen in tblBeschriftungen eingelesen oder ergänzt. Gelöschte Controls werden auch
' aus tblBeschriftungen gelöscht.
'---------------------------------------------------------------------------------------

Public Function ggfncFormControlsEinlesen() As Boolean

Dim AktCtrl As Control
Dim rst As DAO.Recordset
Dim rsid As DAO.Recordset
Dim strSQL As String
Dim found As Boolean
Dim frm As Object
Dim allfrm As Object
Dim intSprachID As Integer

10 On Error GoTo ggfncFormControlsEinlesen_Error
20 If fncIsProtected = True Then Exit Function
30 Set rsid = CurrentDbC.OpenRecordset(cSpracheTabelle, dbOpenSnapshot)
40 For Each allfrm In Application.CurrentProject.AllForms 'Alle Formularnamen holen
50 DoCmd.OpenForm allfrm.Name, acDesign, , , , acHidden 'Alle Formulare nacheinander im Entwurfsmodus öffnen
60 Set frm = Forms(allfrm.Name)
70 rsid.MoveFirst
80 Do While Not rsid.EOF
90 intSprachID = rsid.Fields(cSpracheTabelleID).Value

100 strSQL = _
"SELECT " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleGueltigkeit & ", " & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & _
" FROM " & cBeschriftungstabelle & _
" WHERE " & cBeschriftungstabelleFormName & "='" _
& frm.Name & "' AND " & cBeschriftungstabelleSprachID & "=" & intSprachID & " AND " & cBeschriftungstabelleObjektTyp & " = " & acForm & ";"

110 Set rst = CurrentDbC.OpenRecordset(strSQL, dbOpenDynaset) 'Recordset auf eine Abfrage, die nur Datensätze des aktuellen Formulars und der aktuellen Sprache enthält
120 Do While Not rst.EOF 'Die Abfrage durchklappern und schauen, ob die Controls tatsächlich existieren
130 found = False
140 If rst.Fields(cBeschriftungstabelleSteuerelement).Value = frm.Name And rst.Fields(cBeschriftungstabelleTyp).Value = acForm Then
150 found = True
160 Else
170 For Each AktCtrl In frm.Controls
180 If rst.Fields(cBeschriftungstabelleSteuerelement).Value = AktCtrl.Name And rst.Fields(cBeschriftungstabelleTyp).Value <> acForm Then
190 found = True
200 Exit For
210 End If
220 Next
230 End If
240 If found = False Then 'Wenn ein Control im Formular nich existiert, den Datensatz aus tblBeschriftungen löschen
250 strSQL = _
"DELETE FROM " & cBeschriftungstabelle & _
" WHERE " & cBeschriftungstabelleSteuerelement & " = '" & rst.Fields(cBeschriftungstabelleSteuerelement).Value & _
"' AND " & cBeschriftungstabelleFormName & " ='" & frm.Name & _
"' AND " & cBeschriftungstabelleSprachID & " =" & intSprachID & ";"
260 CurrentDbC.Execute strSQL, dbFailOnError
270 End If
280 rst.MoveNext
290 Loop
300 rst.Requery 'Falls was in tblBeschriftungen gelöscht wurde sollte der Recordset ja was davon wissen
310 If rst.BOF And rst.EOF Then
320 Else
330 rst.MoveFirst
340 End If
350 Do 'Formularbeschriftung
360 If Not rst.EOF Then
370 If rst.Fields(cBeschriftungstabelleSteuerelement).Value = frm.Name And rst.Fields(cBeschriftungstabelleTyp).Value = acForm Then
380 Exit Do
390 End If
400 End If
410 If rst.EOF Then
420 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & frm.Name & "','" & frm.Name & "','" & frm.Caption & "', " & acForm & ", " & acForm & ");", dbFailOnError
430 Exit Do
440 End If
450 rst.MoveNext
460 Loop
470 For Each AktCtrl In frm.Controls 'Alle Controls im Formular durchgehen...
480 If rst.BOF And rst.EOF Then
490 Else
500 rst.MoveFirst
510 End If
520 Do
530 If Not rst.EOF Then
540 If AktCtrl.Name = rst.Fields(cBeschriftungstabelleSteuerelement).Value Then
550 Exit Do 'Control gefunden, also auf zum nächsten Control
560 End If
570 End If
580 If rst.EOF Then 'Wenn das Control nicht in tblBeschriftungen ist, dann einfügen MsgBox
590 Select Case AktCtrl.ControlType
Case acLabel
600 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(frm.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.Caption, dtmemo) & "','" & fncOptimizeStringForSQL(AktCtrl.ControlTipText) & "', " & AktCtrl.ControlType & ", " & acForm & ");", dbFailOnError
610 Case acListBox, acComboBox, acTextBox, acOptionGroup 'Todo: Hier fehlt noch Datenblattbeschriftung?
620 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleGueltigkeit & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(frm.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.ControlTipText) & "','" & fncOptimizeStringForSQL(AktCtrl.ValidationText) & "','" & fncOptimizeStringForSQL(AktCtrl.StatusBarText) & "', " & AktCtrl.ControlType & ", " & acForm & ");", dbFailOnError
630 Case acTabCtl, acSubform
640 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(frm.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.StatusBarText) & "', " & AktCtrl.ControlType & ", " & acForm & ");", dbFailOnError
650 Case acPage, acToggleButton, acCommandButton
660 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(frm.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.Caption, dtmemo) & "','" & fncOptimizeStringForSQL(AktCtrl.ControlTipText) & "','" & fncOptimizeStringForSQL(AktCtrl.StatusBarText) & "', " & AktCtrl.ControlType & ", " & acForm & ");", dbFailOnError
670 Case acOptionButton
680 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(frm.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.ControlTipText) & "','" & fncOptimizeStringForSQL(AktCtrl.StatusBarText) & "', " & AktCtrl.ControlType & ", " & acForm & ");", dbFailOnError
690 Case acCheckBox
700 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleGueltigkeit & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(frm.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.ValidationText) & "','" & fncOptimizeStringForSQL(AktCtrl.ControlTipText) & "','" & fncOptimizeStringForSQL(AktCtrl.StatusBarText) & "', " & AktCtrl.ControlType & ", " & acForm & ");", dbFailOnError
710 Case Else
720 End Select
730 Exit Do
740 End If
750 rst.MoveNext
760 Loop
770 Next AktCtrl
780 rsid.MoveNext
790 Loop
800 DoCmd.Close acForm, allfrm.Name, acSaveYes
810 Next allfrm
820 ggfncFormControlsEinlesen = True

Ausgang:
830 On Error Resume Next
840 rst.Close
850 Set rst = Nothing
860 rsid.Close
870 Set rsid = Nothing
880 frm.Close
890 Set frm = Nothing
900 allfrm.Close
910 Set allfrm = Nothing
920 Exit Function

ggfncFormControlsEinlesen_Error:
930 Select Case Err.Number
Case 0
940 Resume Ausgang
950 Case 3078
960 VBA.MsgBox "Die nötigen Tabellen sind noch nicht vorhanden, bitte erst erzeugen lassen!", vbCritical, "Error"
970 ggfncFormControlsEinlesen = False
980 Resume Ausgang
990 Case Else
1000 Call fncErrorHandler("mdlSprache", "ggfncFormControlsEinlesen")
1010 ggfncFormControlsEinlesen = False
1020 Resume Ausgang
1030 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : ggfncReportControlsEinlesen
' Autor : Günter Gerold
' Datum : 08.11.2008
' Text :
'---------------------------------------------------------------------------------------

Public Function ggfncReportControlsEinlesen() As Boolean

Dim AktCtrl As Control
Dim rst As DAO.Recordset
Dim rsid As DAO.Recordset
Dim strSQL As String
Dim found As Boolean
Dim rpt As Object
Dim allRpt As Object
Dim intSprachID As Integer

10 On Error GoTo ggfncReportControlsEinlesen_Error
20 If fncIsProtected = True Then Exit Function
30 Set rsid = CurrentDbC.OpenRecordset(cSpracheTabelle, dbOpenSnapshot)
40 For Each allRpt In Application.CurrentProject.AllReports 'Alle Formularnamen holen
50 DoCmd.OpenReport allRpt.Name, acDesign 'Alle Formulare nacheinander im Entwurfsmodus öffnen
60 Set rpt = Reports(allRpt.Name)
70 rsid.MoveFirst
80 Do While Not rsid.EOF
90 intSprachID = rsid.Fields(cSpracheTabelleID).Value

100 strSQL = _
"SELECT " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & _
" FROM " & cBeschriftungstabelle & _
" WHERE " & cBeschriftungstabelleFormName & "='" _
& rpt.Name & "' AND " & cBeschriftungstabelleSprachID & "=" & intSprachID & " AND " & cBeschriftungstabelleObjektTyp & " = " & acReport & ";"

110 Set rst = CurrentDbC.OpenRecordset(strSQL, dbOpenDynaset) 'Recordset auf eine Abfrage, die nur Datensätze des aktuellen Formulars und der aktuellen Sprache enthält
120 Do While Not rst.EOF 'Die Abfrage durchklappern und schauen, ob die Controls tatsächlich existieren
130 found = False
140 If rst.Fields(cBeschriftungstabelleSteuerelement).Value = rpt.Name And rst.Fields(cBeschriftungstabelleTyp).Value = acReport Then
150 found = True
160 Else
170 For Each AktCtrl In rpt.Controls
180 If rst.Fields(cBeschriftungstabelleSteuerelement).Value = AktCtrl.Name And rst.Fields(cBeschriftungstabelleTyp).Value <> acReport Then
190 found = True
200 Exit For
210 End If
220 Next
230 End If
240 If found = False Then 'Wenn ein Control im Formular nich existiert, den Datensatz aus tblBeschriftungen löschen
250 strSQL = _
"DELETE FROM " & cBeschriftungstabelle & _
" WHERE " & cBeschriftungstabelleSteuerelement & " = '" & rst.Fields(cBeschriftungstabelleSteuerelement).Value & _
"' AND " & cBeschriftungstabelleFormName & " ='" & rpt.Name & _
"' AND " & cBeschriftungstabelleSprachID & " =" & intSprachID & ";"
260 CurrentDbC.Execute strSQL, dbFailOnError
270 End If
280 rst.MoveNext
290 Loop
300 rst.Requery 'Falls was in tblBeschriftungen gelöscht wurde sollte der Recordset ja was davon wissen
310 If rst.BOF And rst.EOF Then
320 Else
330 rst.MoveFirst
340 End If
350 Do 'Formularbeschriftung
360 If Not rst.EOF Then
370 If rst.Fields(cBeschriftungstabelleSteuerelement).Value = rpt.Name And rst.Fields(cBeschriftungstabelleTyp).Value = acReport Then
380 Exit Do
390 End If
400 End If
410 If rst.EOF Then
420 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(rpt.Name) & "','" & fncOptimizeStringForSQL(rpt.Name) & "','" & fncOptimizeStringForSQL(rpt.Caption, dtmemo) & "', " & acReport & ", " & acReport & ");", dbFailOnError
430 Exit Do
440 End If
450 rst.MoveNext
460 Loop
470 For Each AktCtrl In rpt.Controls 'Alle Controls im Formular durchgehen...
480 If rst.BOF And rst.EOF Then
490 Else
500 rst.MoveFirst
510 End If
520 Do
530 If Not rst.EOF Then
540 If AktCtrl.Name = rst.Fields(cBeschriftungstabelleSteuerelement).Value Then
550 Exit Do 'Control gefunden, also auf zum nächsten Control
560 End If
570 End If
580 If rst.EOF Then 'Wenn das Control nicht in tblBeschriftungen ist, dann einfügen MsgBox
590 Select Case AktCtrl.ControlType
Case acLabel
600 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & rpt.Name & "','" & fncOptimizeStringForSQL(AktCtrl.Caption, dtmemo) & "', " & AktCtrl.ControlType & ", " & acReport & ");", dbFailOnError
610 Case acListBox, acComboBox, acTextBox, acOptionGroup 'Todo: Hier fehlt noch Datenblattbeschriftung?
620 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(rpt.Name) & "', " & AktCtrl.ControlType & ", " & acReport & ");", dbFailOnError
630 Case acTabCtl ', acSubreport
640 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(rpt.Name) & ", " & AktCtrl.ControlType & ", " & acReport & ");", dbFailOnError
650 Case acPage, acToggleButton, acCommandButton
660 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(rpt.Name) & "','" & fncOptimizeStringForSQL(AktCtrl.Caption, dtmemo) & "', " & AktCtrl.ControlType & ", " & acReport & ");", dbFailOnError
670 Case acOptionButton
680 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(rpt.Name) & "', " & AktCtrl.ControlType & ", " & acReport & ");", dbFailOnError
690 Case acCheckBox
700 CurrentDbC.Execute "INSERT INTO " & cBeschriftungstabelle & "(" & _
cBeschriftungstabelleSprachID & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleTyp & ", " & _
cBeschriftungstabelleObjektTyp & ") " & _
"VALUES(" & intSprachID & ",'" & fncOptimizeStringForSQL(AktCtrl.Name) & "','" & fncOptimizeStringForSQL(rpt.Name) & "', " & AktCtrl.ControlType & ", " & acReport & ");", dbFailOnError
710 Case Else
720 End Select
730 Exit Do
740 End If
750 rst.MoveNext
760 Loop
770 Next AktCtrl
780 rsid.MoveNext
790 Loop
800 DoCmd.Close acReport, allRpt.Name, acSaveYes
810 Next allRpt
820 ggfncReportControlsEinlesen = True

Ausgang:
830 On Error Resume Next
840 rst.Close
850 Set rst = Nothing
860 rsid.Close
870 Set rsid = Nothing
880 rpt.Close
890 Set rpt = Nothing
900 allRpt.Close
910 Set allRpt = Nothing
920 Exit Function

ggfncReportControlsEinlesen_Error:
930 Select Case Err.Number
Case 0
940 Resume Ausgang
950 Case 3078
960 VBA.MsgBox "Die nötigen Tabellen sind noch nicht vorhanden, bitte erst erzeugen lassen!", vbCritical, "Error"
970 ggfncReportControlsEinlesen = False
980 Resume Ausgang
990 Case Else

1000 Call fncErrorHandler("mdlSprache", "ggfncReportControlsEinlesen")
1010 ggfncReportControlsEinlesen = False
1020 Resume Ausgang
1030 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncIsFunctionPresent
' Autor : Günter Gerold
' Datum : 07.11.2008
' Text :
'---------------------------------------------------------------------------------------

Private Function fncIsFunctionPresent(ByRef modcode As vbide.CodeModule, ByVal strText As String) As Boolean
10 On Error GoTo fncIsFunctionPresent_Error

20 If modcode.ProcStartLine(strText, vbext_pk_Proc) <> 0 Then
30 fncIsFunctionPresent = True
40 End If

Ausgang:
50 On Error Resume Next
60 Exit Function

fncIsFunctionPresent_Error:
70 Select Case Err.Number
Case 0
80 Resume Ausgang
90 Case 35
100 fncIsFunctionPresent = False
110 Resume Ausgang
120 Case Else
130 Call fncErrorHandler("mdlSprache", "fncIsFunctionPresent")
140 Resume Ausgang
150 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncFindMsgBoxes
' Autor : Günter Gerold
' Datum : 25.10.2008
' Text : liefert die Anzahl der Boxen zurück
'---------------------------------------------------------------------------------------

Public Function fncFindMsgBoxes(ByVal bolReplaceBox As Boolean) As Boolean

Dim i As Long
Dim k As Long
Dim intStartPos As Integer
Dim intEndPos As Integer
Dim strText As String
Dim strDanach As String
Dim strVor As String
Dim strFinde1 As String
Dim strPrompt As String
Dim lngType As String
Dim strTitle As String
Dim strHelpFile As String
Dim lngContext As String
Dim lngID As Long
Dim lngBoxID As Long
Dim StartLine As Long
Dim EndLine As Long
Dim StartLineBuffer As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim strPH As String
Dim strArray As String
Dim vbComp As vbide.VBComponent
Dim modcode As vbide.CodeModule
Dim lngStartNeu As Long
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim rsu As DAO.Recordset
Dim boldirty As Boolean

10 On Error GoTo fncFindMsgBoxes_Error

20 strFinde1 = "MsgBox"
30 If fncIsProtected = True Then Exit Function
40 CurrentDbC.Execute "UPDATE " & cBoxIDs & " SET " & cBoxIDsCheck & " = False ;" 'Alle Boxen in der Tabelle werden als nicht kontrolliert gesetzt
50 For Each vbComp In Application.VBE.VBProjects(getProjectNumber).VBComponents
60 Select Case vbComp.Name
Case "mdlSprache", "mdlggMehrsprachigkeit"

70 Case Else
80 Set modcode = vbComp.CodeModule
90 If fncIsFunctionPresent(modcode, strFinde1) = True Then
100 VBA.MsgBox "Es ist bereits eine andere Ersatzfunktion für " & strFinde1 & " vorhanden, die neue Funktion wird nicht geschrieben!", vbCritical, "Error"
110 Exit Function
120 End If
130 StartLine = 0
140 i = 1 'mit i wird festgelegt die wievielte MsgBox in der Zeile gesucht werden soll. Es könnten ja mehrere Boxen durch : getrennt in einer Zeile stehen
'dann wird die Zeile solange gescannt, bis der Parser false zurückgibt
150 EndLine = modcode.CountOfLines
160 Do While modcode.Find(strFinde1, StartLine, StartColumn, EndLine, EndColumn) = True 'Den ganzen Code duchsuchen
170 If StartLineBuffer <> StartLine Then i = 1
180 strText = MachGanzeZeile(vbComp, StartLine, lngStartNeu) 'Die Zeile umbruchbereinigt in den Quellcode zurückgeschrieben. Anders ist das ersetzten nacher zu kniffelig
190 If lngStartNeu > 0 Then 'Nur wenn Umbrüche beseitigt wurden, die neu erstellte Zeile nochmal von Anfang an scannen
200 StartColumn = 1
210 EndColumn = 255
220 StartLine = lngStartNeu
230 EndLine = modcode.CountOfLines
240 modcode.Find strFinde1, StartLine, StartColumn, EndLine, EndColumn 'Nochmal Position feststellen, jetzt umbruchbereinigt
250 End If
'Es können mehrere Befehle in einer Zeile stehen, wenn sie durch Doppelpunkt getrennt sind. Deshalb muß die gleiche CodeZeile ev. mehrmals durchsucht werden
260 If Parser(strText, i, strFinde1, intStartPos, intEndPos) = True Then
'Jetzt wird anhand der Kommas der Inhalt der MsgBox zerlegt.
270 fncGetMsgBoxParts Mid$(strText, intStartPos, intEndPos - intStartPos), strPrompt, lngType, strTitle, strHelpFile, lngContext, lngID
'Hier ist jetzt alles zerlegt. Wenn lngID = 0 dann ists ne alte Msgbox die ersetzt werden muss.
'intStartpos und intEndpos sind Anfang und Ende des MsgBox Inhalts.
280 If lngID < 1 Then
290 Set rs = CurrentDbC.OpenRecordset(cBoxTabelle, dbOpenDynaset, dbSeeChanges) 'Die Tabelle für die Übersetzungen
300 Set rsu = CurrentDbC.OpenRecordset(cBoxIDs, dbOpenDynaset, dbSeeChanges) 'Die Tabelle der MsgBoxen
310 Set rst = CurrentDbC.OpenRecordset(cSpracheTabelle, dbOpenSnapshot, dbFailOnError) 'Die Sprachen
320 rsu.AddNew 'MsgBox anlegen
330 rsu.Fields(cBoxIDsText).Value = vbComp.Name & ", " & StartLine
340 rsu.Update
350 rsu.Move 0, rsu.LastModified
360 lngBoxID = rsu.Fields(cBoxIDsID).Value 'Die neue eindeutige ID der MsgBox aus dem Autowertfeld der Tabelle
370 rsu.Edit
380 rsu.Fields(cBoxIDsCheck).Value = True 'Der Tabelleneintrag gilt als kontrolliert
390 rsu.Fields(cBoxIDsType).Value = 1 'MsgBoxen haben Typ 1
400 rsu.Update
410 strPH = ""
420 strArray = " "
'Erst muß noch in Prompt und Title nach Variablen gesucht werden. Diese werden durch Platzhalter ersetzt
430 k = 1
440 Do While fncSetPlatzhalter(strPrompt, "%PH" & k & "%", strPH) = True
450 strArray = strArray & " " & strPH & ","
460 k = k + 1
470 Loop
'k wird nicht auf 0 gesetzt, damit der Parameterzähler durchzählt
480 Do While fncSetPlatzhalter(strTitle, "%PH" & k & "%", strPH) = True
490 strArray = strArray & " " & strPH & ","
500 k = k + 1
510 Loop
520 If k = 2 Then 'nur 1 Variable
530 strArray = ", " & Left$(strArray, Len(strArray) - 1) 'Das letzte Komma wird gelöscht
540 ElseIf k > 2 Then 'wenn mehrere Variablen gefunden wurden
550 strArray = Left$(strArray, Len(strArray) - 1) 'Das letzte Komma wird gelöscht
560 strArray = ", Array(" & strArray & ") " 'Das Ganze in Array() verpacken
570 End If
580 If bolReplaceBox = True Then
'jetzt wird die originale MsgBox ersetzt!!!!!!!!!!!!!!!
590 strVor = Left$(strText, intStartPos - 1) 'Die Zeile vor dem MsgBox Inhalt
600 strDanach = Right$(strText, Len(strText) - intEndPos + 1) 'Die Zeile nach dem MsgBox Inhalt
610 strText = strVor & strPrompt & ", " & lngType & ", " & strTitle & ", " & strHelpFile & ", " & lngContext & ", " & lngBoxID & strArray & strDanach & " 'Eingefügt vom Addin ggMehrsprachigkeit"
620 modcode.ReplaceLine StartLine, strText 'Todo jetzt wirds ernst
630 boldirty = True
640 strPrompt = fncMakeString(strPrompt)
650 strTitle = fncMakeString(strTitle)
660 Do Until rst.EOF 'Je Sprache die gleiche Box anlegen
670 rs.AddNew
680 rs.Fields(cBoxTabellePrompt).Value = strPrompt
690 rs.Fields(cBoxTabelleTitle).Value = strTitle
700 rs.Fields(cBoxTabelleHelpFile).Value = strHelpFile
710 rs.Fields(cBoxTabelleLanguage).Value = rst.Fields(cSpracheTabelleID).Value
720 rs.Fields(cBoxTabelleBoxID).Value = lngBoxID
730 rs.Update 'aktualisiert die Tabelle
'rs.Move 0, rs.LastModified
'lngID = rs.Fields(cMsgBoxTabelleID).Value
740 rst.MoveNext
750 Loop
760 rs.Close
770 rst.Close
780 rsu.Close
790 End If
800 Else
'Es wird kontrolliert, ob die ID der MsgBox in der Tabelle existiert. Falls ja, wird sie als kontrolliert markiert.
810 Set rsu = CurrentDbC.OpenRecordset("SELECT " & cBoxIDsID & ", " & cBoxIDsCheck & " FROM " & cBoxIDs & " WHERE " & cBoxIDsID & " = " & lngID, dbOpenDynaset, dbFailOnError) 'Die Tabelle der MsgBoxen
820 If rsu.EOF Then 'Box existiert nicht in der Tabelle
830 VBA.MsgBox "die MsgBox mit der ID " & lngID & " existiert nicht in der Tabelle, bitte prüfen!", vbCritical, "Fehler in einer MsgBox!"
840 Else
850 rsu.Edit
860 rsu.Fields(cBoxIDsCheck).Value = True 'Der Tabelleneintrag gilt als kontrolliert
870 rsu.Update
880 rsu.Close
890 End If
900 End If
910 End If
920 i = i + 1
930 StartColumn = EndColumn
940 StartLineBuffer = StartLine
950 EndLine = modcode.CountOfLines
960 EndColumn = 255
970 Loop
980 End Select
990 If boldirty = True Then
1000 Select Case vbComp.Type
Case 1, 2
1010 DoCmd.Close acModule, vbComp.Name, acSaveYes
1020 Case 100
1030 If Left$(vbComp.Name, 4) = "Form" Then

1040 DoCmd.Save acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5)
1050 DoCmd.Close acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5), acSaveYes

1060 ElseIf Left$(vbComp.Name, 6) = "Report" Then

1070 DoCmd.Save acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7)
1080 DoCmd.Close acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7), acSaveYes

1090 Else
1100 VBA.MsgBox "test"
1110 End If
1120 Case Else
1130 End Select
1140 boldirty = False
1150 End If
1160 Next
1170 CurrentDbC.Execute "DELETE * FROM " & cBoxIDs & " WHERE " & cBoxIDsCheck & " = False AND " & cBoxIDsType & " = 1;", dbFailOnError 'Alle nicht im Code gefundenen Boxen werden aus der Tabelle cMsgBoxIDs gelöscht. Durch die Löschweitergabe auch in der cMsgBoxTexte
'Prüfen, ob für jede Box auch eine Zeile für jede Sprache existiert (es könnte ja eine neue Sprache dazugekommen oder sein)
1180 Set rs = CurrentDbC.OpenRecordset("SELECT x.SprachID , x.BoxID FROM ( Select S.ID as SprachID, B.ID as BoxID FROM " & cSpracheTabelle & " S, " & cBoxIDs & " B ) AS X Left Join " & cBoxTabelle & " i ON (I.BoxID = X.BoxID AND I.Sprache = X.SprachID) where I.ID IS NULL;")
1190 Set rst = CurrentDbC.OpenRecordset(cBoxTabelle, dbOpenDynaset, dbFailOnError)
1200 Do Until rs.EOF
1210 rst.AddNew
1220 rst.Fields(cBoxTabelleBoxID).Value = rs.Fields("MsgBoxID").Value
1230 rst.Fields(cBoxTabelleLanguage).Value = rs.Fields("sprachID")
1240 rst.Fields(cBoxTabellePrompt).Value = "####Text einfügen####"
1250 rst.Update
1260 rs.MoveNext
1270 Loop
1280 fncFindMsgBoxes = True

Ausgang:
1290 On Error Resume Next
1300 rs.Close
1310 rst.Close
1320 rsu.Close
1330 Set rs = Nothing
1340 Set rst = Nothing
1350 Set rsu = Nothing
1360 Set modcode = Nothing
1370 Set vbComp = Nothing
1380 Exit Function

fncFindMsgBoxes_Error:
1390 Select Case Err.Number
Case 0
1400 Resume Ausgang
1410 Case 3078
1420 VBA.MsgBox "Die nötigen Tabellen sind noch nicht vorhanden, bitte erst erzeugen lassen!", vbCritical, "Error"
1430 Resume Ausgang
1440 Case Else
1450 Call fncErrorHandler("mdlSprache", "fncFindMsgBoxes")
1460 Resume Ausgang
1470 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncFindInputBoxes
' Autor : Günter Gerold
' Datum : 12.11.2008
' Text :
'---------------------------------------------------------------------------------------

Public Function fncFindInputBoxes(ByVal bolReplaceBox As Boolean) As Boolean

Dim i As Long
Dim k As Long
Dim intStartPos As Integer
Dim intEndPos As Integer
Dim strText As String
Dim strDanach As String
Dim strVor As String
Dim strFinde1 As String
Dim strPrompt As String
Dim strTitle As String
Dim strDefault As String
Dim lngXPos As Long
Dim lngYPos As Long
Dim strHelpFile As String
Dim lngContext As String
Dim lngID As Long
Dim lngBoxID As Long
Dim StartLine As Long
Dim EndLine As Long
Dim StartLineBuffer As Long
Dim StartColumn As Long
Dim EndColumn As Long
Dim strPH As String
Dim strArray As String
Dim vbComp As vbide.VBComponent
Dim modcode As vbide.CodeModule
Dim lngStartNeu As Long
Dim rs As DAO.Recordset
Dim rst As DAO.Recordset
Dim rsu As DAO.Recordset
Dim boldirty As Boolean

10 On Error GoTo fncFindInputBoxes_Error

20 strFinde1 = "InputBox"
30 If fncIsProtected = True Then Exit Function
40 CurrentDbC.Execute "UPDATE " & cBoxIDs & " SET " & cBoxIDsCheck & " = False ;" 'Alle Boxen in der Tabelle werden als nicht kontrolliert gesetzt
50 For Each vbComp In Application.VBE.VBProjects(getProjectNumber).VBComponents
60 Select Case vbComp.Name
Case "mdlSprache", "mdlggMehrsprachigkeit"

70 Case Else
80 Set modcode = vbComp.CodeModule
90 If fncIsFunctionPresent(modcode, strFinde1) = True Then
100 VBA.MsgBox "Es ist bereits eine andere Ersatzfunktion für " & strFinde1 & " vorhanden, die neue Funktion wird nicht geschrieben!", vbCritical, "Error"
110 Exit Function
120 End If
130 StartLine = 0
140 i = 1 'mit i wird festgelegt die wievielte InputBox in der Zeile gesucht werden soll. Es könnten ja mehrere Boxen durch : getrennt in einer Zeile stehen
'dann wird die Zeile solange gescannt, bis der Parser false zurückgibt
150 EndLine = modcode.CountOfLines
160 Do While modcode.Find(strFinde1, StartLine, StartColumn, EndLine, EndColumn) = True 'Den ganzen Code duchsuchen
170 If StartLineBuffer <> StartLine Then i = 1
180 strText = MachGanzeZeile(vbComp, StartLine, lngStartNeu) 'Die Zeile umbruchbereinigt in den Quellcode zurückgeschrieben. Anders ist das ersetzten nacher zu kniffelig
190 If lngStartNeu > 0 Then 'Nur wenn Umbrüche beseitigt wurden, die neu erstellte Zeile nochmal von Anfang an scannen
200 StartColumn = 1
210 EndColumn = 255
220 StartLine = lngStartNeu
230 EndLine = modcode.CountOfLines
240 modcode.Find strFinde1, StartLine, StartColumn, EndLine, EndColumn 'Nochmal Position feststellen, jetzt umbruchbereinigt
250 End If
'Es können mehrere Befehle in einer Zeile stehen, wenn sie durch Doppelpunkt getrennt sind. Deshalb muß die gleiche CodeZeile ev. mehrmals durchsucht werden
260 If Parser(strText, i, strFinde1, intStartPos, intEndPos) = True Then
'Jetzt wird anhand der Kommas der Inhalt der InputBox zerlegt.
270 fncGetInputBoxParts Mid$(strText, intStartPos, intEndPos - intStartPos), strPrompt, strTitle, strDefault, lngXPos, lngYPos, strHelpFile, lngContext, lngID
'Hier ist jetzt alles zerlegt. Wenn lngID = 0 dann ists ne alte Inputbox die ersetzt werden muss.
'intStartpos und intEndpos sind Anfang und Ende des InputBox Inhalts.
280 If lngID < 1 Then
290 Set rs = CurrentDbC.OpenRecordset(cBoxTabelle, dbOpenDynaset, dbSeeChanges) 'Die Tabelle für die Übersetzungen
300 Set rsu = CurrentDbC.OpenRecordset(cBoxIDs, dbOpenDynaset, dbSeeChanges) 'Die Tabelle der MsgBoxen
310 Set rst = CurrentDbC.OpenRecordset(cSpracheTabelle, dbOpenSnapshot, dbFailOnError) 'Die Sprachen
320 rsu.AddNew 'MsgBox anlegen
330 rsu.Fields(cBoxIDsText).Value = vbComp.Name & ", " & StartLine
340 rsu.Update
350 rsu.Move 0, rsu.LastModified
360 lngBoxID = rsu.Fields(cBoxIDsID).Value 'Die neue eindeutige ID der MsgBox aus dem Autowertfeld der Tabelle
370 rsu.Edit
380 rsu.Fields(cBoxIDsCheck).Value = True 'Der Tabelleneintrag gilt als kontrolliert
390 rsu.Fields(cBoxIDsType).Value = 2 'Inputboxen haben Typ 2
400 rsu.Update
410 strPH = ""
420 strArray = " "
'Erst muß noch in Prompt, Title und Default nach Variablen gesucht werden. Diese werden durch Platzhalter ersetzt
430 k = 1
440 Do While fncSetPlatzhalter(strPrompt, "%PH" & k & "%", strPH) = True
450 strArray = strArray & " " & strPH & ","
460 k = k + 1
470 Loop
'k wird nicht auf 0 gesetzt, damit der Parameterzähler durchzählt
480 Do While fncSetPlatzhalter(strTitle, "%PH" & k & "%", strPH) = True
490 strArray = strArray & " " & strPH & ","
500 k = k + 1
510 Loop
520 Do While fncSetPlatzhalter(strDefault, "%PH" & k & "%", strPH) = True
530 strArray = strArray & " " & strPH & ","
540 k = k + 1
550 Loop
560 If k = 2 Then 'nur 1 Variable
570 strArray = ", " & Left$(strArray, Len(strArray) - 1) 'Das letzte Komma wird gelöscht
580 ElseIf k > 2 Then 'wenn mehrere Variablen gefunden wurden
590 strArray = Left$(strArray, Len(strArray) - 1) 'Das letzte Komma wird gelöscht
600 strArray = ", Array(" & strArray & ") " 'Das Ganze in Array() verpacken
610 End If
620 If bolReplaceBox = True Then
'jetzt wird die originale InputBox ersetzt!!!!!!!!!!!!!!!
630 strVor = Left$(strText, intStartPos - 1) 'Die Zeile vor dem InputBox Inhalt
640 strDanach = Right$(strText, Len(strText) - intEndPos + 1) 'Die Zeile nach dem MsgBox Inhalt
650 strText = strVor & strPrompt & ", " & strTitle & ", " & strDefault & ", " & lngXPos & ", " & lngYPos & ", " & strHelpFile & ", " & lngContext & ", " & lngBoxID & strArray & strDanach & " 'Eingefügt vom Addin ggMehrsprachigkeit"
660 modcode.ReplaceLine StartLine, strText 'Todo jetzt wirds ernst
670 boldirty = True
680 strPrompt = fncMakeString(strPrompt)
690 strTitle = fncMakeString(strTitle)
700 strDefault = fncMakeString(strDefault)
710 Do Until rst.EOF 'Je Sprache die gleiche Box anlegen
720 rs.AddNew
730 rs.Fields(cBoxTabellePrompt).Value = strPrompt
740 rs.Fields(cBoxTabelleTitle).Value = strTitle
750 rs.Fields(cBoxTabelleDefault).Value = strDefault
760 rs.Fields(cBoxTabelleHelpFile).Value = strHelpFile
770 rs.Fields(cBoxTabelleLanguage).Value = rst.Fields(cSpracheTabelleID).Value
780 rs.Fields(cBoxTabelleBoxID).Value = lngBoxID
790 rs.Update 'aktualisiert die Tabelle
'rs.Move 0, rs.LastModified
'lngID = rs.Fields(cMsgBoxTabelleID).Value
800 rst.MoveNext
810 Loop
820 rs.Close
830 rst.Close
840 rsu.Close
850 End If
860 Else
'Es wird kontrolliert, ob die ID der MsgBox in der Tabelle existiert. Falls ja, wird sie als kontrolliert markiert.
870 Set rsu = CurrentDbC.OpenRecordset("SELECT " & cBoxIDsID & ", " & cBoxIDsCheck & " FROM " & cBoxIDs & " WHERE " & cBoxIDsID & " = " & lngID, dbOpenDynaset, dbFailOnError) 'Die Tabelle der MsgBoxen
880 If rsu.EOF Then 'Box existiert nicht in der Tabelle
890 VBA.MsgBox "die MsgBox mit der ID " & lngID & " existiert nicht in der Tabelle, bitte prüfen!", vbCritical, "Fehler in einer MsgBox!"
900 Else
910 rsu.Edit
920 rsu.Fields(cBoxIDsCheck).Value = True 'Der Tabelleneintrag gilt als kontrolliert
930 rsu.Update
940 rsu.Close
950 End If
960 End If
970 End If
980 i = i + 1
990 StartColumn = EndColumn
1000 StartLineBuffer = StartLine
1010 EndLine = modcode.CountOfLines
1020 EndColumn = 255
1030 Loop
1040 End Select
1050 If boldirty = True Then
1060 Select Case vbComp.Type
Case 1, 2
1070 DoCmd.Close acModule, vbComp.Name, acSaveYes
1080 Case 100
1090 If Left$(vbComp.Name, 4) = "Form" Then

1100 DoCmd.Save acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5)
1110 DoCmd.Close acForm, Right$(vbComp.Name, Len(vbComp.Name) - 5), acSaveYes

1120 ElseIf Left$(vbComp.Name, 6) = "Report" Then

1130 DoCmd.Save acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7)
1140 DoCmd.Close acReport, Right$(vbComp.Name, Len(vbComp.Name) - 7), acSaveYes

1150 Else
1160 VBA.MsgBox "test"
1170 End If
1180 Case Else
1190 End Select
1200 boldirty = False
1210 End If
1220 Next

1230 CurrentDbC.Execute "DELETE * FROM " & cBoxIDs & " WHERE " & cBoxIDsCheck & " = False AND " & cBoxIDsType & " = 2;", dbFailOnError 'Alle nicht im Code gefundenen Boxen werden aus der Tabelle cMsgBoxIDs gelöscht. Durch die Löschweitergabe auch in der cMsgBoxTexte
'Prüfen, ob für jede Box auch eine Zeile für jede Sprache existiert (es könnte ja eine neue Sprache dazugekommen oder sein)
1240 Set rs = CurrentDbC.OpenRecordset("SELECT x.SprachID , x.BoxID FROM ( Select S.ID as SprachID, B.ID as BoxID FROM " & cSpracheTabelle & " S, " & cBoxIDs & " B ) AS X Left Join " & cBoxTabelle & " i ON (I.BoxID = X.BoxID AND I.Sprache = X.SprachID) where I.ID IS NULL;")
1250 Set rst = CurrentDbC.OpenRecordset(cBoxTabelle, dbOpenDynaset, dbFailOnError)
1260 Do Until rs.EOF
1270 rst.AddNew
1280 rst.Fields(cBoxTabelleBoxID).Value = rs.Fields("MsgBoxID").Value
1290 rst.Fields(cBoxTabelleLanguage).Value = rs.Fields("sprachID")
1300 rst.Fields(cBoxTabellePrompt).Value = "####Text einfügen####"
1310 rst.Update
1320 rs.MoveNext
1330 Loop
1340 fncFindInputBoxes = True

Ausgang:
1350 On Error Resume Next
1360 rs.Close
1370 rst.Close
1380 rsu.Close
1390 Set rs = Nothing
1400 Set rst = Nothing
1410 Set rsu = Nothing
1420 Set modcode = Nothing
1430 Set vbComp = Nothing
1440 Exit Function

fncFindInputBoxes_Error:
1450 Select Case Err.Number
Case 0
1460 Resume Ausgang
1470 Case 3078
1480 VBA.MsgBox "Die nötigen Tabellen sind noch nicht vorhanden, bitte erst erzeugen lassen!", vbCritical, "Error"
1490 Resume Ausgang
1500 Case Else
1510 Call fncErrorHandler("mdlSprache", "fncFindInputBoxes")
1520 Resume Ausgang
1530 End Select

End Function
'---------------------------------------------------------------------------------------
' Prozedur : getProjectNumber
' Autor : Günter Gerold
' Datum : 30.10.2008
' Text : liefert die Nummer des aktuellen Projekts
'---------------------------------------------------------------------------------------

Private Function getProjectNumber() As Integer

Dim i As Integer

10 On Error GoTo getProjectNumber_Error

20 For i = 1 To CurrentProject.Application.VBE.VBProjects.Count
30 If CurrentDb.Name = Application.VBE.VBProjects(i).FileName Then 'kein DBC sonst klappts manchmal nicht!
40 getProjectNumber = i
50 Exit For
60 End If
70 Next

Ausgang:
80 On Error Resume Next
90 Exit Function

getProjectNumber_Error:
100 Select Case Err.Number
Case 0
110 Resume Ausgang
120 Case Else
130 Call fncErrorHandler("mdlSprache", "getProjectNumber")
140 Resume Ausgang
150 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncSetPlatzhalter
' Autor : Günter Gerold
' Datum : 11.10.2008
' Text : der String wird nach Variablen durchsucht. Wird eine gefunden, wird strPlatzhalter eingefügt
' und die Variable zurückgegeben.
' Dazu wird bei Kommentaren usw. der Startmarker weitergesetzt, bei Variablen der Stoppmarker
' Ist eine Variable zusammengebaut, wird der Platzhalter gesetzt und die Funktion verlassen
'---------------------------------------------------------------------------------------

Private Function fncSetPlatzhalter(ByRef strText As String, ByVal strPlatzhalter As String, ByRef strVariable As String) As Boolean

Dim strArray() As String
Dim intStart As Integer
Dim intStop As Integer
Dim i As Integer
Dim k As Integer
Dim intKlammerCounter As Integer

10 On Error GoTo fncSetPlatzhalter_Error

20 ReDim strArray(Len(strText))

30 For i = 1 To Len(strText)
40 strArray(i) = Mid$(strText, i, 1)
50 Next i
60 intStart = 1

70 For i = 1 To Len(strText)
80 Select Case strArray(i)
Case "("
90 If i - 2 < 0 Then
100 k = 2
110 Else
120 k = i
130 End If
140 If strArray(i - 1) <> " " And strArray(i - 1) <> "" Or strArray(i - 1) = " " And strArray(k - 2) = "&" Then 'Wenn vor der Klammer nix oder Leerzeichen ist, dann ists ne Funktion, die wird wie eine Variable behandelt
150 Do While i < Len(strText)
160 If strArray(i) = "(" Then
170 intKlammerCounter = intKlammerCounter + 1
180 ElseIf strArray(i) = ")" Then
190 intKlammerCounter = intKlammerCounter - 1
200 End If
210 i = i + 1
220 intStop = i
230 If intKlammerCounter = 0 Then Exit Do
240 Loop
250 Else
260 intStart = i
270 End If
280 Case ")"
'intStart = i
290 Case Chr$(34)
300 i = i + 1
310 Do While i < Len(strText)
320 If strArray(i) = Chr$(34) Then
330 intStart = i
340 Exit Do
350 End If
360 i = i + 1
370 Loop
380 Case "&"
390 If intStop >= intStart Then
400 Exit For
410 Else
420 intStart = i + 1
430 End If
440 Case " "

450 Case Else
460 intStop = i
470 End Select
480 Next i
490 If intStop < intStart Then
500 fncSetPlatzhalter = False
510 Exit Function
520 End If
530 strVariable = Mid$(strText, intStart, intStop + 1 - intStart)
540 If strVariable = "" Or strVariable = " " Then
550 fncSetPlatzhalter = False
560 Else
570 strText = Left$(strText, intStart - 1) & Chr$(34) & strPlatzhalter & Chr$(34) & Right$(strText, Len(strText) - intStop)
580 fncSetPlatzhalter = True
590 End If

Ausgang:
600 On Error Resume Next
610 Exit Function

fncSetPlatzhalter_Error:
620 Select Case Err.Number
Case 0
630 Resume Ausgang
640 Case Else
650 Call fncErrorHandler("mdlSprache", "fncSetPlatzhalter")
660 Resume Ausgang
670 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncMakeString
' Autor : Günter Gerold
' Datum : 13.10.2008
' Text : Entfernt die störenden Anführungszeichen
'---------------------------------------------------------------------------------------

Private Function fncMakeString(ByRef strText As String) As String

Dim strArray() As String
Dim i As Integer

10 On Error GoTo fncMakeString_Error

20 ReDim strArray(Len(strText))

30 For i = 1 To Len(strText)
40 strArray(i) = Mid$(strText, i, 1)
50 Next i

60 For i = 1 To Len(strText)
70 Select Case strArray(i)
Case Chr$(34)
80 i = i + 1
90 Do While i < Len(strText)
100 If strArray(i) = Chr$(34) Then
110 Exit Do
120 End If
130 fncMakeString = fncMakeString & strArray(i)
140 i = i + 1
150 Loop
160 Case Else
170 End Select
180 Next i

Ausgang:
190 On Error Resume Next
200 Exit Function

fncMakeString_Error:
210 Select Case Err.Number
Case 0
220 Resume Ausgang
230 Case Else
240 Call fncErrorHandler("mdlSprache", "fncMakeString")
250 Resume Ausgang
260 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : MachGanzeZeile
' Autor : Thomas Möller, abgeändert Günter Gerold
' Datum : 01.10.2008
' Text : Der Originalcode der Funktion GibGanzeZeile von Thomas gibts unter:
' http://www.team-moeller.de/access/tiptrick/vbide/gibganzezeile.html
' Zeilenumbrüche vor und hinter der aktuellen Zeile werden gesucht und alles
' zu einer Zeile zusammengefügt. Diese ersetzt dann das Original.
'---------------------------------------------------------------------------------------

Private Function MachGanzeZeile(Modul As vbide.VBComponent, ByVal lngStart As Long, ByRef lngStartZeileNeu As Long) As String

'Variablen deklarieren
Dim mdl As vbide.CodeModule
Dim strGanzZeile As String
Dim strZeile As String
Dim strSpace As String 'Der Abstand vor der ersten Zeile
Dim lngStartAb As Long
Dim lngStartAuf As Long
10 On Error GoTo MachGanzeZeile_Error

20 Set mdl = Modul.CodeModule

'Vorhergehende Zeilen
30 lngStartAuf = lngStart - 1
40 strZeile = Trim$(mdl.Lines(lngStartAuf, 1))
50 Do While Right$(strZeile, 1) = "_"
60 strGanzZeile = Left$(strZeile, Len(strZeile) - 1) & strGanzZeile
70 lngStartAuf = lngStartAuf - 1
80 strZeile = Trim$(mdl.Lines(lngStartAuf, 1))
90 Loop
'lngStartAuf steht eins vor der ersten Zeile
100 strSpace = Left$(mdl.Lines(lngStartAuf + 1, 1), Len(mdl.Lines(lngStartAuf + 1, 1)) - Len(LTrim$(mdl.Lines(lngStartAuf + 1, 1))))
'Folgende Zeilen
110 lngStartAb = lngStart
120 strZeile = Trim$(mdl.Lines(lngStartAb, 1))
130 Do While Right$(strZeile, 1) = "_"
140 strGanzZeile = strGanzZeile & Left$(strZeile, Len(strZeile) - 1)
150 lngStartAb = lngStartAb + 1
160 strZeile = Trim$(mdl.Lines(lngStartAb, 1))
170 Loop
'jetzt steht lngStartAb auf der letzten Zeile
180 strGanzZeile = strSpace & strGanzZeile & strZeile

190 If lngStartAuf = lngStart - 1 And lngStartAb = lngStart Then
'Keine Umbrüche, Zeile so lassen
200 lngStartZeileNeu = 0
210 Else
220 mdl.DeleteLines lngStartAuf + 1, lngStartAb - lngStartAuf
230 mdl.InsertLines lngStartAuf + 1, strGanzZeile & " 'Abgeändert vom Addin ggMehrsprachigkeit"
240 lngStartZeileNeu = lngStartAuf + 1 'neue Position der bereinigten Zeile
250 End If

260 MachGanzeZeile = strGanzZeile

Ausgang:
270 On Error Resume Next
'Set mdl = Nothing
280 Exit Function

MachGanzeZeile_Error:
290 Select Case Err.Number
Case 0
300 Resume Ausgang
310 Case Else
320 Call fncErrorHandler("mdlSprache", "MachGanzeZeile")
330 Resume Ausgang
340 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncGetMsgBoxParts
' Autor : Günter Gerold
' Datum : 25.10.2008
' Text : zerlegt die MsgBox in die einzelnen Argumente
'---------------------------------------------------------------------------------------

Private Function fncGetMsgBoxParts(ByVal strText As String, ByRef Prompt As String, ByRef ButtonType As String, ByRef Title As String, ByRef HelpFile As String, ByRef Context As String, ByRef ID As Long) As Boolean

Dim i As Integer
Dim lngCount As Long
Dim strArray() As String
Dim intButtonsStart As Integer
Dim intTitleStart As Integer
Dim intHelpfileStart As Integer
Dim intContextStart As Integer
Dim intIDStart As Integer
Dim intKlammerCounter As Integer

10 On Error GoTo fncGetMsgBoxParts_Error

20 strText = strText & "," 'Nur hiermit funktioniert das select case!

30 ReDim strArray(Len(strText))

40 Prompt = "" 'Da die Strings byref ankommen muß ich erstmal alle löschen.
50 ButtonType = ""
60 Title = ""
70 HelpFile = ""
80 Context = ""
90 ID = 0

100 For i = 1 To Len(strText)
110 strArray(i) = Mid$(strText, i, 1)
120 Next i

130 For i = 1 To Len(strText)
140 Select Case strArray(i)
Case "("
150 If strArray(i - 1) <> " " And strArray(i - 1) <> "" Then
160 Do While i < Len(strText)
170 If strArray(i) = "(" Then
180 intKlammerCounter = intKlammerCounter + 1
190 ElseIf strArray(i) = ")" Then
200 intKlammerCounter = intKlammerCounter - 1
210 End If
220 If intKlammerCounter = 0 Then Exit Do
230 i = i + 1
240 Loop
250 Else
260 intKlammerCounter = 0
270 End If
280 Case ","
290 lngCount = lngCount + 1
300 Select Case lngCount
Case 1
310 intButtonsStart = i + 1
320 Prompt = Left$(strText, i - 1)
330 Case 2
340 intTitleStart = i + 1
350 ButtonType = Mid$(strText, intButtonsStart, i - intButtonsStart)
360 Case 3
370 intHelpfileStart = i + 1
380 Title = Mid$(strText, intTitleStart, i - intTitleStart)
390 Case 4
400 intContextStart = i + 1
410 HelpFile = Mid$(strText, intHelpfileStart, i - intHelpfileStart)
420 Case 5
430 intIDStart = i + 1
440 Context = Mid$(strText, intContextStart, i - intContextStart)
450 Case 6
460 ID = Mid$(strText, intIDStart, i - intIDStart)
' Case 9
' ID = Val(Right(strtext, Len(strtext) - i))
470 Case Else
480 End Select
490 Case Chr$(34)
500 i = i + 1
510 Do While i < Len(strText)
520 If strArray(i) = Chr$(34) Then
530 Exit Do
540 End If
550 i = i + 1
560 Loop
570 Case Else
580 End Select
590 Next i
600 If strText = "" Then fncGetMsgBoxParts = False Else fncGetMsgBoxParts = True
Ausgang:
610 On Error Resume Next
620 Exit Function

fncGetMsgBoxParts_Error:
630 Select Case Err.Number
Case 0
640 Resume Ausgang
650 Case Else
660 Call fncErrorHandler("mdlSprache", "fncGetMsgBoxParts")
670 Resume Ausgang
680 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncGetInputBoxParts
' Autor : Günter Gerold
' Datum : 12.11.2008
' Text :
'---------------------------------------------------------------------------------------

Private Function fncGetInputBoxParts(ByVal strText As String, ByRef Prompt As String, ByRef Title As String, ByRef Default As String, ByRef XPos As Long, ByRef YPos As Long, ByRef HelpFile As String, ByRef Context As String, ByRef ID As Long) As Boolean

Dim i As Integer
Dim lngCount As Long
Dim strArray() As String
Dim intTitleStart As Integer
Dim intHelpfileStart As Integer
Dim intContextStart As Integer
Dim intIDStart As Integer
Dim intXPosStart As Integer
Dim intYPosStart As Integer
Dim intDefaultStart As Integer
Dim intKlammerCounter As Integer

10 On Error GoTo fncGetInputBoxParts_Error

20 strText = strText & "," 'Nur hiermit funktioniert das select case!

30 ReDim strArray(Len(strText))

40 Prompt = "" 'Da die Strings byref ankommen muß ich erstmal alle löschen.
50 Default = ""
60 Title = ""
70 HelpFile = ""
80 Context = ""
90 ID = 0
100 XPos = 0
110 YPos = 0

120 For i = 1 To Len(strText)
130 strArray(i) = Mid$(strText, i, 1)
140 Next i

150 For i = 1 To Len(strText)
160 Select Case strArray(i)
Case "("
170 If strArray(i - 1) <> " " And strArray(i - 1) <> "" Then
180 Do While i < Len(strText)
190 If strArray(i) = "(" Then
200 intKlammerCounter = intKlammerCounter + 1
210 ElseIf strArray(i) = ")" Then
220 intKlammerCounter = intKlammerCounter - 1
230 End If
240 If intKlammerCounter = 0 Then Exit Do
250 i = i + 1
260 Loop
270 Else
280 intKlammerCounter = 0
290 End If
300 Case ","
310 lngCount = lngCount + 1
320 Select Case lngCount
Case 1
330 intTitleStart = i + 1
340 Prompt = Left$(strText, i - 1)
350 Case 2
360 intDefaultStart = i + 1
370 Title = Mid$(strText, intTitleStart, i - intTitleStart)
380 Case 3
390 intXPosStart = i + 1
400 Default = Mid$(strText, intDefaultStart, i - intDefaultStart)
410 Case 4
420 intYPosStart = i + 1
430 XPos = Mid$(strText, intXPosStart, i - intXPosStart)
440 Case 5
450 intHelpfileStart = i + 1
460 YPos = Mid$(strText, intYPosStart, i - intYPosStart)
470 Case 6
480 intContextStart = i + 1
490 HelpFile = Mid$(strText, intHelpfileStart, i - intHelpfileStart)
500 Case 7
510 intIDStart = i + 1
520 Context = Mid$(strText, intContextStart, i - intContextStart)
530 Case 8
540 ID = Mid$(strText, intIDStart, i - intIDStart)
550 Case Else
560 End Select
570 Case Chr$(34)
580 i = i + 1
590 Do While i < Len(strText)
600 If strArray(i) = Chr$(34) Then
610 Exit Do
620 End If
630 i = i + 1
640 Loop
650 Case Else
660 End Select
670 Next i
680 If strText = "" Then fncGetInputBoxParts = False Else fncGetInputBoxParts = True
Ausgang:
690 On Error Resume Next
700 Exit Function

fncGetInputBoxParts_Error:
710 Select Case Err.Number
Case 0
720 Resume Ausgang
730 Case Else
740 Call fncErrorHandler("mdlSprache", "fncGetInputBoxParts")
750 Resume Ausgang
760 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : Parser
' Autor : Günter Gerold
' Datum : 30.09.2008
' Text : Der Parser sucht nach Doppelpunkten und zählt diese. Zeichen zwischen
' Anführungszeichen werden ignoriert. Bei Kommentaren wird abgebrochen. Ist der
' gewünschte Bereich zwischen den Doppelpunkten gefunden wird Start und Endpunkt gesetzt
' Ebenso werden Anfang und Ende des Strings ermittelt
'---------------------------------------------------------------------------------------

Private Function Parser(ByVal strText As String, ByVal lngTeilnummer As Long, ByVal strBefehl As String, ByRef startpos As Integer, ByRef endpos As Integer) As Boolean
Dim i As Integer
Dim intCount As Integer
Dim strArray() As String

10 On Error GoTo Parser_Error

20 ReDim strArray(Len(strText))
30 startpos = 1
40 endpos = Len(strText) + 1
50 intCount = 0
60 For i = 1 To Len(strText)
70 strArray(i) = Mid$(strText, i, 1)
80 Next i

90 For i = 1 To Len(strText)
100 Select Case strArray(i)
Case ":"
110 intCount = intCount + 1
120 If intCount = lngTeilnummer - 1 Then
130 startpos = i
140 ElseIf intCount = lngTeilnummer Then
150 endpos = i
160 Exit For
170 End If
180 Case "'"
190 intCount = intCount + 1
200 If intCount = lngTeilnummer Then
210 endpos = i
220 Else
230 endpos = startpos
240 End If
250 Exit For
260 Case "R"
270 If Len(strText) > i + 2 Then
280 If (strArray(i - 1) = " " Or strArray(i - 1) = "") And strArray(i + 1) = "e" And strArray(i + 2) = "m" And strArray(i + 3) = " " Then
290 intCount = intCount + 1
300 If intCount = lngTeilnummer Then
310 endpos = i
320 Else
330 endpos = startpos
340 End If
350 Exit For
360 End If
370 End If
380 Case Chr$(34)
390 i = i + 1
400 Do While i < Len(strText)
410 If strArray(i) = Chr$(34) Then
420 Exit Do
430 End If
440 i = i + 1
450 Loop
460 Case Else
470 End Select
480 Next i
'Hier steht zwischen Startpos und Endpos der String
490 intCount = 0
500 If Nz(InStr(startpos, strText, strBefehl)) < endpos Then 'Wenn in dem Zeilenabschnitt der gesuchten Funktion (MsgBox) vorkommt
510 If (strArray(Nz(InStr(startpos, strText, strBefehl)) - 1) = " " Or Nz(InStr(startpos, strText, strBefehl)) = 1) Then 'Wenn vor der Funktion nichts steht oder ein Leerzeichen kommt
520 If strArray(Nz(InStr(startpos, strText, strBefehl)) + Len(strBefehl)) = " " Then 'Wenn nach dem Funktionsnamen ein Leerzeichen kommt
530 startpos = Nz(InStr(startpos, strText, strBefehl)) + Len(strBefehl) + 1
540 If Mid$(strText, startpos, endpos - startpos) <> "" Then Parser = True 'Wenn auch Argumente folgen
550 ElseIf (strArray(Nz(InStr(startpos, strText, strBefehl)) + Len(strBefehl)) = "(") Then 'Wenn nach dem Funktionsnamen ein ( kommt
560 startpos = Nz(InStr(startpos, strText, strBefehl)) + Len(strBefehl) + 1
570 For i = startpos - 1 To Len(strText) 'Das Ende der Funktion suchen, Klammern zählen, die nicht in Kommentaren stehen
580 Select Case strArray(i)
Case "("
590 intCount = intCount + 1
600 Case ")"
610 intCount = intCount - 1
620 Case Chr$(34)
630 i = i + 1
640 Do While i < Len(strText)
650 If strArray(i) = Chr$(34) Then
660 Exit Do
670 End If
680 i = i + 1
690 Loop
700 Case Else
710 End Select
720 If intCount = 0 Then
730 endpos = i
740 Exit For
750 End If
760 Next i
770 If Mid$(strText, startpos, endpos - startpos) <> "" Then Parser = True
780 End If
790 End If
800 End If

Ausgang:
810 On Error Resume Next
820 Exit Function

Parser_Error:
830 Select Case Err.Number
Case 0
840 Resume Ausgang
850 Case Else
860 Call fncErrorHandler("mdlSprache", "Parser")
870 Resume Ausgang
880 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncCreateTables
' Autor : Günter Gerold
' Datum : 13.10.2008
' Text : 2 Tabellen werden angelegt um die Texte der Messageboxen aufzunehmen
'---------------------------------------------------------------------------------------

Public Function fncCreateTables() As Boolean
Dim strSQL As String
Dim rss As DAO.Recordset
10 On Error GoTo fncCreateTables_Error
20 If fncIsProtected = True Then Exit Function
30 strSQL = "CREATE TABLE " & cBoxIDs & " ( [" & cBoxIDsID & "] COUNTER PRIMARY KEY, [" & cBoxIDsText & "] TEXT(255), [" & cBoxIDsCheck & "] BIT, [" & cBoxIDsType & "] LONG);"
40 fncCreateDAOTable strSQL
50 strSQL = "CREATE TABLE " & cBoxTabelle & " ( [" & cBoxTabelleID & "] COUNTER PRIMARY KEY, [" & cBoxTabelleBoxID & "] LONG , [" & cBoxTabellePrompt & "] MEMO, [" & cBoxTabelleTitle & "] TEXT(255), [" & cBoxTabelleHelpFile & "] TEXT(255), [" & cBoxTabelleLanguage & "] LONG, [" & cBoxTabelleDefault & "] TEXT(255), CONSTRAINT FKID FOREIGN KEY (" & cBoxTabelleBoxID & ") REFERENCES " & cBoxIDs & " ON UPDATE CASCADE ON DELETE CASCADE);"
60 fncCreateADOTable strSQL 'Mit ADO !!!! sonst geht ON UPDATE CASCADE und ON DELETE CASCADE nicht !!!!
70 strSQL = "CREATE TABLE " & cSpracheTabelle & " ( [" & cSpracheTabelleID & "] COUNTER NOT NULL PRIMARY KEY, [" & cSpracheTabelleSprache & "] TEXT(255), [" & cSpracheTabelleActive & "] BIT);"
80 fncCreateDAOTable strSQL
90 Set rss = CurrentDbC.OpenRecordset(cSpracheTabelle, dbOpenDynaset)
100 If rss.BOF And rss.EOF Then
110 rss.AddNew
120 rss.Fields(cSpracheTabelleSprache) = "Deutsch"
130 rss.Fields(cSpracheTabelleActive) = True
140 rss.Update
150 rss.AddNew
160 rss.Fields(cSpracheTabelleSprache) = "English"
170 rss.Update
180 End If
190 lngLang = 1 'aktuelle Sprache setzen

200 strSQL = "CREATE TABLE " & cBeschriftungstabelle & " ( [" & cBeschriftungstabelleID & "] COUNTER NOT NULL PRIMARY KEY, [" & cBeschriftungstabelleSprachID & "] LONG, [" & cBeschriftungstabelleSteuerelement & "] TEXT(255), [" & cBeschriftungstabelleCaption & "] MEMO, [" & cBeschriftungstabelleTooltip & "] TEXT(255), [" & cBeschriftungstabelleStatus & "] TEXT(255), [" & cBeschriftungstabelleGueltigkeit & "] TEXT(255), [" & cBeschriftungstabelleFormName & "] TEXT(255), [" & cBeschriftungstabelleIgnore & "] BIT, [" & cBeschriftungstabelleTyp & "] LONG, " & cBeschriftungstabelleObjektTyp & " LONG );"

210 fncCreateDAOTable strSQL

220 fncCopyObjects "mdlggmehrsprachigkeit", acModule, "mdlggmehrsprachigkeit"
230 fncCopyObjects "ggfrmSprache", acForm, "ggfrmSpracheX"
240 fncCopyObjects "ggfrmSpracheDetails", acForm, "ggfrmSpracheDetails"
250 fncCopyObjects "ggfrmSpracheBoxen", acForm, "ggfrmSpracheBoxen"
260 fncCopyObjects "ggfrmSpracheRptDetails", acForm, "ggfrmSpracheRptDetails"
270 fncCopyObjects "ggfrmSpracheInputBoxen", acForm, "ggfrmSpracheInputBoxen"
280 fncCreateTables = True

Ausgang:
290 On Error Resume Next
300 rss.Close
310 Set rss = Nothing
320 Exit Function

fncCreateTables_Error:
330 Select Case Err.Number
Case 0
340 Resume Ausgang
350 Case Else
360 Call fncErrorHandler("mdlSprache", "fncCreateTables")
370 fncCreateTables = False
380 Resume Ausgang
390 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncCopyObjects
' Autor : Günter Gerold
' Datum : 07.11.2008
' Text : Es wird zuerst das Objekt gesucht,
' ist es noch nicht vorhanden wird es kopiert.
'---------------------------------------------------------------------------------------

Public Function fncCopyObjects(ByVal Zielname As String, ByVal ObjektTyp As AcObjectType, Quellname As String) As Boolean
Dim obj As AccessObject
Dim dbs As Object

10 On Error GoTo fncCopyObjects_Error
20 If fncIsProtected = True Then Exit Function
30 Set dbs = Application.CurrentProject
40 Select Case ObjektTyp
Case acForm
50 For Each obj In dbs.AllForms
60 If obj.Name = Zielname Then
70 Exit Function
80 End If
90 Next obj
100 Case acModule
110 For Each obj In dbs.AllModules
120 If obj.Name = Zielname Then
130 Exit Function
140 End If
150 Next obj
160 Case Else
170 End Select
180 DoCmd.CopyObject CurrentDbC.Name, Zielname, ObjektTyp, Quellname
Ausgang:
190 On Error Resume Next
200 Set obj = Nothing
210 Set dbs = Nothing
220 Exit Function

fncCopyObjects_Error:
230 Select Case Err.Number
Case 0
240 Resume Ausgang
250 Case Else
260 Call fncErrorHandler("mdlSprache", "fncCopyObjects")
270 Resume Ausgang
280 End Select

End Function
'---------------------------------------------------------------------------------------
' Prozedur : fncCreateDAOTable
' Autor : Günter Gerold
' Datum : 06.11.2008
' Text : Damit Fehler speziell für diesen Befehl besser bearbeitet werden können
'---------------------------------------------------------------------------------------

Private Function fncCreateDAOTable(ByVal strSQL As String) As Boolean
10 On Error GoTo fncCreateDAOTable_Error

20 CurrentDbC.Execute strSQL, dbFailOnError

Ausgang:
30 On Error Resume Next
40 Exit Function

fncCreateDAOTable_Error:
50 Select Case Err.Number
Case 0
60 Resume Ausgang
70 Case 3010, -2147217900
90 Resume Ausgang
100 Case Else
110 Call fncErrorHandler("mdlSprache", "fncCreateDAOTable")
120 Resume Ausgang
130 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncCreateADOTable
' Autor : Günter Gerold
' Datum : 06.11.2008
' Text : ADO, damit UPDATE CASCADE und DELETE CASCADE funktionieren
'---------------------------------------------------------------------------------------

Private Function fncCreateADOTable(ByVal strSQL As String) As Boolean
10 On Error GoTo fncCreateADOTable_Error

20 CurrentProject.Connection.Execute strSQL, dbFailOnError

Ausgang:
30 On Error Resume Next
40 Exit Function

fncCreateADOTable_Error:
50 Select Case Err.Number
Case 0
60 Resume Ausgang
70 Case 3010, -2147217900
90 Resume Ausgang
100 Case Else
110 Call fncErrorHandler("mdlSprache", "fncCreateADOTable")
120 Resume Ausgang
130 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncIsProtected
' Autor : Günter Gerold
' Datum : 06.11.2008
' Text : Ein passwortgeschützter Code kann natürlich (gottseidank) nicht ausgelesen und
' bearbeitet werden.
'---------------------------------------------------------------------------------------

Public Function fncIsProtected() As Boolean

10 On Error GoTo fncIsProtected_Error

20 If CBool(Application.VBE.VBProjects(getProjectNumber).Protection) = True Then
30 Call VBA.MsgBox("Das Projekt ist mit einem Passwort geschützt." _
& vbCrLf & "Bitte öffnen Sie erst den Editor und geben das Passwort ein!" _
& vbCrLf & "Der Vorgang wird Abgebrochen." _
, vbCritical, "Projekt geschützt!")

40 fncIsProtected = True
50 End If

Ausgang:
60 On Error Resume Next
70 Exit Function

fncIsProtected_Error:
80 Select Case Err.Number
Case 0
90 Resume Ausgang
100 Case Else
110 Call fncErrorHandler("mdlSprache", "fncIsProtected")
120 Resume Ausgang
130 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncCheckAbfragen
' Autor : Günter Gerold
' Datum : 16.11.2008
' Text : In Abfragen könnte z.B. ein Formularbezug mit "Formulare!" beginnen, was ein
' englisches Access nicht versteht. Deshalb wird "Forms!" eingesetzt.
'---------------------------------------------------------------------------------------

Public Function fncCheckAbfragen() As Boolean
Dim obj As Object
Dim allobj As Object
Dim ctrl As Control

10 On Error GoTo fncCheckAbfragen_Error

20 For Each allobj In Application.CurrentProject.AllForms 'Alle Formularnamen holen
30 DoCmd.OpenForm allobj.Name, acDesign, , , , acHidden 'Alle Formulare nacheinander im Entwurfsmodus öffnen
40 Set obj = Forms(allobj.Name)
50 fncReplaceBezuege obj, dtRecordSource
60 For Each ctrl In obj.Controls
70 Select Case ctrl.ControlType
Case acTextBox, acCheckBox, acOptionGroup
80 fncReplaceBezuege ctrl, dtControlSource
90 Case acListBox, acComboBox
100 fncReplaceBezuege ctrl, dtRowSource
110 fncReplaceBezuege ctrl, dtControlSource
120 Case Else
130 End Select
140 Next
150 DoCmd.Close acForm, allobj.Name, acSaveYes
160 Next
170 For Each allobj In Application.CurrentProject.AllReports
180 DoCmd.OpenReport allobj.Name, acDesign, , , , acHidden
190 Set obj = Reports(allobj.Name)
200 fncReplaceBezuege obj, dtRecordSource
210 For Each ctrl In obj.Controls
220 Select Case ctrl.ControlType
Case acTextBox
230 fncReplaceBezuege ctrl, dtControlSource
240 Case Else
250 End Select
260 Next
270 DoCmd.Close acReport, allobj.Name, acSaveYes
280 Next
290 For Each allobj In CurrentDb.QueryDefs
300 fncReplaceBezuege allobj, dtSQL
310 Next

Ausgang:
320 On Error Resume Next
330 Set ctrl = Nothing
340 Set allobj = Nothing
350 Set obj = Nothing
360 Exit Function

fncCheckAbfragen_Error:
370 Select Case Err.Number
Case 0
380 Resume Ausgang
390 Case Else
400 Call fncErrorHandler("mdlSprache", "fncCheckAbfragen")
410 Resume Ausgang
420 End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncReplaceBezuege
' Autor : Günter Gerold
' Datum : 16.11.2008
' Text :
'---------------------------------------------------------------------------------------

Private Function fncReplaceBezuege(ByRef ctrl As Object, ByVal eType As eSuchBereich) As Boolean
10 On Error GoTo fncReplaceBezuege_Error

20 Select Case eType
Case dtRecordSource
30 If Left$(ctrl.RecordSource, 6) = "SELECT" Then
40 ctrl.RecordSource = Replace(ctrl.RecordSource, "Formulare!", "Forms!")
50 ctrl.RecordSource = Replace(ctrl.RecordSource, "[Formulare]!", "Forms!")
60 ctrl.RecordSource = Replace(ctrl.RecordSource, "Formular!", "Form!")
70 ctrl.RecordSource = Replace(ctrl.RecordSource, "[Formular]!", "Form!")
80 ctrl.RecordSource = Replace(ctrl.RecordSource, "Berichte!", "Reports!")
90 ctrl.RecordSource = Replace(ctrl.RecordSource, "[Berichte]!", "Reports!")
100 ctrl.RecordSource = Replace(ctrl.RecordSource, "Bericht!", "Report!")
110 ctrl.RecordSource = Replace(ctrl.RecordSource, "[Bericht]!", "Report!")
120 End If
130 Case dtRowSource
140 If Left$(ctrl.RowSource, 6) = "SELECT" Then
150 ctrl.RowSource = Replace(ctrl.RowSource, "Formulare!", "Forms!")
160 ctrl.RowSource = Replace(ctrl.RowSource, "[Formulare]!", "Forms!")
170 ctrl.RowSource = Replace(ctrl.RowSource, "Formular!", "Form!")
180 ctrl.RowSource = Replace(ctrl.RowSource, "[Formular]!", "Form!")
190 ctrl.RowSource = Replace(ctrl.RowSource, "Berichte!", "Reports!")
200 ctrl.RowSource = Replace(ctrl.RowSource, "[Berichte]!", "Reports!")
210 ctrl.RowSource = Replace(ctrl.RowSource, "Bericht!", "Report!")
220 ctrl.RowSource = Replace(ctrl.RowSource, "[Bericht]!", "Report!")
230 End If
240 Case dtControlSource
250 If Left$(ctrl.ControlSource, 6) = "SELECT" Then
260 ctrl.ControlSource = Replace(ctrl.ControlSource, "Formulare!", "Forms!")
270 ctrl.ControlSource = Replace(ctrl.ControlSource, "[Formulare]!", "Forms!")
280 ctrl.ControlSource = Replace(ctrl.ControlSource, "Formular!", "Form!")
290 ctrl.ControlSource = Replace(ctrl.ControlSource, "[Formular]!", "Form!")
300 ctrl.ControlSource = Replace(ctrl.ControlSource, "Berichte!", "Reports!")
310 ctrl.ControlSource = Replace(ctrl.ControlSource, "[Berichte]!", "Reports!")
320 ctrl.ControlSource = Replace(ctrl.ControlSource, "Bericht!", "Report!")
330 ctrl.ControlSource = Replace(ctrl.ControlSource, "[Bericht]!", "Report!")
340 End If
350 Case dtSQL
360 If Left$(ctrl.SQL, 6) = "SELECT" Then
370 ctrl.SQL = Replace(ctrl.SQL, "Formulare!", "Forms!")
380 ctrl.SQL = Replace(ctrl.SQL, "[Formulare]!", "Forms!")
390 ctrl.SQL = Replace(ctrl.SQL, "Formular!", "Form!")
400 ctrl.SQL = Replace(ctrl.SQL, "[Formular]!", "Form!")
410 ctrl.SQL = Replace(ctrl.SQL, "Berichte!", "Reports!")
420 ctrl.SQL = Replace(ctrl.SQL, "[Berichte]!", "Reports!")
430 ctrl.SQL = Replace(ctrl.SQL, "Bericht!", "Report!")
440 ctrl.SQL = Replace(ctrl.SQL, "[Bericht]!", "Report!")
450 End If
460 Case Else
470 End Select

Ausgang:
480 On Error Resume Next
490 Exit Function

fncReplaceBezuege_Error:
500 Select Case Err.Number
Case 0
510 Resume Ausgang
520 Case Else
530 Call fncErrorHandler("mdlSprache", "fncReplaceBezuege")
540 Resume Ausgang
550 End Select

End Function

mdlggMehrsprachigkeit

Das folgende Modul wird vom Addin in das Projekt kopiert. Es enthält die nötigen Funktionen zum auslesen der Übersetzungstabellen zur Laufzeit.

'---------------------------------------------------------------------------------------
' Modul : mdlggMehrsprachigkeit 1.30
' Autor : Günter Gerold
' Datum : 16.11.2008
' Text :
'
' 1. Tabellen werden erzeugt (beim ersten Start mit 2 Sprachen)
' 2. Formulare und dieses Modul kopiert
' 3. Alle Beschriftungen und Texte der Steuerelemente in den Formularen und Reports werden eingelesen, wenn nicht schon vorhanden
' Datensätze für nicht mehr vorhandene Steuerelemente werden gelöscht
' 4. Der Aufruf FormBeschriftung Me wird in das Ereignis Form_Open eingefügt falls nicht schon vorhanden
' 5. MsgBoxen und Inputboxen werden eingelesen, falls nicht schon geschehen. Auch hier werden verwaiste Datensätze gelöscht

'Alle Änderungen im Code werden mit dem Kommentar "eingefügt vom Addin ggMehrsprachigkeit"
'versehen. Dadurch können mit der Suchfunktion diese Stellen einfach gefunden werden. Wird
'im Code oder den Tabellen etwas geändert, einfach das Addin erneut aufrufen. So werden die Daten
'abgeglichen, z.B. beim Einfügen einer neuen Sprache in allen Tabellen die nötigen Datensätze erzeugt.
'die CurrentDb Aufrufe können/sollen durch ein eigenes CurrentDbC ersetzt werden
'Ebenso sollte der eigene Errorhandler hinzugefügt werden
'---------------------------------------------------------------------------------------

Option Compare Database
Option Explicit

Public lngLang As Long 'Diese Variable hält die aktuelle Sprache. Sie kann auch aus der Tabelle cSpracheTabelle Feld cSpracheTabelleActive ausgelesen werden.

Public Const cSpracheTabelle As String = "ggMehrsprachigkeittblSprache"
Public Const cSpracheTabelleID As String = "ID"
Public Const cSpracheTabelleSprache As String = "Sprache"
Public Const cSpracheTabelleActive As String = "Aktiv"

Public Const cBeschriftungstabelle As String = "ggMehrsprachigkeittblBeschriftungen"
Public Const cBeschriftungstabelleID As String = "ID"
Public Const cBeschriftungstabelleSprachID As String = "SprachID"
Public Const cBeschriftungstabelleSteuerelement As String = "Steuerelementname"
Public Const cBeschriftungstabelleCaption As String = "Beschriftung"
Public Const cBeschriftungstabelleTooltip As String = "TooltipText"
Public Const cBeschriftungstabelleStatus As String = "StatuszeilenText"
Public Const cBeschriftungstabelleGueltigkeit As String = "Gueltigkeitsmeldung"
Public Const cBeschriftungstabelleFormName As String = "Formularname"
Public Const cBeschriftungstabelleIgnore As String = "ignorieren"
Public Const cBeschriftungstabelleTyp As String = "Typ"
Public Const cBeschriftungstabelleObjektTyp As String = "ObjektTyp"

Public Const cBoxIDs As String = "ggMehrsprachigkeittblBoxIDs"
Public Const cBoxIDsID As String = "ID"
Public Const cBoxIDsText As String = "Position"
Public Const cBoxIDsCheck As String = "Check" 'Während des Codedurchlaufs werden gefundene Boxen mit ID in der Tabelle angehakt damit können verwaiste Tabelleneinträge schneller gefunden werden.
Public Const cBoxIDsType As String = "Typ"

Public Const cBoxTabelle As String = "ggMehrsprachigkeittblBoxTexte"
Public Const cBoxTabelleID As String = "ID"
Public Const cBoxTabelleBoxID As String = "BoxID"
Public Const cBoxTabellePrompt As String = "Prompt"
Public Const cBoxTabelleTitle As String = "Title"
Public Const cBoxTabelleHelpFile As String = "HelpFile"
Public Const cBoxTabelleLanguage As String = "Sprache"
Public Const cBoxTabelleDefault As String = "Default"

'---------------------------------------------------------------------------------------
' Prozedur : fncggSpracheStarter
' Autor : Günter Gerold
' Datum : 04.11.2008
' Text : Diese Funktion holt die in cSpracheTabelle gespeicherte Sprache und lädt
' sie in die globale Variable lngLang. Diese Funktion sollte beim Start der
' Datenbank ausgeführt werden!
'---------------------------------------------------------------------------------------

Public Function fncggSpracheStarter() As Boolean

Dim rs As DAO.Recordset
Dim strSQL As String

On Error GoTo fncggSpracheStarter_Error

strSQL = "SELECT " & cSpracheTabelleID & " FROM " & cSpracheTabelle & " WHERE " & cSpracheTabelleActive & " = -1 ;"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot, dbFailOnError)
lngLang = rs.Fields(cSpracheTabelleID).Value
fncggSpracheStarter = True

Ausgang:
On Error Resume Next
rs.Close
Set rs = Nothing
Exit Function

fncggSpracheStarter_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case Else
VBA.MsgBox "Fehler in der Funktion fncggSprachestarter im Modul mdlggMehrsprachigkeit", vbCritical, "Error" 'Todo: Eigenen Errorhandler einfügen
Resume Ausgang
End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : fncStoreLanguage
' Autor : Günter Gerold
' Datum : 07.11.2008
' Text : Soll eine Sprache dauerhaft ausgewählt werden, wird sie hier aus der globalen
' Variable in die Sprachetabelle übertragen
'---------------------------------------------------------------------------------------

Public Function fncStoreLanguage() As Boolean
Dim strSQL As String

On Error GoTo fncStoreLanguage_Error

strSQL = "UPDATE " & cSpracheTabelle & " SET " & cSpracheTabelleActive & " = False"
CurrentDb.Execute strSQL, dbFailOnError
strSQL = "UPDATE " & cSpracheTabelle & " SET " & cSpracheTabelleActive & " = True WHERE " & cSpracheTabelleID & " = " & lngLang
CurrentDb.Execute strSQL, dbFailOnError

Ausgang:
On Error Resume Next
Exit Function

fncStoreLanguage_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case Else
VBA.MsgBox "Fehler im Modul: mdlggMehrsprachigkeit Funktion: fncStoreLanguage", , "Error" 'Todo: Eigenen Errorhandler einfügen
Resume Ausgang
End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : getControlType
' Autor : Günter Gerold
' Datum : 02.11.2008
' Text : Damit im Sprachenformular beim Steuerelementtyp nich nur eine nichtssagende
' Zahl steht, wird hier in einen Text umgewandelt.
'---------------------------------------------------------------------------------------

Public Function getControlType(ByVal lngcontroltype As Long) As String

On Error GoTo getControlType_Error

Select Case lngcontroltype
Case acBoundObjectFrame
getControlType = "Bound Object Frame"
Case acCheckBox
getControlType = "Check Box"
Case acComboBox
getControlType = "Combo Box"
Case acCommandButton
getControlType = "Command Button"
Case acCustomControl
getControlType = "Custom Control"
Case acImage
getControlType = "Image"
Case acLabel
getControlType = "Label"
Case acLine
getControlType = "Line"
Case acListBox
getControlType = "List Box"
Case acObjectFrame
getControlType = "Object Frame"
Case acOptionButton
getControlType = "Object Button"
Case acOptionGroup
getControlType = "Option Group"
Case acPage
getControlType = "Page"
Case acPageBreak
getControlType = "Page Break"
Case acRectangle
getControlType = "Rectangle"
Case acSubform
getControlType = "Subform/Subreport"
Case acTabCtl
getControlType = "Tab Control"
Case acTextBox
getControlType = "Text Box"
Case acToggleButton
getControlType = "Toggle Button"
Case acForm
getControlType = "Form"
Case acReport
getControlType = "Report"
Case Else
getControlType = "Unknown type"
End Select

Ausgang:
On Error Resume Next
Exit Function

getControlType_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case Else
VBA.MsgBox "Fehler in mdlggMehrsprachigkeit, Funktion: getControlType" 'Todo: Eigenen Errorhandler einfügen
Resume Ausgang
End Select

End Function

'---------------------------------------------------------------------------------------
' Prozedur : FormBeschriftung
' Autor : Günter Gerold
' Datum : 14.09.2008
' Text : zur Laufzeit werden die Texte in die Controls gesetzt. Aufruf mit:
' 'FormBeschriftung Me' im Ereignis 'Beim Öffnen' der Formulare
' Die Einträge in den Steuerelementen selbst werden ignoriert.
'---------------------------------------------------------------------------------------

Public Sub FormBeschriftung(objForm As Object)
Dim strSQL As String
Dim rst As DAO.Recordset

On Error GoTo FormBeschriftung_Error

If lngLang = 0 Then fncggSpracheStarter

strSQL = _
"SELECT " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleGueltigkeit & ", " & _
cBeschriftungstabelleTyp & _
" FROM " & cBeschriftungstabelle & _
" WHERE " & cBeschriftungstabelleFormName & "='" & objForm.Name & _
"' AND " & cBeschriftungstabelleSprachID & "=" & lngLang & _
" AND " & cBeschriftungstabelleObjektTyp & "=" & 2 & _
" AND " & cBeschriftungstabelleIgnore & " = False;"

Set rst = CurrentDb.OpenRecordset(strSQL, _
dbOpenDynaset)
Do While Not rst.EOF
Select Case rst.Fields(cBeschriftungstabelleTyp).Value
Case acForm
objForm.Caption = rst.Fields(cBeschriftungstabelleCaption).Value
Case acLabel
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).Caption _
= rst.Fields(cBeschriftungstabelleCaption).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
Case acListBox, acComboBox, acTextBox, acOptionGroup
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ValidationText _
= rst.Fields(cBeschriftungstabelleGueltigkeit).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acTabCtl, acSubform
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acPage, acToggleButton, acCommandButton
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).Caption _
= rst.Fields(cBeschriftungstabelleCaption).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acOptionButton
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acCheckBox
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
objForm.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ValidationText _
= rst.Fields(cBeschriftungstabelleGueltigkeit).Value
Case Else
End Select
rst.MoveNext
Loop

Ausgang:
On Error Resume Next
rst.Close
Set rst = Nothing
Exit Sub

FormBeschriftung_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case 13
Resume Next 'wenn ein Button keine Beschriftung sondern eine Grafik zeigt
Case 2465
VBA.MsgBox "In der Tabelle " & cBeschriftungstabelle & " existieren Beschriftungen für Steuerelemente, die in dem Formular nicht vorhanden sind. Bitte mit Hilfe des Addins aktualisieren!", , "Steuerelement nicht gefunden"
Resume Ausgang
Case Else
VBA.MsgBox "Fehler in der Sub Formbeschriftung", , "Error" 'Todo: Eigenen Errorhandler einsetzen
Resume Ausgang
End Select

End Sub

'---------------------------------------------------------------------------------------
' Prozedur : ReportBeschriftung
' Autor : Günter Gerold
' Datum : 12.11.2008
' Text :
'---------------------------------------------------------------------------------------

Public Sub ReportBeschriftung(objReport As Object)
Dim strSQL As String
Dim rst As DAO.Recordset

On Error GoTo ReportBeschriftung_Error

If lngLang = 0 Then fncggSpracheStarter

strSQL = _
"SELECT " & _
cBeschriftungstabelleFormName & ", " & _
cBeschriftungstabelleSteuerelement & ", " & _
cBeschriftungstabelleCaption & ", " & _
cBeschriftungstabelleTooltip & ", " & _
cBeschriftungstabelleStatus & ", " & _
cBeschriftungstabelleTyp & _
" FROM " & cBeschriftungstabelle & _
" WHERE " & cBeschriftungstabelleFormName & "='" & objReport.Name & _
"' AND " & cBeschriftungstabelleSprachID & "=" & lngLang & _
" AND " & cBeschriftungstabelleObjektTyp & "=" & 3 & _
" AND " & cBeschriftungstabelleIgnore & " = False;"

Set rst = CurrentDb.OpenRecordset(strSQL, _
dbOpenDynaset)
Do While Not rst.EOF
Select Case rst.Fields(cBeschriftungstabelleTyp).Value
Case acReport
objReport.Caption = rst.Fields(cBeschriftungstabelleCaption).Value
Case acLabel
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).Caption _
= rst.Fields(cBeschriftungstabelleCaption).Value
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
Case acListBox, acComboBox, acTextBox, acOptionGroup
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acTabCtl, acSubform
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acPage, acToggleButton, acCommandButton
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).Caption _
= rst.Fields(cBeschriftungstabelleCaption).Value
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acOptionButton
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case acCheckBox
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).ControlTipText _
= rst.Fields(cBeschriftungstabelleTooltip).Value
objReport.Controls(rst.Fields(cBeschriftungstabelleSteuerelement).Value).StatusBarText _
= rst.Fields(cBeschriftungstabelleStatus).Value
Case Else
End Select
rst.MoveNext
Loop

Ausgang:
On Error Resume Next
rst.Close
Set rst = Nothing
Exit Sub

ReportBeschriftung_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case 13
Resume Next 'wenn ein Button keine Beschriftung sondern eine Grafik zeigt
Case 2465
VBA.MsgBox "In der Tabelle " & cBeschriftungstabelle & " existieren Beschriftungen für Steuerelemente, die in dem Formular nicht vorhanden sind. Bitte mit Hilfe des Addins aktualisieren!", , "Steuerelement nicht gefunden"
Resume Ausgang
Case Else
VBA.MsgBox "Fehler in der Sub ReportBeschriftung", , "Error" 'Todo: Eigenen Errorhandler einsetzen
Resume Ausgang
End Select
End Sub

'------------------------------------------------------------------------------------------------------
' Prozedur : MsgBox
' Autor : Günter Gerold
' Datum : 25.10.2008
' Text : Die originale MsgBox wurde nur erweitert. Deshalb kann sie auch Standardaufrufe abarbeiten
' Die neue MessageBox holt anhand der ID den Prompt und Title aus der Tabelle cMsgBoxTabelle
' ist keine ID vorhanden, wird der übergebene Prompt und Title verwendet, der sonst ignoriert wird
' Params kann ein einzelner Wert einer Variable sein, oder ein Array. z.B.: array(Variable1, Variable2, ...)
'------------------------------------------------------------------------------------------------------

Public Function MsgBox(ByVal Prompt As String, Optional ByVal ButtonType As VbMsgBoxStyle, Optional ByVal Title As String, Optional ByVal HelpFile As String, Optional ByVal Kontext As Long, Optional ByVal ID As Long, Optional ByVal Params As Variant = "") As VbMsgBoxResult
Dim a As Integer
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strPrompt As String
Dim strTitle As String
Dim bytCounter As Byte

On Error GoTo MsgBox_Error

If lngLang = 0 Then lngLang = 1
If IsNull(ID) Then
a = VBA.MsgBox(Prompt, ButtonType, Title, HelpFile, Kontext)
Else
strSQL = "SELECT " & cBoxTabelle & "." & cBoxTabellePrompt & ", " & cBoxTabelle & "." & cBoxTabelleTitle & ", " & cBoxTabelle & "." & cBoxTabelleHelpFile & " FROM " & cBoxIDs & " INNER JOIN " & cBoxTabelle & " ON " & cBoxIDs & "." & cBoxIDsID & " = " & cBoxTabelle & "." & cBoxTabelleBoxID & " WHERE (((" & cBoxTabelle & "." & cBoxTabelleBoxID & ") = " & ID & ") AND ((" & cBoxTabelle & "." & cBoxTabelleLanguage & ") = " & lngLang & ") AND ((" & cBoxIDs & "." & cBoxIDsType & ") = 1));"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbFailOnError)
strPrompt = rs.Fields(cBoxTabellePrompt).Value 'ToDo: wenn in der Tabelle nichts gefunden wird, den Prompt aus der Box nehmen (im Moment noch im Errorhandler!!!)
strTitle = Nz(rs.Fields(cBoxTabelleTitle).Value)
If IsArray(Params) Then
For bytCounter = LBound(Params) To UBound(Params)
strPrompt = Replace(strPrompt, "%PH" & bytCounter + 1 & "%", Params(bytCounter))
strTitle = Replace(strTitle, "%PH" & bytCounter + 1 & "%", Params(bytCounter))
Next bytCounter
Else
strPrompt = Replace(strPrompt, "%PH1%", Params)
strTitle = Replace(strTitle, "%PH1%", Params)
End If
a = VBA.MsgBox(strPrompt, Val(ButtonType), strTitle, rs.Fields(cBoxTabelleHelpFile).Value, Kontext)
End If
MsgBox = a

Ausgang:
On Error Resume Next
Set rs = Nothing
Exit Function

MsgBox_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case 3021
a = VBA.MsgBox(Prompt, ButtonType, Title, HelpFile, Kontext)
Resume Ausgang
Case Else
VBA.MsgBox "Fehler in der Funktion MsgBox", , "Error" 'Todo: Eigenen Errorhandler einfügen
Resume Ausgang
End Select
End Function

'---------------------------------------------------------------------------------------
' Prozedur : InputBox
' Autor : Günter Gerold
' Datum : 12.11.2008
' Text :
'---------------------------------------------------------------------------------------

Public Function InputBox(ByVal Prompt As String, Optional ByVal Title As String, Optional ByVal Default As String, Optional ByVal XPos As Long, Optional ByVal YPos As Long, Optional ByVal HelpFile As String, Optional ByVal Kontext As Long, Optional ByVal ID As Long, Optional ByVal Params As Variant = "") As String
Dim a As String
Dim rs As DAO.Recordset
Dim strSQL As String
Dim strPrompt As String
Dim strTitle As String
Dim strDefault As String
Dim bytCounter As Byte

On Error GoTo InputBox_Error

If lngLang = 0 Then lngLang = 1
If IsNull(ID) Then
a = VBA.InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Kontext)
Else
strSQL = "SELECT " & cBoxTabelle & "." & cBoxTabellePrompt & ", " & cBoxTabelle & "." & cBoxTabelleTitle & ", " & cBoxTabelle & "." & cBoxTabelleHelpFile & ", " & cBoxTabelle & "." & cBoxTabelleDefault & " FROM " & cBoxIDs & " INNER JOIN " & cBoxTabelle & " ON " & cBoxIDs & "." & cBoxIDsID & " = " & cBoxTabelle & "." & cBoxTabelleBoxID & " WHERE (((" & cBoxTabelle & "." & cBoxTabelleBoxID & ") = " & ID & ") AND ((" & cBoxTabelle & "." & cBoxTabelleLanguage & ") = " & lngLang & ") AND ((" & cBoxIDs & "." & cBoxIDsType & ") = 2));"
Set rs = CurrentDb.OpenRecordset(strSQL, dbOpenDynaset, dbFailOnError)
strPrompt = rs.Fields(cBoxTabellePrompt).Value 'ToDo: wenn in der Tabelle nichts gefunden wird, den Prompt aus der Box nehmen (im Moment noch im Errorhandler!!!)
strTitle = Nz(rs.Fields(cBoxTabelleTitle).Value)
strDefault = Nz(rs.Fields(cBoxTabelleDefault).Value)
If IsArray(Params) Then
For bytCounter = LBound(Params) To UBound(Params)
strPrompt = Replace(strPrompt, "%PH" & bytCounter + 1 & "%", Params(bytCounter))
strTitle = Replace(strTitle, "%PH" & bytCounter + 1 & "%", Params(bytCounter))
strDefault = Replace(strDefault, "%PH" & bytCounter + 1 & "%", Params(bytCounter))
Next bytCounter
Else
strPrompt = Replace(strPrompt, "%PH1%", Params)
strTitle = Replace(strTitle, "%PH1%", Params)
strDefault = Replace(strTitle, "%PH1%", Params)
End If
a = VBA.InputBox(strPrompt, strTitle, strDefault, XPos, YPos, rs.Fields(cBoxTabelleHelpFile).Value, Kontext)
End If
InputBox = a

Ausgang:
On Error Resume Next
Set rs = Nothing
Exit Function

InputBox_Error:
Select Case Err.Number
Case 0
Resume Ausgang
Case 3021
a = VBA.InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Kontext)
Resume Ausgang
Case Else
VBA.MsgBox "Fehler in der Funktion InputBox", , "Error" 'Todo: Eigenen Errorhandler einfügen
Resume Ausgang
End Select
End Function