Attribute VB_Name = "mdlMultiLanguage"
'*********************************************************'
'*                                                       *'
'*   *   *   *   *   *   *   *   *   *   *   *   *   *   *'
'*                                                       *'
'*   MultilanguageSupport für bestehende ACCESS-Projecte *'
'*                                                       *'
'*   Autor:   Butzel  { www.butzel.info }                *'
'*   Version: 1.2006.03.02.1644                          *'
'*   Hinweis: vor der Einbindung ist ein BackUp          *'
'*            zu erstellen, keine Haftung für Schäden    *'
'*            jeglicher Art                              *'
'*                                                       *'
'*   *   *   *   *   *   *   *   *   *   *   *   *   *   *'
'*                                                       *'
'*********************************************************'
Option Compare Database
Public ML_SPRACHDATEI As String
Public Const ML_ZEILENSCHALTUNG = "\n" 'Zeilenschaltung       [Enter]
Public Const ML_KLAMMER_AUF = "\("     'geschweifte Klammer auf [{]
Public Const ML_KLAMMER_ZU = "\)"      'geschweifte Klammer zu  [}]
Public Const ML_GLEICH = "\i"          'Gleich-Zeichen          [=]
Public Const ML_SEMIKOLON = "\,"       'Semikolon               [;]
Public Const ML_TABULATOR = "\t"       'Tabulator             [     ]
'** BACKSLASH-Schrägstrich = "\\"      'BackSlash               [\]
'
'
'* * * * H I N W E I S E   &   K U R Z A N L E I T U N G * * * *
' :: Einbindung
'
'   o Formulare
'      in jedem Formular (auch bei Unterformularen), welche MultiLanguage-Support
'      unterstützen soll, muss  wie im folgendem Beispiel der multiLanguage-Aufruf
'      im LOAD-Event eingefügt werden:
'
' ''''''''' Private Sub Form_Load()
' '''''''''     '...
' '''''''''     '...
' '''''''''     multiLanguage Me, ML_SPRACHDATEI
' '''''''''     '...
' '''''''''     '...
' '''''''''     '...
' ''''''''' End Sub
'
'   o die String-Variable ML_SPRACHDATEI enthält dabei die Pfad- und Dateiangabe
'      wo sich die zu verwendene Sprachdatei befindet:
' z.B.
'
' ''''''''' ML_SPRACHDATEI = Application.CurrentProject.Path + "\lang.ini"
'
'  o Zeichenketten
'     hier übersetzt die Funktion multiLanguageString(sText,sDateiNameMitPfad)
'     den zuübersetzenden Text. Sofern er in der Sprachdatei gefunden wird
'
' :: Hinweise zur SprachDatei
'
' o die Sprachdatei enthält für jedes unterstütze Formular einen Eintrag nach
'    folgendem Beispiel:
'
''' form_name{
''' me.caption=Formular Beschriftung;
''' objectname.caption=Beschriftung des Objects;
''' objectname.tooltip=ToolTip-Text des Objects;
''' cmdexit.caption=Schliessen;
''' cmdexit.tooltip=Schliesst das aktuelle Formular;
''' lbltest.caption=Mein Test Formular\n2.Zeile;
''' lbltest.tooltip=;
''' }
'''
''' !strings{
''' hallo welt=Hallo Welt;
''' wirklich\nlöschen?=Möchten Sie wirklich löschen??\n[JA]-[NEIN];
''' }
'''
'
' o Syntax:
'    Nach dem Namen des Formulares sind in geschweiften Klammer die zugehörigen
'    Objekte aufgelistet.Die Namen der Objekte (und Formulare) sowie die
'    Eigenschaftgen sind in Kleinbuchstaben einzutragen. Zwischen dem [=]-Zeichen
'    und dem [;]-Semikolon befindet sich der Text für Beschriftung und ToolTip,
'    welcher freimodifiziert werden kann.
'    Caption bezeichnet dabei die Beschriftung
'    und ToolTip den Steuerelement-Tip
'    me.caption stellt die Überschrift des Formulares dar...
'
' o Fehler in der Sprach-Datei
'    Fehlen in der Sprach-Datei Objekte (oder FormularNamen) bzw. sind diese falsch
'    geschrieben, so werden diese nicht angepasst. Sind Objekte zuviel aufgelistet
'    so werden diese ignoriert.
'    Bei beiden Fehlern wird keine Fehlerausgabe produziert.
'
' o Weglassen des Beschriftung- bzw. ToolTip-Textes (z.B. objekt.tooltip=;)
'    dies hat zur folge das die Beschriftung bzw. ToolTip leer bleibt
'    (im Beispiel hat das Objekt keinen Steuerelement-Tip)
'
' o Sonderzeichen:
'    (alle ASCII-Zeichen welche kleiner als 29(dezimal)  werden ignoriert.)
'
'    [{]-[}]-[=]-[;]-[\] und Sonderzeichen-Darstellung in der INI:
'
'     \n = Zeilenschaltung       [Enter]
'     \( = geschweifte Klammer auf [{]
'     \) = geschweifte Klammer zu  [}]
'     \i = Gleich-Zeichen          [=]
'     \, = Semikolon               [;]
'     \t = Tabulator             [     ]
'     \\ = Backslash               [\]
'     Dies kann durch Änderung der entsprechenden Konstanten angepasst werden,
'      jedoch ist das [\]-Zeichen als erstes dieser Darstellungszeichen und
'      eine Länge von 2-stellen festgelegt!
'
' o unterstützte Objekte:
'   in dieser Version werden folgende Objekttypen unterstützt:
'    100 = Label         (Bezeichnungsfeld)
'    104 = CommandButton (Befehlschaltfläche)
'    122 = OptionCommand (Umschaltfläche)
'    124 = TabStrip      (Registerkarten)
'
' :: Automatisches erstellen einer Sprach-Datei
'
' o multiLanguageErstelleINI c:\lang.ini
'    wenn sich dieses Modul in Ihrem Projekt befindet, die Funktion
'    multiLanguageErstelleINI(sDateiNameMitPfad As String) aufrufen.
'    sDateiNameMitPfad enthält den Pfad- u. Dateinamen der Speicherortes.
'    (ist die angegebene Datei vorhanden, wird sie überschrieben!).
'
' o Funktionsweise
'    die Funktion versucht alle Fenster zuöffnen und schreibt dann bei jedem
'    geöffneten Fenster die unterstützten Objekte in die angegebene Datei mit
'    aktuellen zustand der Beschriftung. So wird eine aktuelle Sprach-Datei zu
'    derzeit verwendeten Sprache hergestellt.
'    Nach Durchlauf dieser Funktion werden Sie über den Erfolg informiert.
'    Schliessen Sie danach die ACCESS ohne  zu speichern.
'
'((HINWEIS zur multiLanguageErstelleINI:                ))
'(( BETA-Funktion: kein Support, keine Funktionsgarantie))
'
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' unabhängige Funktionen dieses Modules:''''''''''''''''''''''''''''
'******************************************************************'
' Zwischen( sQuelle,  sBeginnString, sEndeString) as String        '                                                        '
'                                                                  '
' Gibt aus der Zeichenkette sQuelle, den Bereich zwischen          '
' sBeginnStr und sEndeStr zurück                                   '
'                --->    benötigt imString    <---                 '
'                                                                  '
'******************************************************************'
' ZwischenX(sQuelle,  sBeginnString, sEndeString) as String        '
'                                                                  '
' Gibt aus der Zeichenkette sQuelle, den Bereich zwischen          '
' sBeginnStr und sEndeStr zurück                                   '
'  X-Funktion:                                                     '
' um sollte zwischen sBeginn und sEnde weitere sBeginn vorhanden   '
' sein so versucht ZwischenX jedes sBeginn mit einem sEnde zu      '
' schliessen                                                       '
'                --->    benötigt imString    <---                 '
'                                                                  '
'******************************************************************'
'                                                                  '
' imString(sSucheIn, sSucheNach) as Long                           '
'                                                                  '
' Gibt die Position von sSucheNach in sSucheIn zurück              '
'                                                                  '
'                                                                  '
'******************************************************************'



