Attribute VB_Name = "cacheapi"
Function gf(ByVal s As String) As String
'Anführungszeichen verdoppeln
Dim s1 As String, c As String
Dim i As Byte
   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
Dim n1 As Integer, i As Integer
Dim r As String, c As String
If IsEmpty(Default) Or IsNull(Default) Or IsMissing(Default) Then Default = ""
    n1 = 1
    r = ""
    
    If s = "" Then
      Piece = ""
      Exit Function
    End If
    
    For i = 1 To Len(s)
        c = Mid$(s, i, Len(tr))
        If c = tr Then
           n1 = n1 + 1
           i = i + Len(tr) - 1
           If n1 = n + 1 Then Exit For
          Else
           If n = n1 Then r = r & Left(c, 1)
        End If
    Next
    If r = "" Then r = Default
    Piece = r
End Function

Function LastPiece(ByVal s As String, tr As String) As String
Dim i As Integer
Dim c As String
Dim r As String
    r = ""
    If s = "" Then
      LastPiece = ""
      Exit Function
    End If
    
    For i = Len(s) To 1 Step -1
        c = Mid$(s, i, 1)
        If c = tr Then Exit For
        r = c & r
    Next
    LastPiece = r
End Function

Function CountPiece(ByVal s As String, tr As String) As Long
Dim n, n1, i As Long
Dim c As String
Dim r As String
    n = 0
    If s = "" Then
      CountPiece = 0
      Exit Function
    End If
    For i = 1 To Len(s)
      c = Mid$(s, i, 1)
      If c = tr Then
         n = n + 1
      End If
    Next
    If Right(s, 1) <> tr Then n = n + 1
    
    CountPiece = n
    
End Function

Function realdot(ByVal s As Variant)
' , nach .  (Achtung keine Tausendertrennzeichen"
Dim s1 As String, s2 As String, c As String
Dim i As Byte
 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 ToNum(ByVal n As Variant) As Single
'Nummerischer Wert mit . nach , (keine Tausendertrennzeichen"
    On Error GoTo err:
 
    If n = "" Then ToNum = 0: Exit Function
    
    s = ""
    For i = 1 To Len(n)
       c = Mid(n, i, 1)
       If InStr("01234567890-+,", c) Then
            s = s & c
          ElseIf c = "." Then
            s = s & ","
       End If
    Next
    ToNum = CDec(s)
    Exit Function
    
err:
    ToNum = 0
 
End Function


Function CharChange(ByVal s As Variant, ByVal Suchen As String, ByVal Ersetzen As String, Optional MehrZeichen As Boolean) As String
Dim s1 As String, s2 As String, c As String
Dim i As Integer
 If IsMissing(MehrZeichen) Then MehrZeichen = False
 If Not MehrZeichen Then
   Suchen = Left(Suchen, 1)
   Ersetzen = Left(Ersetzen, 1)
 End If
 s1 = s
 s2 = ""
 For i = 1 To Len(s1)
  c = Mid(s1, i, Len(Suchen))
  If c = Suchen Then
     c = Ersetzen
     i = i + Len(Suchen) - 1
  Else: c = Left(c, 1)
  End If
  s2 = s2 + c
 Next
 CharChange = s2
End Function

Function user_anmeld() As Boolean
'AO am 25.10.2001
Dim objPers As CacheObject.ObjInstance
Dim objAbt As CacheObject.ObjInstance
Dim objPersonal As CacheObject.ObjInstance
Dim methode As CacheObject.ObjInstance
Dim FehlerStelle As String
Dim AbtNr As String
Dim USER As String, AnzahlUserJobs As Byte

Personal = ""
'Aufbaun des connection String + Passworteingabe erzwingen falls angegeben
If CommandParameter = "" Then CommandParameter = Command()
ConnectionString
'Anmeldung an Datenbank
 LockEIN
 On Error GoTo OnError
  FehlerStelle = "Anmeldung mit nicht existierendem Personalcode"
 Set objPers = WWS_Server.OpenId("BM.ParPersEdv", Firma + "||" + Umlaut(lpers, "GUIBAUMAT", True))
 On Error GoTo 0
'Passworkontrolle+Ergebnis
If objPers.Passwort <> lpass Or _
    objPers.AKTIV <> "J" Then  'Kontrolle ob Passwort OK und User Aktiv
  MsgBox "Passwort Falsch oder Benutzer nicht Aktiv.", vbInformation, "Anmeldung an Caché."
  PasswortFalsch = True
  ObjektMarkieren FMPass.BPASSWORT ', True
ElseIf objPers.FAJN = "N" And Standort <> DefaultStandort Then
  MsgBox "Sie dürfen die Filiale nicht verändern.", vbInformation, "Anmeldung an BAUMAT."
  PasswortFalsch = True
