Attribute VB_Name = "msmapi"
Public msm, lastmsm, sema, connected
Public msm_printer() As String

Public cache_par, cache_namespace, servtyp

Const timeout = 5

Function cache_login() As Boolean

If cache_par = "" Then cache_login = False: Exit Function

FMPass.VisM1.MServer = cache_par
FMPass.VisM1.NAMESPACE = cache_namespace
cache_login = (FMPass.VisM1.Error = 0)

End Function

Function cacheinit(ByVal mco_file As String) As Boolean

cache_port = "1972"
cache_namespace = "BAUMAT"
servtyp = "msm"

cacheinit = False
Open Environ("windir") + "\" + mco_file + ".mco" For Input As #1
While Not EOF(1)
 Line Input #1, zeile1
 Zeile = ""
 For i = 1 To Len(zeile1)
   If Mid(zeile1, i, 1) <> " " Then Zeile = Zeile + Mid(zeile1, i, 1)
 Next
 If Zeile = "[CACHE]" Then servtyp = "cache"
 If Piece(Zeile, "=", 1) = "NAMESPACE" Then cache_namespace = Piece(Zeile, "=", 2)
 If Piece(Zeile, "=", 1) = "PORTCACHE" Then cache_port = Piece(Zeile, "=", 2)
 If Piece(Zeile, "=", 1) = "SERVERCACHE" Then cache_server = Piece(Zeile, "=", 2)
Wend
Close #1
If servtyp <> "cache" Then Exit Function


cache_par = "CN_IPTCP:" + cache_server + "[" + cache_port + "]"

If Not cache_login Then
   cacheinit = False
   Exit Function
End If

lastmsm = Timer
FMPass.VisM1.Execute ("S P0=$$NEW^%SEMA() W:$F($ZV,""MSM"") P0")
If FMPass.VisM1.Error = 0 Then
  connected = True
  sema = FMPass.VisM1.P0
  cacheinit = True
End If

End Function