Public Function multiLanguageGetEnter(sWert As String) As String
' ersetzt enterschaltungen mit  µ
Dim nZaehler As Long
Dim RetVal As String
RetVal = ""
For nZaehler = 1 To Len(sWert)
    Select Case Asc(Mid(sWert, nZaehler, 1))
        Case 92
            RetVal = RetVal + "\\"
        Case 13
            RetVal = RetVal + ML_ZEILENSCHALTUNG
        Case 10
            'Teil 2 der Zeilenschaltung
        Case 123
            RetVal = RetVal + ML_KLAMMER_AUF
        Case 125
            RetVal = RetVal + ML_KLAMMER_ZU
        Case 61
            RetVal = RetVal + ML_GLEICH
        Case 59
            RetVal = RetVal + ML_SEMIKOLON
        Case 9
            RetVal = RetVal + ML_TABULATOR
        Case Else
            RetVal = RetVal + Mid(sWert, nZaehler, 1)
    End Select
Next nZaehler
multiLanguageGetEnter = RetVal
End Function
Public Function multiLanguageSetEnter(sWert As String) As String
'ersetzt enterschaltungen mit  µ
Dim nZaehler As Long
Dim RetVal As String
RetVal = ""
For nZaehler = 1 To Len(sWert)
    
    If Mid(sWert, nZaehler, 1) = "\" Then
        Select Case Mid(sWert, nZaehler, 2)
            Case ML_ZEILENSCHALTUNG
                
                RetVal = RetVal + Chr(13) + Chr(10)
            Case ML_KLAMMER_AUF
                RetVal = RetVal + Chr(123)
            Case ML_KLAMMER_ZU
                RetVal = RetVal + Chr(125)
            Case ML_GLEICH
                RetVal = RetVal + Chr(61)
            Case ML_SEMIKOLON
                RetVal = RetVal + Chr(59)
            Case ML_TABULATOR
                RetVal = RetVal + Chr(9)
            Case "\\"
                RetVal = RetVal + "\"
            Case Else
                nZaehler = nZaehler - 1
                RetVal = RetVal + Mid(sWert, nZaehler, 1)
        End Select
    nZaehler = nZaehler + 1
    Else
        RetVal = RetVal + Mid(sWert, nZaehler, 1)
    End If