Else
  Personal = lpers + "|" + objPers.PNAMELogicalToODBC(objPers.PNAME) 'Alles OK ==> Ergebnis setzen
  PNAME = objPers.PNAMELogicalToODBC(objPers.PNAME)
  PNR = objPers.PNR
  AbtNr = objPers.AbtNr
  TelDW = objPers.DW
  ACCESS = objPers.BERGRP
  On Error GoTo OnError
    FehlerStelle = "Abteilungsermittlung"
    Set objAbt = WWS_Server.OpenId("BM.ParPersAbt", Firma + "||" + AbtNr)
    PABT = objAbt.ABTBEZlogicaltoodbc(objAbt.abtbez)
    PABTNR = objAbt.AbtNr
    PHABTNR = objAbt.HAbtNr
    If Berechtigung("MehrfachArbeitsplatz") = 1 Then
        lpersAbt = "s" + PABTNR
    Else
        lpersAbt = lpers
    End If
  On Error GoTo 0
  ObjektSchließen objAbt
  On Error GoTo OnError
    Fehlerstlle = "PersBasis Nummern"
    Set objPersonal = WWS_Server.OpenId("BM.PersBasis", Firma + "||" + CStr(objPers.PNR))
    TelFax = objPersonal.Fax
    Mail = objPersonal.EMailLogicalToODBC(objPersonal.EMail)
  On Error GoTo 0
  ObjektSchließen objPersonal
  ObjektSchließen objPers
  If Personal <> "" Then
     On Error GoTo OnError
       FehlerStelle = "Firma Filiale Personal Setzen"
       Set methode = WWS_Server.Static("BM.Windows")
       methode.Xecute ("S FIRMA=" + Firma + ",FIL=" + FIL + ",PERSONAL=" + """" + lpers + """")
       USER = lpersAbt
       If USER = "" Then USER = lpers
       If SysUser Then USER = UserSys
       'Aufruf für Lizenzmodell WWS $system.License.Login(PCODE)
       AnzahlUserJobs = methode.Xecute("S P0=$system.License.Login(""" & USER & """)")
       Debug.Print "JobAnzahl Cache:"; CStr(AnzahlUserJobs); " für User:"; USER
     On Error GoTo 0
     ObjektSchließen methode
     PasswortFalsch = False
     user_anmeld = True
     If AnzahlUserJobs >= MaxJobs Then
       MsgBox "Maximale JobAnzahl für Benutzer : " + USER + " erreicht!", vbCritical, App.Title + " keine Lizenz frei!"
       Ende
     End If
  End If
End If
LockAUS 'Abmelden in 30 Sekunden ohne Aktivität
  FMPass.Visible = False
  FMServer.Visible = False
 On Error Resume Next
  FMServer.Hide
  FMPass.Hide
 On Error GoTo 0
Exit Function
OnError:
  LockAUS
  On Error GoTo 0
  PasswortFalsch = True
  PasswortErforderlich = True
  user_anmeld = False
  CacheFehlermeldung err, "cacheapi.user_anmeld " & FehlerStelle
End Function

Function cacheParameterGet(ByVal Gruppe As String, ByVal Objekt As String, Optional Beschreibung As Boolean, Optional Default As Variant, Optional keineÜbersetzung As Boolean, Optional keineFehlerMeldung As Boolean) As Variant
'Lesen von Programmparametern AO am 14.12.2001
Dim obj As CacheObject.ObjInstance
LockEIN
 On Error GoTo Fehler
 Set obj = WWS_Server.OpenId("BM.ParAnwPar", Firma + "||" + Gruppe + "||" + Objekt)
 If Not Beschreibung Then
   If Not keineÜbersetzung Then
     cacheParameterGet = obj.parameterLogicalToODBC(obj.Parameter)
   Else
     cacheParameterGet = obj.Parameter
   End If
 Else
   cacheParameterGet = obj.BeschreibungLogicalToODBC(obj.Beschreibung)
 End If
 ObjektSchließen obj
 On Error GoTo 0
LockAUS
Exit Function
Fehler:
 If Not keineFehlerMeldung Then CacheFehlermeldung err, "cacheapi.cacheParameterGet Lese Parameter Gruppe " + Gruppe + " Objekt " + Objekt
 On Error GoTo 0
 cacheParameterGet = Default
LockAUS
End Function

Function CacheFehlermeldung(ByRef Fehler As ErrObject, ByVal Vorgang As String)
MsgBox "Vorgang: " + Vorgang + "." + vbCrLf + vbCrLf + _
       "Fehler: " + CStr(Fehler.Number) + vbCrLf _
       + Fehler.Description + vbCrLf + vbCrLf _
         , vbExclamation, "Caché Zugriffsfehler"
StatusText "cacheapi.CacheFehlermeldung", Vorgang, "Fehler #" + CStr(err.Number) + " " + err.Description
LockAUS True
End Function

Function cacheParameterSet(ByVal Gruppe As String, ByVal Objekt As String, ByVal Wert As Variant, Optional Beschreibung As Boolean, Optional OhneUmwandlung As Boolean)
'Schreiben von Programmparametern AO am 14.12.2001
Dim obj As CacheObject.ObjInstance
LockEIN
 On Error GoTo Fehler
 Set obj = WWS_Server.OpenId("BM.ParAnwPar", Firma + "||" + Gruppe + "||" + Objekt)
 If Not Beschreibung Then
   If Not OhneUmwandlung Then
     obj.Parameter = Umlaut(Wert, "GUIBAUMAT")
   Else
     obj.Parameter = Wert
   End If
 Else
   obj.Beschreibung = Umlaut(Wert, "GUIBAUMAT")
 End If
 obj.sys_Save ' Änderungen Speichern
 ObjektSchließen obj
 On Error GoTo 0
LockAUS
Exit Function
Fehler:
 CacheFehlermeldung err, "cacheapi.cacheParameterSet Schreibe Parameter Gruppe " + Gruppe + " Objekt " + Objekt
 On Error GoTo 0
LockAUS
End Function

Function ObjektSchließen(ByRef Objekt As Object)
'Verbindung trennen
'DoEvents
On Error GoTo Schließen
 Objekt.sys_Close
On Error GoTo 0
Schließen:
Set Objekt = Nothing
End Function

Function PasswortChange(ByRef PW As String) As String
Dim i As Byte
Dim v 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

Function Pause(ByRef PauseInHundertstelSekunden As Long, Optional TatsächlichePausenDauerInSekunden As Long)
'AOB am 15.11.2001
'Pause in 1/100 Sek mitdestpausenlänge = 0.001 Sekunden
'ACHTUNG Timer funktion Liefert vergangensekunden seit Tagesbeginn
Dim Start As Variant, b As Boolean
   Start = Timer
   Do
      Sleep 1
      DoEvents
      b = Timer - Start > (PauseInHundertstelSekunden / 100)
   Loop Until b
   TatsächlichePausenDauerInSekunden = Timer - Start
End Function

Function LockEIN(Optional CursorAus As Boolean, Optional KeineMeldung As Boolean)
  If CursorAus Then Screen.MousePointer = vbHourglass
  VerbindungEIN KeineMeldung
  FMServer.Lock.Enabled = False
  LockNumber = LockNumber + 1
End Function

Function LockAUS(Optional CursorEin As Boolean)
  If CursorEin Then Screen.MousePointer = vbDefault
  LockNumber = LockNumber - 1
  If LockNumber <= 0 Then
     FMServer.Lock.Enabled = False
  End If
End Function

Function ArchivLockEIN(Optional CursorAus As Boolean, Optional KeineMeldung As Boolean)
  If CursorAus Then Screen.MousePointer = vbHourglass
  ArchivVerbindungEIN KeineMeldung
  FMServer.ArchivLock.Enabled = False
  ArchivLockNumber = ArchivLockNumber + 1
End Function

Function ArchivLockAUS(Optional CursorEin As Boolean)
  If CursorEin Then Screen.MousePointer = vbDefault
  ArchivLockNumber = ArchivLockNumber - 1
  If ArchivLockNumber <= 0 Then
     FMServer.ArchivLock.Enabled = True
  End If
End Function


Function VerbindungEIN(Optional KeineMeldung As Boolean)
Dim i As Byte
Dim FehlermeldungErfolgt As Boolean
Dim methode As CacheObject.ObjInstance
Dim USER As String, AnzahlUserJobs As Byte
'Überprüfung Ob Serverangaben Korrect
On Error GoTo Verbinden
If WWS_Server.IsConnected Then Exit Function
On Error GoTo 0
i = 0
FehlermeldungErfolgt = False
Verbinden:
    On Error GoTo 0
    Set WWS_Server = CreateObject("CacheObject.Factory")
    If WWS_Server.Connect(ConnString) And WWS_Server.IsConnected Then
      Set methode = WWS_Server.Static("BM.Windows")
      methode.Xecute ("S FIRMA=" + Firma + ",FIL=" + FIL + ",PERSONAL=" + """" + lpers + """")
      methode.Xecute ("S ^STAND($J)=""" + Standort + """")
      USER = lpersAbt
      If USER = "" Then USER = lpers
      If USER = "" Then USER = FMPass.BUSER.Text
      If SysUser Or lpers = "" Then USER = UserAnmeldung
      'Aufruf für Lizenzmodell WWS $system.License.Login(PCODE)
       AnzahlUserJobs = methode.Xecute("S P0=$system.License.Login(""" & USER & """)")
       Debug.Print "JobAnzahl Cache:"; CStr(AnzahlUserJobs); " für User:"; USER
       On Error GoTo 0
       If AnzahlUserJobs >= MaxJobs Then
         MsgBox "Maximale JobAnzahl für Benutzer : " + USER + " erreicht!", vbCritical, App.Title + " keine Lizenz frei!"
         ObjektSchließen methode
         Ende
       End If
      methode.Xecute ("D ^%XTT")
      ObjektSchließen methode
    Else
      If Not KeineMeldung Then
        i = i + 1
        If i = 3 Then
          If Not FehlermeldungErfolgt Then
            MsgBox "Server nach 3 Versuchen nicht erreichbar!" + vbCrLf + "Wahrscheinlich sind keine freien Lizenzen verfügbar!" + vbCrLf + "Bitte Kontrollieren Sie die Verbindungsdaten", vbExclamation, "Anmeldung an Caché"
            FMServer.Show 1
            FehlermeldungErfolgt = True
            GoTo Verbinden
          Else
            MsgBox "Der Server ist nicht erreichbar!" + vbCrLf + "Wahrscheinlich sind keine Lizenzen frei. Die Anwendung wird beendet!" + vbCrLf + "Bitte Versuchen Sie die Anmeldung zu einem späteren Zeitpunk noch ein mal.", vbCritical, "Anmeldung an Caché"
            FMServer.Hide
            Personal = ""
            If WWS_Server.IsConnected Then WWS_Server.Disconnect
            FMPass.BUAusst_Click
            Exit Function
          End If
        End If
      End If
      'DoEvents
      Pause (1000)
      GoTo Verbinden
    End If
End Function

Function VerbindungAUS()
'Verbindung Trenen
LockNumber = 0
FMServer.Lock.Enabled = False
On Error GoTo aus
If WWS_Server.IsConnected Then WWS_Server.Disconnect
On Error GoTo 0
aus:
On Error GoTo 0
End Function

Function ArchivVerbindungEIN(Optional KeineMeldung As Boolean) As Boolean
Dim i As Byte
Dim FehlermeldungErfolgt As Boolean
Dim methode As CacheObject.ObjInstance
'Überprüfung Ob Serverangaben Korrect
On Error GoTo Verbinden
If Archiv_Server.IsConnected Then Exit Function
On Error GoTo 0
i = 0
FehlermeldungErfolgt = False
Verbinden:
    If ArchivConnString = "" Then
      'Am WWS_Server den zugehörigen Archivserver suchen!
      Dim rs As CacheObject.ResultSet
      LockEIN
         Set rs = WWS_Server.ResultSet("BM.KassaSW", "ArchivFuerId")
         Call rs.Execute(SERVERID, "")  'Nur Baumat Einträge anzeigen!
         rs.Next 'Es darf nur ein Eintrag vorhanden Sein
         ArchivConnString = "cn_iptcp:" + rs.GetData(2) + "[" + CStr(rs.GetData(3)) + "]:" + rs.GetData(4)
         Debug.Print "ArchivConnString:" + ArchivConnString
         ObjektSchließen rs
      LockAUS
    End If
    Set Archiv_Server = CreateObject("CacheObject.Factory")
    If Archiv_Server.Connect(ArchivConnString) And Archiv_Server.IsConnected Then
    'Bei ConcurrenUser Lizenz!!!
    '   Set methode = WWS_Server.Static("BM.Windows")
    '   methode.Xecute ("S FIRMA=" + Firma + ",FIL=" + FIL + ",PERSONAL=" + """" + lpers + """")
    '   User = lpers
    '  If User = "" Then User = FMPass.BUSER.Text
    '  If SysUser Or lpers = "" Then User = UserAnmeldung
      'Aufruf für Lizenzmodell WWS $system.License.Login(PCODE)
    '   AnzahlUserJobs = methode.Xecute("S P0=$system.License.Login(""" & User & """)")
    '   On Error GoTo 0
    '   If AnzahlUserJobs >= 11 Then
    '     MsgBox "Maximale JobAnzahl für Benutzer : " + User + " erreicht!", vbCritical, App.Title + " keine Lizenz frei!"
    '     ObjektSchließen methode
    '     Ende
    '   End If
    '  ObjektSchließen methode
    Else
      If Not KeineMeldung Then
        i = i + 1
        If i = 3 Then
          If Not FehlermeldungErfolgt Then
            MsgBox "Archiv-Server nach 3 Versuchen nicht erreichbar!" + vbCrLf + "Wahrscheinlich sind keine freien Lizenzen verfügbar!" + vbCrLf + "Bitte Kontrollieren Sie die Verbindungsdaten", vbExclamation, "Anmeldung an Caché Archiv"
            FehlermeldungErfolgt = True
            ArchivVerbindungEIN = False
            Exit Function 'Programm beenden
          End If
        End If
      End If
      'DoEvents
      GoTo Verbinden 'Wenn keineVehermeldungen immer versuchen!!!
    End If
    ArchivVerbindungEIN = True
End Function

Function ArchivVerbindungAUS()
'Verbindung Trenen
On Error Resume Next
If Archiv_Server.IsConnected Then Archiv_Server.Disconnect
On Error GoTo 0
End Function


Function ConnectionString()
Dim i As Byte
If CommandParameter <> "" Then 'Anmeldung Lesen aus Programmübergabe
   If Not IsNumeric(Piece(CommandParameter, " ", 1)) Then GoTo CommandNichtAuswertbar
   If Not IsNumeric(Piece(CommandParameter, " ", 2)) Then GoTo CommandNichtAuswertbar
   If IsNumeric(Piece(CommandParameter, " ", 3)) Or Len(Piece(CommandParameter, " ", 3)) > 3 Then GoTo CommandNichtAuswertbar
   Firma = Piece(CommandParameter, " ", 1, 1)
   FIL = Piece(CommandParameter, " ", 2, 0)
   lpers = Piece(CommandParameter, " ", 3)
   lpass = Piece(CommandParameter, " ", 4)
   SERVERIP = Piece(CommandParameter, " ", 5, "172.30.1.2")
   PORT = Piece(CommandParameter, " ", 6, "1973")
   NAMESPACE = Piece(CommandParameter, " ", 7, "BAUMAT")
   WJ = Piece(CommandParameter, " ", 8)
   DRDEV = Piece(CommandParameter, " ", 9)
   ConnString = "cn_iptcp:" + SERVERIP + "[" + PORT + "]:" + NAMESPACE
   CommandParameter = ""
   SERVERID = GetSetting("Cache Login", "Login", "ServerObjekt")
   FMServer.BFIRMA = Firma
   FMServer.BFIL = FIL
   FMServer.BSERVERIP = SERVERIP
   FMServer.BPORT = PORT
   FMServer.BNAMESPACE = NAMESPACE
   FMServer.BWJ = WJ
   FMPass.BUSER = lpers
Else 'Anmeldung Lesen aus Registry
CommandNichtAuswertbar:
  Call lesenReg
  If PasswortErforderlich Or lpass = "" Or PasswortFalsch Or lpers = "" Or FMPass.KeinDefaultEintrag Then
   If FMPass.Visible = False Then FMPass.Show vbModal   'Passwort eingabe Erzwingen
   Call lesen
  End If
End If
ConnString = "cn_iptcp:" + SERVERIP + "[" + PORT + "]:" + NAMESPACE
End Function

Sub lesen()
  If FMServer.CurrentId <> 255 And CStr(FMServer.CurrentId) <> "" And Not IsEmpty(FMServer.CurrentId) And Not IsMissing(FMServer.CurrentId) And IsNumeric(FMServer.CurrentId) Then SERVERID = CStr(FMServer.CurrentId)
  Firma = FMServer.BFIRMA.Text
  FIL = FMServer.BFIL.Text
  SERVERIP = FMServer.BSERVERIP.Text
  PORT = FMServer.BPORT.Text
  NAMESPACE = FMServer.BNAMESPACE.Text
  WJ = FMServer.BWJ.Text
  lpass = FMPass.BPASSWORT.Text
  lpers = PwTOUser(lpass)
  ConnString = "cn_iptcp:" + SERVERIP + "[" + PORT + "]:" + NAMESPACE
End Sub

Sub lesenReg(Optional nichtInFMServer As Boolean)
  SERVERID = GetSetting("Cache Login", "Login", "ServerObjekt")
    If SERVERID = "" Then FMPass.KeinDefaultEintrag = True
  SERVERIP = GetSetting("Cache Login", "Login", "Server", "172.30.1.2")
  Firma = GetSetting("Cache Login", "Login", "Firma", "1")
  FIL = GetSetting("Cache Login", "Login", "Filiale", "0")
  PORT = GetSetting("Cache Login", "Login", "Port", "1973")
  NAMESPACE = GetSetting("Cache Login", "Login", "Namespace", "BAUMAT")
  ConnString = "cn_iptcp:" + SERVERIP + "[" + PORT + "]:" + NAMESPACE
  WJ = dbcall("S P0=$P(^FA(0)," + """" + "`" + """" + ",2) W P0")
  If Not nichtInFMServer Then
    lpers = GetSetting("Cache Login", "Login", "Name", "")
    If PasswortErforderlich = False Then
       lpass = FMPass.BPASSWORT.Text
       lpass = PasswortChange(GetSetting("Cache Login", "Login", "Passwort", ""))
       FMPass.BPASSWORT.Text = lpass
       lpers = PwTOUser(lpass)
       FMPass.BUSER.Text = lpers
    End If
    FMServer.BFIRMA.Text = Firma
    FMServer.BFIL.Text = FIL
    FMServer.BSERVERIP.Text = SERVERIP
    FMServer.BPORT.Text = PORT
    FMServer.BNAMESPACE.Text = NAMESPACE
    FMServer.BWJ.Text = WJ
    FMPass.BUSER.Text = lpers
  End If
End Sub


Function da_msm_vb(ByVal D As String) As Date
Dim Tag As Integer, Mon As Integer, Jahr As Integer
  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
Dim Tag1 As Integer, Mon As Integer, Jahr As Integer
  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 D = "  .  ." 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

Sub Ende()
Dim i As Integer
' Forms-Auflistung durchlaufen und jedes Formular entladen.
   StatusText "cacheapi.Ende", "Start ENDE"
   For i = (Forms.Count) - 1 To 0 Step -1
     'Debug.Print Forms(i).Caption
     On Error Resume Next
      Debug.Print Forms(i).Caption
      Debug.Print Forms(i).Name
      Unload Forms(i)
     On Error GoTo 0
   Next
   StatusText "cacheapi.Ende", "Ende ENDE", "es folgt end"
   End
End Sub

Function Einheitumwandeln(ByVal Einheit As String) As String
Dim obj As CacheObject.ObjInstance
 Select Case Einheit
    Case "CBM": Einheitumwandeln = "m³"
    Case "CM": Einheitumwandeln = "cm"
    Case "M": Einheitumwandeln = "lfm"
    Case "ML": Einheitumwandeln = "mm"
    Case "QM": Einheitumwandeln = "m²"
    Case "ST": Einheitumwandeln = "Stk."
    Case "KG": Einheitumwandeln = "kg"
    Case Else
      LockEIN
      On Error Resume Next
       Set obj = WWS_Server.OpenId("BM.ParEinh", Firma + "||" + Einheit)
       err.Clear
      On Error GoTo EinheitNichtVorhanden
       Einheitumwandeln = obj.NameLogicalToODBC(obj.Name) 'Per
      On Error GoTo 0
      ObjektSchließen obj
      LockAUS
 End Select
Exit Function
EinheitNichtVorhanden:
 Einheitumwandeln = Einheit
 CacheFehlermeldung err, "Das Einheitenkürzel " + Einheit + " kann nicht in Klartext übersetzt werden"
 ObjektSchließen obj
 LockAUS
End Function


Function dbcall(ByVal Command As String, Optional Fehler As Boolean, Optional KeineMeldung As Boolean) As String
Dim methode As CacheObject.ObjInstance
LockEIN
   On Error GoTo FehlerMeldung
     Set methode = WWS_Server.Static("BM.Windows")
     dbcall = methode.Xecute(Command)
     ObjektSchließen methode
   On Error GoTo 0
LockAUS
Exit Function
FehlerMeldung:
 LockAUS
 Fehler = True
 On Error GoTo 0
 If Not KeineMeldung Then CacheFehlermeldung err, "cacheapi.dbcall Ungültige Anfrage! Kein Ergebnis gefunden" + vbCrLf + vbCrLf + _
                                                  "DBCall Aufruf von BM.Windwos Xecute " + Command
 StatusText "dbCall", "Command_:" & Command, err.Description
 dbcall = " "
End Function

Function dbGet(ByVal Command As String, Optional Fehler As Boolean) As String
Dim methode As CacheObject.ObjInstance
LockEIN
   On Error GoTo FehlerMeldung
     Set methode = WWS_Server.Static("GUI.db")
     dbGet = methode.dbGet(Command)
     ObjektSchließen methode
   On Error GoTo 0
LockAUS
Exit Function
FehlerMeldung:
 Fehler = True
 LockAUS
 On Error GoTo 0
 CacheFehlermeldung err, "cacheapi.dbget Ungültige Anfrage! Kein Ergebnis gefunden" + vbCrLf + vbCrLf + _
                         "DBGet Aufruf von GUI.db dbGet " + Command
 StatusText "dbGet", "Command_:" & Command, err.Description
 dbGet = " "
End Function

Function dbcalld(ByVal Command As String, ByVal tr1 As String, dat, Optional Fehler As Boolean)
Dim ndim As Integer, n As Integer, i As Integer
Dim ad As String, s As String, c As String
Dim methode As CacheObject.ObjInstance
    ndim = 0
LockEIN
    On Error GoTo FehlerMeldung
      Set methode = WWS_Server.Static("BM.Windows")
      ad = methode.Xecute(Command)
      ObjektSchließen methode
    On Error GoTo 0
LockAUS
    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
Exit Function
FehlerMeldung:                       ' Fehlerbehandlung bei Falscher Anfrage
 Fehler = True
 LockAUS
 On Error GoTo 0
 CacheFehlermeldung err, "cacheapi.dbcalld Ungültige Anfrage! Kein Ergebnis gefunden" + vbCrLf + vbCrLf + _
                         "DBCallD Aufruf von BM.Windwos Xecute " + Command
 StatusText "dbCalld", "Command_:" & Command, err.Description
 dat = " "
End Function

Function Umlaut(ByVal Text As String, ByVal Umwandlungsart As String, Optional Grosschreibung As Boolean) As String
If IsMissing(Grosschreibung) Then Grosschreibung = True
Umlaut = Text
If Grosschreibung Then Umlaut = Format(Umlaut, ">")
Select Case Umwandlungsart
 Case "RTF" ' RTF Umlautumwandlung
  Umlaut = CharChange(Umlaut, "ä", "\'e4", True)
  Umlaut = CharChange(Umlaut, "ö", "\'f6", True)
  Umlaut = CharChange(Umlaut, "ü", "\'fc", True)
  Umlaut = CharChange(Umlaut, "ß", "\'df", True)
  Umlaut = CharChange(Umlaut, "Ä", "\'C4", True)
  Umlaut = CharChange(Umlaut, "Ö", "\'d6", True)
  Umlaut = CharChange(Umlaut, "Ü", "\'dc", True)
 Case "BAUMATSUCHE" 'Baumat Umlautumwandlung
  Umlaut = CharChange(Umlaut, "ß", "SS", True)
  Umlaut = CharChange(Umlaut, "Ä", "AE", True)
  Umlaut = CharChange(Umlaut, "Ö", "OE", True)
  Umlaut = CharChange(Umlaut, "Ü", "UE", True)
 Case "BAUMAT"
  Umlaut = CharChange(Umlaut, "{", "ä", False)
  Umlaut = CharChange(Umlaut, "|", "ö", False)
  Umlaut = CharChange(Umlaut, "}", "ü", False)
  Umlaut = CharChange(Umlaut, "~", "ß", False)
  Umlaut = CharChange(Umlaut, "[", "Ä", False)
  Umlaut = CharChange(Umlaut, "\", "Ö", False)
  Umlaut = CharChange(Umlaut, "]", "Ü", False)
  Umlaut = CharChange(Umlaut, "õ", "§", False)
 Case "BAUMATSZ"
  Umlaut = CharChange(Umlaut, "{", "ä", False)
  'Umlaut = CharChange(Umlaut, "|", "ö", False)
  Umlaut = CharChange(Umlaut, "}", "ü", False)
  Umlaut = CharChange(Umlaut, "~", "ß", False)
  Umlaut = CharChange(Umlaut, "[", "Ä", False)
  'Umlaut = CharChange(Umlaut, "\", "Ö", False)
  Umlaut = CharChange(Umlaut, "]", "Ü", False)
  Umlaut = CharChange(Umlaut, "õ", "§", False)
 Case "GUIBAUMAT"
  Umlaut = CharChange(Umlaut, "ä", "{", False)
  Umlaut = CharChange(Umlaut, "ö", "|", False)
  Umlaut = CharChange(Umlaut, "ü", "}", False)
  Umlaut = CharChange(Umlaut, "ß", "~", False)
  Umlaut = CharChange(Umlaut, "Ä", "[", False)
  Umlaut = CharChange(Umlaut, "Ö", "\", False)
  Umlaut = CharChange(Umlaut, "Ü", "]", False)
  Umlaut = CharChange(Umlaut, "§", "õ", False)

End Select
End Function

Function Prüfziffer(ByRef EAN As String, Optional RückgabeIstNichtGanzerEAN As Boolean) As String
Dim PZ As Variant
Dim i As Integer, j As Integer
On Error GoTo Fehler
PZ = 0
j = 0
For i = Len(EAN) To 1 Step -1
 j = j + 1
 PZ = (((((j Mod 2) * 2) + 1) * CDec(Mid(EAN, i, 1))) + PZ)
Next
PZ = 10 - (PZ Mod 10)
If PZ = 10 Then PZ = 0
Prüfziffer = EAN + CStr(PZ)
If RückgabeIstNichtGanzerEAN Then Prüfziffer = PZ
Exit Function
Fehler:
Prüfziffer = 0
End Function

Sub ObjektMarkieren(ByRef Objekt As Object, Optional notfocus As Boolean)
With Objekt
 .SelStart = 0
 .SelLength = Len(.Text)
 If Not notfocus Then .SetFocus
End With
End Sub

Public Sub StatusText(Optional Programmteil As String, Optional Text As String, Optional Parameter As String, Optional LogLevel As Byte)
Dim Datei
 On Error Resume Next:
  If Val(LogLevel) <= 254 Then frmProgrammverlauf.Verlauf.InsertItem Programmteil + ";" + Text + ";" + Parameter, 0
  frmProgrammverlauf.Verlauf.RemoveItem 100
 On Error GoTo 0
 On Error GoTo NichtSchreiben
  If FMStart.mProgrammverlauf(Verlauf.Schreiben).Checked And LogEin And Val(LogLevel) <= Val(MaxLogLevel) Then
     Datei = FreeFile
     Open Environ("Temp") + "\" + App.Title + ".nlt" For Append As #Datei
     Write #Datei, Format(Now, "DD.MM.YY HH:NN:SS.MS") & ";" & Programmteil + ";" + Text + ";" + Parameter + ";" + CStr(LogLevel)
     Close #Datei
  End If
NichtSchreiben:
 On Error GoTo 0
End Sub

Public Function Periode(ByVal StartPeriode As String, ByVal PlusMinus As String) As String
Dim Jahr As Variant
Dim Monat As Variant

Monat = Right(StartPeriode, 2)
Jahr = Left(StartPeriode, Len(StartPeriode) - 2)

Monat = Val(Monat) + PlusMinus

If Monat > 12 Then
  Monat = Monat - 12
  Jarhr = Jahr + 1
ElseIf Monat < 1 Then Monat = Monat + 12
  Jahr = Jahr - 1
End If
  Periode = CStr(Jahr) + Format(Monat, "00")
End Function

Public Function Berechtigung(Optional SubProgramm As String, Optional Personal As String) As Integer
StatusText "cacheapi.Berchtigung", "Start"
If IsEmpty(SubProgramm) Or SubProgramm = "" Then SubProgramm = "alles"
If IsEmpty(Personal) Or Personal = "" Then Personal = lpers
    Dim methode As CacheObject.ObjInstance
    LockEIN
       Set methode = WWS_Server.Static("UserVerwaltung.Programm")
       Berechtigung = methode.Berechtigung(Personal, App.Title, SubProgramm)
       ObjektSchließen methode
    LockAUS
StatusText "cacheapi.Berchtigung", "Ende"
End Function

Public Function BerechtigungM(ByVal ErforderlicheStufe As Integer, ByVal FehlerMeldung As String, Optional SubProgramm As String, Optional Personal As String) As Boolean
StatusText "cacheapi.BerchtigungM", "Start"
  If Berechtigung(SubProgramm, Personal) < ErforderlicheStufe Then
     MsgBox "Zugriff auf : " & FehlerMeldung & " verweigert!" & vbCrLf & "Berechtigung zu gering!", vbCritical
     BerechtigungM = False
  Else
     BerechtigungM = True
  End If
StatusText "cacheapi.BerchtigungM", "Ende"
End Function

Function PwTOUser(ByVal PW As String) As String
Const PCODE As Byte = 1
Dim rs As CacheObject.ResultSet
    LockEIN
    On Error Resume Next
      Set rs = WWS_Server.ResultSet("BM.ParPersEdv", "UserViaPasswort")
      Call rs.Execute(PW, Firma, "")
      rs.Next
      PwTOUser = Umlaut(rs.GetData(PCODE), "BAUMAT")
      ObjektSchließen rs
    On Error GoTo 0
    LockAUS
End Function

Function PnrTOUser(ByVal PNR As String) As String
Const PNAME As Byte = 1
Dim rs As CacheObject.ResultSet
    LockEIN
    On Error Resume Next
      Set rs = WWS_Server.ResultSet("BM.ParPersEdv", "UserViaPNR")
      Call rs.Execute(PNR, Firma, "")
      rs.Next
      PnrTOUser = Umlaut(rs.GetData(PNAME), "BAUMAT")
      ObjektSchließen rs
    On Error GoTo 0
    LockAUS
End Function

Function PnrTOPcode(ByVal PNR As String) As String
 PnrTOPcode = PnrTOUser(PNR)
End Function

Function Schaltjahr(Jahreszahl)
If (Jahreszahl Mod 4) = 0 And (Jahreszahl Mod 100) <> 0 Or _
((Jahreszahl Mod 400) = 0) Or ((Jahreszahl Mod 500) = 0) Then
Schaltjahr = True
Else
Schaltjahr = False
End If
End Function

Function TageImMonat(ByVal Monat As Byte, Optional Jahr As Integer) As Byte
If IsMissing(Jahr) Then Jahr = Format(Date, "YYYY")
Select Case Monat
  Case 1: TageImMonat = 31
  Case 2:
          If Schaltjahr(Jahr) Then
            TageImMonat = 29
          Else
            TageImMonat = 28
          End If
  Case 3: TageImMonat = 31
  Case 4: TageImMonat = 30
  Case 5: TageImMonat = 31
  Case 6: TageImMonat = 30
  Case 7: TageImMonat = 31
  Case 8: TageImMonat = 31
  Case 9: TageImMonat = 30
  Case 10: TageImMonat = 31
  Case 11: TageImMonat = 30
  Case 12: TageImMonat = 31
  Case Else: MsgBox "Cacheapi.TageImMonat Case: Programmierter Fehler", vbCritical: TageImMonat = 0
End Select
End Function