Function msminit(ByVal mco_file As String) As Boolean
    FMPass.msm_timer.Enabled = True
    Set msm = GetObject(Environ("windir") + "\" + mco_file + ".mco")
    lastmsm = Timer
    On Error GoTo err_msminit
      FMPass.msm_timer.Enabled = True
      msm.Login
      connected = True
      sema = msm.Xecute("W $$NEW^%SEMA()")
    On Error GoTo 0
    msminit = True
    Exit Function
    
err_msminit:
    msminit = False
End Function

Function dbcall(ByVal command As String, Optional Fehler As Boolean) As String
    FMPass.msm_timer.Enabled = True
    Fehler = False 'Optionaler Parameter zum Auslesen ob eine Anfrage Korrekt war
     
     If Not connected Then   ' Überprüfung der Datenbankverbindung
      On Error GoTo Meldung    ' Einschalten der Fehlerüberwachung für LOGON
         If servtyp = "cache" Then
            If Not cache_login Then GoTo Meldung
            FMPass.VisM1.Execute ("D MEMPOP^%SEMA(" + sema + ")")
            If FMPass.VisM1.Error <> 0 Then GoTo Meldung
            connected = True
          Else
            msm.Login
            connected = True
            msm.Xecute ("D MEMPOP^%SEMA(" + sema + ")")
         End If
         FMPass.msm_timer.Enabled = True
      On Error GoTo 0          ' Aussschalten der Fehlerüberwachung für LOGON
    End If
    
    On Error GoTo Nochmal      ' Einschalten der Fehlerüberwachung Anfrage Falsch
      FMPass.msm_timer.Enabled = True
      If servtyp = "cache" Then
        FMPass.VisM1.Execute (command)
        If FMPass.VisM1.Error <> 0 Then GoTo Nochmal
        dbcall = FMPass.VisM1.P0
       Else
        dbcall = msm.Xecute(command)
      End If
      lastmsm = Timer
    On Error GoTo 0            ' Ausschalten der Fehlerüberwachung Anfrage Falsch
Exit Function

Nochmal:                       ' Fehlerbehandlung bei Falscher Anfrage
 If servtyp = "cache" Then
   Fehler = True
   A = MsgBox(FMPass.VisM1.ErrorName, vbOKOnly, "Ungültige Anfrage")
  Else
   A = MsgBox("Ungültige Anfrage. Anfrage mit anderer Eingabe wiederholen!", vbOKOnly, "Ungültige Anfrage")
   
   Fehler = False               ' Übergabe der Fehlermeldung an Aufrufer zur Verhinderung weiterer Fehlanfragen
 End If
 Exit Function
Meldung:                       ' Fehlerbehandlung für LOGON Fehler
   MsgBox "Keine Lizenz Frei! Programm wird beendet!", vbOKOnly, "Lizenz!"
   End
End Function

Function msmParameterGet(ByVal P1 As String, ByVal P2 As String, Optional Stelle As Byte, Optional Fehler As Boolean) As String
'Funktion zum Lesen von Parameterwerten aus Globl PA
If IsEmpty(Stelle) Or Stelle = 0 Then Stelle = 2
  msmParameterGet = dbcall("S P0=$$ASCIANSI^%UML($P($G(^PA(" + FIRMA + ",340,""" + P1 + """,""" + P2 + """)),""" + tr + """," + CStr(Stelle) + ")) W:$F($ZV,""MSM"") P0")
End Function

Sub msmParameterSet(ByVal P1 As String, ByVal P2 As String, ByVal wert As String, Optional Stelle As Byte, Optional Fehler As Boolean)
'Funktion zum Lesen von Parameterwerten aus Globl PA
Dim A As String
If IsEmpty(Stelle) Or Stelle = 0 Then Stelle = 2
  A = dbcall("S $P(^PA(" + FIRMA + ",340,""" + P1 + """,""" + P2 + """),""" + tr + """," + CStr(Stelle) + ")=""" + wert + """ W:$F($ZV,""MSMS"") P0")
End Sub

Function dbcalld(ByVal command As String, ByVal tr1 As String, dat, Optional Fehler As Boolean)
    FMPass.msm_timer.Enabled = True
    Fehler = False 'Optionaler Parameter zum Auslesen ob eine Anfrage Korrekt war
    If Not connected Then
     On Error GoTo Meldung
        If servtyp = "cache" Then
           If Not cache_login Then GoTo Meldung
           FMPass.VisM1.Execute ("D MEMPOP^%SEMA(" + sema + ")")
           If FMPass.VisM1.Error <> 0 Then GoTo Meldung
          Else
           msm.Login
           connected = True
           msm.Xecute ("D MEMPOP^%SEMA(" + sema + ")")
        End If
        FMPass.msm_timer.Enabled = True
    On Error GoTo 0
    End If
    
    ndim = 0
    On Error GoTo Nochmal
     If servtyp = "cache" Then
        FMPass.VisM1.Execute (command)
        ad = FMPass.VisM1.P0
      Else
        ad = msm.Xecute(command)
     End If
    On Error GoTo 0
    N = 0
    S = ""
    For i = 1 To Len(ad)
      C = Mid(ad, i, 1)
      If C = tr1 Then
         N = N + 1
         If N > ndim Then ndim = ndim + 10: ReDim Preserve dat(ndim)
         dat(N) = S
         S = ""
       Else
         S = S + C
      End If
    Next
    If S <> "" Then
       N = N + 1
       If N > ndim Then ndim = ndim + 10: ReDim Preserve dat(ndim)
       dat(N) = S
    End If
    dbcalld = N
    lastmsm = Timer
Exit Function
Nochmal:                       ' Fehlerbehandlung bei Falscher Anfrage
 If servtyp = "cache" Then
   Fehler = True
   A = MsgBox(FMPass.VisM1.ErrorName, vbOKOnly, "Ungültige Anfrage")
   
  Else
   A = MsgBox("Ungültige Anfrage. Anfrage mit anderer Eingabe wiederholen!", vbOKOnly, "Ungültige Anfrage")
   
   Fehler = False               ' Übergabe der Fehlermeldung an Aufrufer zur Verhinderung weiterer Fehlanfragen
 End If
 Exit Function
Meldung:
  End
End Function

Sub dbtimeout()
    If Not connected Then Exit Sub
    FMPass.msm_timer.Enabled = False
    If Timer - lastmsm > timeout Then
      If servtyp = "cache" Then
        FMPass.VisM1.Execute ("D MEMPUSH^%SEMA(" + sema + ")")
        FMPass.VisM1.MServer = ""
       Else
        msm.Xecute ("D MEMPUSH^%SEMA(" + sema + ")")
        msm.Logout
      End If
      connected = False
     Else
      FMPass.msm_timer.Enabled = True
    End If
End Sub

Sub msmexit()
    If Not connected Then
      If servtyp = "cache" Then
        Call cache_login
       Else
        msm.Login
        connected = True
      End If
      FMPass.msm_timer.Enabled = True
    End If
    If servtyp = "cache" Then
       FMPass.VisM1.Execute ("K ^XWSEM(" + sema + ")")
     Else
       msm.Xecute ("K ^XWSEM(" + sema + ")")
    End If
    If Not connected Then
       If servtyp = "cache" Then
          FMPass.VisM1.MServer = ""
        Else
          msm.Logout
          connected = False
       End If
       FMPass.msm_timer.Enabled = False
    End If
End Sub

Function gf(ByVal S As String) As String
   s1 = ""
   For i = 1 To Len(S)
      C = Mid(S, i, 1)
      If C = """" Then
        s1 = s1 + """"""
       Else
        s1 = s1 + C
      End If
   Next
   gf = s1
End Function
 
Function Piece(ByVal S As String, ByVal tr As String, ByVal N As Integer, Optional Default As String) As String
If IsEmpty(Default) Or IsMissing(Default) Then Default = ""
    n1 = 1
    R = ""
    For i = 1 To Len(S)
        C = Mid$(S, i, 1)
        If C = tr Then
           n1 = n1 + 1
           If n1 = N + 1 Then Exit For
          Else
           If N = n1 Then R = R & C
        End If
    Next
    If R = "" Then R = Default
    Piece = R
End Function

Function da_msm_vb(ByVal D As String) As Date
  D = Val(D)
  Tag = D Mod 100
  mon = D \ 100 Mod 100
  jahr = (D \ 100 \ 100) + 1900
  da_msm_vb = Format(Tag) + "." + Format(mon) + "." + Format(jahr)
End Function
 
Function da_vb_msm(ByVal D As Variant) As String
  If D = -1 Then da_vb_msm = "": Exit Function
  If D = #12/31/1899# Then da_vb_msm = "": Exit Function
  If D = Null Then da_vb_msm = "": Exit Function
  If Format(D) = "" Then da_vb_msm = "": Exit Function
  tag1 = Day(D)
  mon = Month(D)
  jahr = Year(D)
  da_vb_msm = Format(jahr - 1900) + Format(mon, "00") + Format(tag1, "00")
End Function

Function realdot(ByVal S As Variant)
 Dim s1, s2 As String
 s1 = Format(S)
 s2 = ""
 For i = 1 To Len(s1)
  C = Mid(s1, i, 1)
  If C = "," Then C = "."
  If C <> " " Then s2 = s2 + C
 Next
 realdot = s2
End Function

Function CharChange(ByVal S As Variant, ByVal Suchen As String, ByVal Ersetzen As String) As String
 Dim s1, s2 As String
 Suchen = Left(Suchen, 1)
 Ersetzen = Left(Ersetzen, 1)
 s1 = S
 s2 = ""
 For i = 1 To Len(s1)
  C = Mid(s1, i, 1)
  If C = Suchen Then C = Ersetzen
  s2 = s2 + C
 Next
 CharChange = s2
End Function

Function user_anmeld() As Boolean
Dim WJUebergabe, WJAktuell As String
PERSONAL = ""

If command() <> "" Then
   FIRMA = Piece(command(), " ", 1)
   FIL = Piece(command(), " ", 2)
   WJUebergabe = Piece(command(), " ", 3)
   lpass = Piece(command(), " ", 4)
   SERVER = Piece(command(), " ", 5)
   DEV = Piece(command(), " ", 6)
   
Else
  SERVER = GetSetting("MSM Login", "Login", "Server", "Nadlinger")
  FIRMA = GetSetting("MSM Login", "Login", "Firma", "1")
  FIL = GetSetting("MSM Login", "Login", "Filiale", "0")
  lpass = PasswortChange(GetSetting("MSM Login", "Login", "Passwort", ""))
  FMPass.BSERVER = SERVER
  FMPass.BFIRMA = FIRMA
  FMPass.BFIL = FIL
  FMPass.PASSW = lpass
End If

GoSub Lesen

If PERSONAL = "" Then
           FMPass.Show 1
End If



If PERSONAL <> "" Then FMPass.msm_timer.Enabled = True
user_anmeld = (PERSONAL <> "")

Exit Function
Lesen:
erg = cacheinit(SERVER)
If servtyp <> "cache" Then
   erg = msminit(SERVER)
End If

If Not erg Then
    MsgBox "Zur Zeit sind leider keine Lizenzen frei. Versuchen Sie Ihre Anfrage in einiger Zeit noch eimal!" + Chr(13) & Chr(10) & Chr(13) & Chr(10) _
         , vbOKOnly, "Lizenzverletzung"
    user_anmeld = False
    Exit Function
End If


If lpass <> "" Then erg = dbcall("D PASS^%ONLCL0(" + FIRMA + "," + FIL + ",""" + lpass + """)")
   If Piece(erg, tr, 1) <> "" Then
    PERSONAL = Piece(erg, tr, 1)
    ACCESS = Piece(erg, tr, 2)
    PNAME = Piece(erg, tr, 3)
    WJAktuell = Piece(erg, tr, 4)
    If WJUebergabe <> "" And WJAktuell <> WJUebergabe Then
     MsgBox "Achtung: Übergebenens Wirtschaftsjahr ist ungleich akutelles Wirtschaftsjahr!", vbOKOnly, "Wanung: Wirtschaftsjahr!"
     WJ = WJUebergabe
    Else
     WJ = WJAktuell
    End If
   End If
If lpass = "" Then PERSONAL = ""
Return
End Function
 
Sub getmsmprinter(ByVal Drucker As ComboBox)
Dim Daten() As String

anz = dbcalld("D PRINTER^%ONLCL0", "@", Daten)
Drucker.Clear
ind = ""
ReDim msm_printer(anz - 1)

For i = 1 To anz
 drbez = Daten(i)
 ldev = Piece(drbez, tr, 1): drbez = Piece(drbez, tr, 2)
 Drucker.AddItem (drbez)
 msm_printer(i - 1) = ldev
 If DEV <> "" And ldev = DEV Then ind = i - 1
Next
If ind <> "" Then Drucker.ListIndex = ind

End Sub

Function PasswortChange(ByRef pw As String) As String
'Xor Sicherheit für Passwort
PasswortChange = ""
For i = 1 To Len(pw)
    v = Asc(Mid(pw, i, 1))
    v = v Xor 3
    PasswortChange = PasswortChange + Chr(v)
Next
End Function