'    If Mid(sWert, nZaehler, Len(ML_ZEILENSCHALTUNG)) = ML_ZEILENSCHALTUNG Then
'        RetVal = RetVal + Chr(13) + Chr(10)
'        n = n + Len(ML_ZEILENSCHALTUNG) - 1
'    Else
'        RetVal = RetVal + Mid(sWert, nZaehler, 1)
'    End If
Next nZaehler

multiLanguageSetEnter = RetVal
End Function


Public Function ZwischenX(ByVal sQuelle, ByVal sBeginnString, ByVal sEndeString, Optional ByVal iStart As Long = 1) As String
'******************************************************************'
'                                                                  '
' Gibt aus der Zeichenkette sQuelle, den Bereich zwischen          '
' sBeginnStr und sEndeStr zurück                                   '
'X-Funktion:                                                       '
' um sollte zwischen sBeginn und sEnde weitere sBeginn vorhanden   '
' sein so versucht ZwischenX jedes sBeginn mit einem sEnde zu      '
' schliessen                                                       '
'                                                                  '
'******************************************************************'
Dim iBeginn As Long
Dim iEnde As Long
Dim nZaehler As Long
Dim nOffen As Integer
iBeginn = 0
iBeginn = imString(sQuelle, sBeginnString, iStart)
If iBeginn = 0 Then
    Zwischen = "": Exit Function
Else
    iBeginn = iBeginn + Len(sBeginnString)
End If

iEnde = 0
nOffen = 0
Dim debugvar
For nZaehler = iBeginn To Len(sQuelle)
    debugvar = Mid(sQuelle, nZaehler, Len(sBeginnString))
    If Mid(sQuelle, nZaehler, Len(sBeginnString)) = sBeginnString Then
        nOffen = nOffen + 1
    End If
    If nOffen = 0 Then
        If Mid(sQuelle, nZaehler, Len(sBeginnString)) = sEndeString Then
            iEnde = nZaehler
        End If
    Else
        If Mid(sQuelle, nZaehler, Len(sBeginnString)) = sEndeString Then
            nOffen = nOffen - 1
        End If
    End If
Next nZaehler
If sBeginnString = sEndeString Then iEnde = imString(sQuelle, sEndeString, iBeginn)
If iEnde = 0 Then
    ZwischenX = Mid(sQuelle, iBeginn)
Else
    ZwischenX = Mid(sQuelle, iBeginn, iEnde - iBeginn)
End If
End Function

Public Function Zwischen(ByVal sQuelle, ByVal sBeginnString, ByVal sEndeString, Optional ByVal iStart As Long = 1) As String
'******************************************************************'
'                                                                  '
' Gibt aus der Zeichenkette sQuelle, den Bereich zwischen          '
' sBeginnStr und sEndeStr zurück                                   '
'                                                                  '
'******************************************************************'
Dim iBeginn As Long
Dim iEnde As Long
iBeginn = 0
iBeginn = imString(sQuelle, sBeginnString, iStart)
If iBeginn = 0 Then
    Zwischen = "":    Exit Function
Else
    iBeginn = iBeginn + Len(sBeginnString)
End If
iEnde = imString(sQuelle, sEndeString, iBeginn)
If iEnde = 0 Then
    Zwischen = Mid(sQuelle, iBeginn)
Else
    Zwischen = Mid(sQuelle, iBeginn, iEnde - iBeginn)
End If
End Function

Public Function imString(ByVal sSucheIn, ByVal sSucheNach, Optional ByVal iStart As Long = 1) As Long
'******************************************************************'
'                                                                  '
' wusste gar nicht, das VB die Funktion InStr hat...               '
'                                                                  '
'******************************************************************'
If iStart = 0 Then iStart = 1
imString = InStr(iStart, sSucheIn, sSucheNach)
End Function

Public Sub multiLanguage(oFormular As Form, Optional ByVal sDateiNameMitPfad As String)
'Variablendeklaration
Dim oElement As Object
Dim sEnter As String
Dim RetVal As String
Dim sIniFormular As String
Dim nZaehler As Long
'Variablen initialisierung
Enter = vbCr
sIniFormular = ""


'Sollte die Datei, nicht angegeben werden, so nutze diese:
If sDateiNameMitPfad = "" Then Exit Sub
    'sDateiNameMitPfad = Application.CurrentProject.Path + "\lang.ini"
    'endif

'Sprachdatei in die Variable siniFile einlesen (beispiel aus der hilfe ;)
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.OpenTextFile(sDateiNameMitPfad, 1)
sIniFormular = a.ReadAll
a.Close

'Wenn sie leer ist hats auch keinen sinn
If sIniFormular = "" Then Exit Sub


'Zeichen unter ASCII-Code 29 rausnehmen
RetVal = ""
For nZaehler  = 1 To Len(sIniFormular)
    If Asc(Mid(sIniFormular, nZaehler , 1)) > 29 Then
        RetVal = RetVal + Mid(sIniFormular, nZaehler , 1)
    End If
Next nZaehler 
sIniFormular = RetVal
RetVal = ""



'zum Formular die Beschriftungen lesen
sIniFormular = Zwischen(sIniFormular, LCase(oFormular.Name) + "{", "}")

'Jedes Element des aktuellen oFormulares durchgehen
For Each oElement In oFormular.Controls
        RetVal = multiLanguageLeseINI(sIniFormular, "me", "caption")
         If Len(RetVal) > 0 Then
            oFormular.Caption = RetVal
            
         End If
     'Wenn es ein Element mit Caption und Beschriftung ist, so überschreibe tooltip und caption
     If oElement.ControlType = 100 Or oElement.ControlType = 104 Or oElement.ControlType = 122 Or oElement.ControlType = 124 Then
        
         'Beschriftungseigenschaft (Caption)
         RetVal = multiLanguageLeseINI(sIniFormular, oElement.Name, "caption")
         If Len(RetVal) > 0 Then
            oElement.Caption = RetVal
         End If
         
         'ToolTipText-Egenschaft (ControlTipText)
         RetVal = multiLanguageLeseINI(sIniFormular, oElement.Name, "tooltip")
         If Len(RetVal) > 0 Then
             oElement.ControlTipText = RetVal
         End If
         
     End If

Next oElement
'fix noch das me.refresh und fertig ist der käse ;)
oFormular.Refresh

End Sub

Public Sub multiLanguageErstelleINI(sDateiNameMitPfad As String)
Dim oFormulare As Object
Dim oFormular As Form
Dim oElement As Object
Dim sAktFensterName As String
Dim sEnter As String
Dim RetVal As String
Dim nZaehler As Integer
Dim nZaehler2 As Integer
sAktFensterName = Application.Screen.ActiveForm.Name
sEnter = Chr(13) + Chr(10)
RetVal = "LANGUAGE=Deutsch (Deutschland)" + sEnter + Chr(13) + sEnter

For Each oFormulare In Application.CurrentProject.AllForms
    DoCmd.OpenForm oFormulare.Name
   ' oFormulare.SetFocus
    DoCmd.SelectObject acForm, oFormulare.Name
    nZaehler = nZaehler + 1
    DoEvents
Next

nZaehler2 = nZaehler


DoEvents

For Each oFormular In Application.Forms
       nZaehler = nZaehler - 1
        DoEvents
        RetVal = RetVal + LCase(oFormular.Name) & "{" + sEnter
        RetVal = RetVal + "me.caption=" + oFormular.Caption + ";"
        
        For Each oElement In oFormular.Controls
            If oElement.ControlType = 100 Or oElement.ControlType = 104 Or oElement.ControlType = 122 Or oElement.ControlType = 124 Then
                RetVal = RetVal + LCase(oElement.Name) & ".caption=" & multiLanguageGetEnter(oElement.Caption) & ";" + sEnter
                RetVal = RetVal + LCase(oElement.Name) & ".tooltip=" & multiLanguageGetEnter(oElement.ControlTipText) & ";" + sEnter
            End If
        Next oElement
        
   RetVal = RetVal + "}" + sEnter + sEnter
      
      
Next oFormular




'Schreibe ini
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.CreateTextFile(sDateiNameMitPfad, True)
a.write RetVal
a.Close

MsgBox "Gespeichert unter: " & vbCr & sDateiNameMitPfad & vbCr & _
"Formulare im Projekt: " & nZaehler2 & vbCr & _
"Formulare in INI:     " & nZaehler2 - nZaehler & vbCr & _
"=Differenz:           " & nZaehler, vbInformation, "Sprach.ini-Referenz wurde erstellt"



End Sub


Public Sub multiLanguageSchreibeINI(sDateiName As String, sFormular As String, sControl As String, sEigenschaft, sBeschriftung)
System.PrivateProfileString(sDateiName, sFormular, sControl & "." & sEigenschaft) = sBeschriftung
End Sub

Public Function multiLanguageLeseINI(sFormular As String, sControl As String, sEigenschaft As String) As String
sEigenschaft = LCase(sEigenschaft)
sControl = LCase(sControl)
Dim RetVal As String
RetVal = ""
Select Case sEigenschaft
Case "caption"
    RetVal = multiLanguageSetEnter(Zwischen(sFormular, sControl + ".caption=", ";"))
Case "tooltip"
    RetVal = multiLanguageSetEnter(Zwischen(sFormular, sControl + ".tooltip=", ";"))
End Select
multiLanguageLeseINI = RetVal
End Function


Public Function multiLanguageString(ByVal sText As String, sDateiNameMitPfad As String) As String
Dim RetVal As String
RetVal = ""
'Sprachdatei in die Variable siniFile einlesen (beispiel aus der hilfe ;)
Dim fs, f, s
Set fs = CreateObject("Scripting.FileSystemObject")
Set a = fs.OpenTextFile(ML_SPRACHDATEI, 1)
RetVal = a.ReadAll
a.Close 'dateischliessen
RetVal = Zwischen(RetVal, "!strings{", "}")
RetVal = Zwischen(RetVal, multiLanguageGetEnter(LCase(sText)) + "=", ";")
'Sollte der Begriff nicht gefunden werden, so wird der deutsche genommen
If RetVal = "" Then RetVal = sText
    multiLanguageString = multiLanguageSetEnter(RetVal)
End Function