Attribute VB_Name = "AOBStandard"
Option Explicit

Public Enum InhaltArt
  PCODE = 0
End Enum

Public Enum WertArt
  Default = 0
  Vorgabe = 1
End Enum

Public Enum ParaArt
  ParaName = 0
  ParaArt = 1
  ParaBesch = 2
  ParaMöglichkeiten = 3
  paraDefault = 4
End Enum

Public Enum ArtKKR
  Kunde = 0
  Lieferant = 1
End Enum

Const MODULE_NAME As String = "modMail"

Public Const StartPort As Integer = 7168
Public Const EndPort As Integer = 8167

Public Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
Public Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long

 
Public Const INFINITE = &HFFFF      '  Infinite timeout
Public Const SYNCHRONIZE = &H100000

Private Const MAX_PATH As Long = 260&

Private Declare Function GetShortPathName Lib "kernel32" Alias _
"GetShortPathNameA" ( _
    ByVal lpszLongPath As String, ByVal lpszShortPath As String, _
    ByVal cchBuffer As Long) As Long

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
        "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation _
        As String, ByVal lpFile As String, ByVal lpParameters _
        As String, ByVal lpDirectory As String, ByVal nShowCmd _
        As Long) As Long
 
Public Sub wait(ByVal id As Long)
   Dim process_handle As Long
   process_handle = OpenProcess(SYNCHRONIZE, 0, id)
    If process_handle <> 0 Then
        WaitForSingleObject process_handle, INFINITE
        CloseHandle process_handle
    End If
End Sub

Function NichtZiffernLöschen(ByVal s As String, Optional ZusätzlichErlaubt As Variant) As String
' AOB am 27.03.01 Stringvormatierung
' Alle nicht nummerischen Zeichen aus einem String löschen!
' AOB am 06..08.01 Rückgabe von 0 bei Leerstring
Dim s1  As String, s2  As String, c As String
Dim i As Integer
Dim Komma As Boolean
If IsMissing(ZusätzlichErlaubt) Then ZusätzlichErlaubt = ""
 s1 = s
 s2 = ""
 For i = 1 To Len(s1)
  c = Mid(s1, i, 1)
  Select Case c '= Suchen Then C = Ersetzen
   Case "0", "1", "2", "3", "4", "5", "6", "7", "8", "9"
   Case ","
    If Komma = True Then c = ""  'Nur ein Komman Zulassen
    Komma = True
   Case "%"
    If i = Len(s1) Then  '% Nur am Ende Zulassen
     c = "%"
    Else
     c = ""
    End If
   Case "-"
    If i <> 1 Then c = "" 'Minus nur an Erste Stelle erlauben
    If i = 1 And Len(s1) = 1 Then c = "-"
   'Case else mit instr
  End Select
  If InStr("0123456789,%-" & ZusätzlichErlaubt, c) = 0 Then c = ""  'Zusäzlich erlaube Zechen überwachen
  s2 = s2 + c
 Next
 If s = "" Then s2 = "0"  'Nummerischen Rückgabewert erforderlich!
 NichtZiffernLöschen = s2
End Function

Function NichtTextLöschen(ByVal s As String, Optional ZusätzlichErlaubt As Variant) As String
' AOB am 30.04.03 Stringvormatierung
' Alle nicht Text Zeichen aus einem String löschen!
Dim s1  As String, s2  As String, c As String
Dim i As Integer
 If IsMissing(ZusätzlichErlaubt) Then ZusätzlichErlaubt = ""
 s1 = s
 s2 = ""
 For i = 1 To Len(s1)
  c = Mid(s1, i, 1)
  If InStr("abcdefghijklmnopqrstuvwxyzäöüABCDEFGHIJKLMNOPQRSTUVWXYZÄÖÜß " & ZusätzlichErlaubt, c) Then s2 = s2 + c
 Next
 NichtTextLöschen = s2
End Function

Function FührendeLeerzeichenLöschen(ByVal s As String) As String
' AOB am 30.04.04 Stringvormatierung
' Alle führenden Leerzeichen Löschen
Dim s1  As String
Dim i As Integer
 s1 = s
 Do
  If Left(s1, 1) = " " Then s1 = Right(s1, Len(s1) - 1)
 Loop Until Left(s1, 1) <> " "
 FührendeLeerzeichenLöschen = s1
End Function

Function FolgendeLeerzeichenLöschen(ByVal s As String) As String
' AOB am 30.04.04 Stringvormatierung
' Alle führenden Leerzeichen Löschen
Dim s1  As String
Dim i As Integer
 s1 = s
 Do
  If Right(s1, 1) = " " Then s1 = Left(s1, Len(s1) - 1)
 Loop Until Right(s1, 1) <> " "
 FolgendeLeerzeichenLöschen = s1
End Function


Function FileNameTauglich(ByVal s As String, Optional ByVal Ersetzen As String) As String
' AOB am 6.02.02 Stringvormatierung
' Alle nicht Filenametauglichen  Zeichen aus einem String löschen!
Dim s1  As String, s2  As String, c As String
Dim i As Integer
If IsMissing(Ersetzen) Then Ersetzen = ""
 s1 = s
 s2 = ""
 For i = 1 To Len(s1)
  c = Mid(s1, i, 1)
  Select Case c '= Suchen Then C = Ersetzen
   Case "\", "/", ":", "*", "?", """", "<", ">", "|", "."
     c = Ersetzen
  End Select
  s2 = s2 + c
 Next
 If s = "" Then s2 = ""
 FileNameTauglich = s2
End Function

Function Formatierung(ByVal Anzeige As Object, Wert As Variant)
Dim a As String
With Anzeige
  If Right(Wert, 1) <> "%" Then
    a = (Wert * 100 - Fix(Wert) * 100)
    If a <> 0 Then
      .Text = Format(Wert, "##,###,##0.00")
    Else
      .Text = Format(Wert, "##,###,##0.-")
    End If
  Else
    Wert = Left(Wert, Len(Wert) - 1)
    a = (Wert * 100 - Fix(Wert) * 100)
    If a <> 0 Then
      .Text = Format(Wert, "##0.00\%")
    Else
      .Text = Format(Wert, "##0\%")
    End If
  End If
End With
End Function

Function Formatierung1(Wert As Variant) As String
Dim a As String
If Not IsNumeric(Wert) Then Exit Function
    a = (Wert * 100 - Fix(Wert) * 100)
    If a <> 0 Then
      Formatierung1 = Format(Wert, "##,###,##0.00")
    Else
      Formatierung1 = Format(Wert, "##,###,##0.-")
    End If
End Function

Function FormatierungHagebau(Wert As Variant) As String
Dim a As String
Wert = CharChange(Wert, ".", "")
Wert = CharChange(Wert, "-", "")
If Not IsNumeric(Wert) Then Exit Function
    a = (Wert * 100 - Fix(Wert) * 100)
    If a <> 0 Then
      FormatierungHagebau = CharChange(Format(Wert, "#0.00"), ",", ".")
    Else
      FormatierungHagebau = CharChange(Format(Wert, "#0.-"), ",", ".")
    End If
End Function


Function EingabePruefen(G1 As Variant, G2 As Variant, Objekt As Object, Optional Grenzen As Boolean, Optional Fehler As Boolean)
' AOB 27.03.01 Eingabeobjekt verändern
' Benutzereingabefehler in ein Nummerisches Eingabefeld verhindern!
' Achtung , wird als Komma interpretiert ==> Vorsicht bei Datenbankwerten!!!!
' G1 erster Wert entweder OG oder Vorkommastellen abhängig von Grenzen
' G2 zweiter Wert entweder UG oder Nachkommastellen abhängig von Grenzen
' Objekt übergebens Eingabefeld
' Grenzen wenn True dann interpretation von G1 und G2 als Grenzen
' Fehler für die wird True wenn G1 oder G2 verletzt

Dim Wert As String

Fehler = False
Dim obj As String

On Error GoTo ObjectFix
    obj = Objekt.Text
    Wert = NichtZiffernLöschen(obj) 'Nummerisches Feld!!
On Error GoTo 0
If Wert = "" Then Exit Function
If Wert = "-" Then Exit Function
If Wert = "," Then Exit Function
Objekt.Text = Wert
If Grenzen = False Then
  With Objekt
    If Len(CStr(Round(CDec(Wert), 0))) > G1 Then
       MsgBox "Zu viele Vorkommastellen Eingegeben!" + vbCrLf + "Maximal Erlaubt sind : " + CStr(G1), vbOKOnly, "Fehler Wertgrenzen Überschritten!"
       '.SetFocus
       .SelStart = 0
       .SelLength = Len(.Text)
       Fehler = True
    End If
    If Round(CDec(Wert), G2) <> CDec(.Text) Then
       MsgBox "Zu viele Nachkommastellen Eingegeben!" + vbCrLf + "Maximal Erlaubt sind : " + CStr(G2), vbOKOnly, "Fehler Wertgrenzen Überschritten!"
       .SetFocus
       .SelStart = 0
       .SelLength = Len(.Text)
       Fehler = True
    End If
  End With
Else
  With Objekt
    If Val(Wert) > G1 Then
       MsgBox "Wert zu groß eingegeben!" + vbCrLf + "Größter erlaubter Wert : " + CStr(G1), vbOKOnly, "Fehler Wertgrenzen Überschritten!"
       .SetFocus
       .SelStart = 0
       .SelLength = Len(.Text)
       Fehler = True
    End If
    If Val(Wert) < G2 Then
       MsgBox "Wert zu klein eingegeben!" + vbCrLf + "Kleinster erlaubter Wert : " + CStr(G2), vbOKOnly, "Fehler Wertgrenzen Überschritten!"
       .SetFocus
       .SelStart = 0
       .SelLength = Len(.Text)
       Fehler = True
    End If
  End With
End If
Exit Function
ObjectFix:
  obj = Objekt 'Nummerisches Feld!!
  Resume
End Function


Function EANtoArtNr(ByVal Nummer As Object)
Dim lanr As String, lean As String, anr1 As String
Dim obj As CacheObject.ObjInstance
Dim Fehler As Boolean
 lanr = LTrim(RTrim(Nummer.Text))
   Select Case Len(lanr)
    Case 1 To 6
    Case 8, 13
      lean = lanr
      If Left(lean, 2) = "20" Then
       lanr = Mid(lean, 3, 6)
      Else
       LockEIN
        On Error Resume Next
         Set obj = WWS_Server.Static("BM.ArtMaEan")
         anr1 = obj.GetArtNr(Firma, lean)
        On Error GoTo 0
        err.Clear
        ObjektSchließen obj
       LockAUS
       If anr1 = "" Then
         Call MsgBox("EAN nicht gefunden", vbOKOnly, "Fehler")
         Nummer.SetFocus
         Exit Function
       End If
       lanr = anr1
      End If
    Case 0
      Exit Function
    Case Else
      MsgBox "Art.-Nr/EAN kann nur 6,8 oder 13-stellig sein", vbOKOnly, Fehler
      Nummer.SetFocus
      Exit Function
   End Select
   Nummer.Text = Format(Val(lanr))
End Function

Function AnwendungAufrufen(ByVal FILE As String, ByVal Extension As String, Optional OhneExtension As Boolean, Optional Modal As Boolean)
Dim AnwendungsName As String
Dim Aufruf As String
Dim AusführbarerAufruf As String
Dim strKey As String
Dim r As New clsRegistry
Dim i As Integer
Dim Path As String

  'With r
  '  .Key = "HKCR\." + Extension + "\"
  '  If Not .KeyExists Then GoTo KeineAnwendungVerbunden
  '  AnwendungsName = .getValue
  'End With
  'With r
  '  .Key = "HKCR\" + AnwendungsName + "\Shell\Open\command\"
  '  If Not .KeyExists Then GoTo KeineAnwendungVerbunden
  '  Aufruf = .getValue
  'End With
  'For i = 1 To Len(Aufruf)
  '  AusführbarerAufruf = AusführbarerAufruf + mID(Aufruf, i, 1)
  '  If i > 1 And (mID(Aufruf, i, 1) = Chr(34) Or mID(Aufruf, i, 1) = "%") Then Exit For
  'Next
  'If Left(AusführbarerAufruf, 1) <> Chr(34) Or Right(AusführbarerAufruf, Len(AusführbarerAufruf) - 1) = "%" Then AusführbarerAufruf = Left(AusführbarerAufruf, Len(AusführbarerAufruf) - 1)
  'If Not OhneExtension Then
  '  AusführbarerAufruf = AusführbarerAufruf + " " + Chr(34) + FILE + "." + Extension + Chr(34)
  'Else
  '  AusführbarerAufruf = AusführbarerAufruf + " " + Chr(34) + FILE + Chr(34)
  'End If
   
   Path = Space(MAX_PATH)
   Call GetShortPathName(FILE & "." & Extension, Path, MAX_PATH)
    
  If Not Modal Then
    'Weiter nach Aufruf
   ' Shell AusführbarerAufruf, vbNormalFocus
    Call ShellExecute(0, "Open", Path, "", Piece(FILE, "\", 1), 1)
  Else
    'Warten auf Programmende
    'Call wait(Shell(AusführbarerAufruf, vbNormalFocus))
    Call wait(ShellExecute(0, "Open", Path, "", Piece(FILE, "\", 1), 1))
  End If
  
Exit Function
KeineAnwendungVerbunden:
  MsgBox "Mit diesem Filetype ist keine Anwendung verbunden", vbCritical, "Anwendungsaufrauf?"
End Function

Public Sub DokumentAnArchiv(BelArt As String, Belnr As String, datum As String, KKR As String, _
                            konto As String, Status As String, Zeit As String, Match As String, _
                            FileJN As String, FILE As String, linkbelart As String, linkbelnr As String, _
                            Text As String, LinkBelDatum As String, Personal As String, _
                            DokTyp As String, DokOverwrite As String, Baustelle As String, _
                            Dok1FileName As String, Dok1Type As String, Dok1ZipJN As String, _
                            Optional LinkBelIndex As String, Optional Passwort As String)
Dim methode As CacheObject.ObjInstance
Dim Bezug As String, Beleg As String, Texte As String, Dok As String, Link As String, Dok1 As String
StatusText "AOBStandard.DokumentAnArchiv", "Start"
If Personal = "" Then Personal = lpers
If Personal = "" Then Personal = "AOB"

If Left(konto, 2) = "0:" And Len(konto) > 3 Then  'Überprüfung ob KNR oder LNR eingegeben aber AnzeigeReihenfolge falsch!
   KKR = Piece(KKR, ":", 2) & ":" & Piece(KKR, ":", 1)
   konto = Piece(konto, ":", 2) & ":" & "0"
ElseIf konto = "0:0" Then                         'Überprügung ob KNR und LNR nicht eingegeben
   If Piece(KKR, ":", 1) = "K" Then
     konto = "99999:0"                            'Abhängig von AnzeigeReihenfolge DefaultNR eingeben
   Else
     konto = "88888:0"
   End If
End If
  
Bezug = Firma & "|" & KKR & "|" & konto & "|" & Personal & "|" & Baustelle
Beleg = BelArt & "|" & Belnr & "|" & Status
Texte = Match & "|" & Text
Dok = FileJN & "|" & FILE & "|" & DokTyp & "|" & DokOverwrite
If LinkBelDatum = "" Then LinkBelDatum = 0
Link = linkbelart & "|" & linkbelnr & "|" & LinkBelDatum & "|" & LinkBelIndex
Dok1 = Dok1FileName & "|" & Dok1Type & "|" & Dok1ZipJN

    LockEIN
       On Error GoTo Fehler
         Set methode = WWS_Server.Static("AR.Dokumente")
         methode.SetDokument Bezug, Beleg, Texte, Dok, Link, Dok1, datum, Zeit, Passwort
       On Error GoTo 0
       ObjektSchließen methode
    LockAUS
StatusText "AOBStandard.DokumentAnArchiv", "Ende"
Exit Sub
Fehler:
    LockAUS
    CacheFehlermeldung err, "AOBStandard.DokumentAnArchiv"
    On Error GoTo 0
    StatusText "AOBStandard.DokumentAnArchiv", "Ende mit Fehler"
End Sub

Public Function NameKKR(ByVal KontoKreis As Byte) As String
  Dim KKRNamen
  KKRNamen = Array("K", "L")
  NameKKR = KKRNamen(KontoKreis)
End Function

Public Function NummerKKR(KontoKreis As String) As Byte
 Select Case KontoKreis
    Case "K":   NummerKKR = 0
    Case "L":   NummerKKR = 1
 End Select
End Function

Public Function GetPort(ByVal Name As String) As String
Dim Basis As Integer
Dim objPers As CacheObject.ObjInstance
Dim zw As String, zw1 As String

On Error GoTo Fehler
If IsNumeric(Name) Then
  'Personalnummer wurde übergeben
  Basis = StartPort
  GoTo ADD
End If
  'Personalcode übergeben oder Abteilungsnummer übergeben
  Basis = StartPort
  LockEIN
  Set objPers = WWS_Server.OpenId("BM.ParPersEdv", Firma + "||" + Umlaut(Name, "GUIBAUMAT", True))
  Name = objPers.PNR
  LockAUS
ADD:
  GetPort = Basis + Val(Name)
On Error GoTo 0
Exit Function
Fehler:
  On Error GoTo 0
  GetPort = EndPort
End Function

Function UserViaPasswort() As String
Dim frage As New frmFrage, AntwortID As String
Dim rs As CacheObject.ResultSet
  frage.Setzen "Baumat Passwort?", "Geben Sie Ihr Baumat Passwort ein:", True
  AntwortID = frage.Antwort
  If AntwortID <> "$$ABBRUCH$$" And AntwortID <> "" Then
    FMPass.BPASSWORT.Text = AntwortID
    LockEIN
     On Error GoTo Fehler
      Set rs = WWS_Server.ResultSet("BM.ParPersEdv", "UserViaPasswort")
      Call rs.Execute(AntwortID, Firma, "")
      rs.Next
     On Error GoTo 0
      UserViaPasswort = Umlaut(rs.GetData(1), "BAUMAT")  'PERSCODE
      ObjektSchließen rs
    LockAUS
  End If
  Unload frage
Exit Function
Fehler:
  LockAUS
  CacheFehlermeldung err, "AOBStandard.UserViaPasswort"
  On Error GoTo 0
End Function

Function userGetIH(ByVal PNR As String) As Byte
Dim obj As CacheObject.ObjInstance
  LockEIN
   On Error GoTo Fehler
    Set obj = WWS_Server.Static("BM.PersZeiterfassung")
   On Error GoTo 0
    userGetIH = obj.GetIH(Firma, PNR)
    ObjektSchließen obj
  LockAUS
Exit Function
Fehler:
  LockAUS
  CacheFehlermeldung err, "AOBStandart.Anwesend"
  On Error GoTo 0
End Function

Public Sub getWindowPos(ByRef window As Object)
Dim dh As Byte
Dim Anw As String
Dim ws As Integer
Dim Left As Long, Top As Long, Width As Long, Height As Long
StatusText "AOBStandard.getWindowPos", "Start", window.Name, LL.Wichtig
Debug.Print window.Name
    dh = 0
    'If (Screen.Width / Screen.Height) > 16 / 10 Then dh = 1
 Anw = App.Title + "\Environ\" + CStr(dh)
 If window.WindowState = vbMinimized Or window.WindowState = vbMaximized Then
    StatusText "AOBStandard.getWindowPos", "Ende Minimiert oder Maximiert", window.Name, LL.Wichtig
    Exit Sub
 Else
    'Feststellen welche auflösung vorliegt
    Left = GetSetting(Anw, window.Name, "Left", window.Left)
    While Left > Screen.Width
        Left = Left - Screen.Width
    Wend
    If Left < 0 Then Left = 0
    Top = GetSetting(Anw, window.Name, "Top", window.Top)
    If Top > Screen.Height Then Top = 0
    Width = GetSetting(Anw, window.Name, "Width", window.Width)
    If Width > Screen.Width Then Width = Screen.Width
    Height = GetSetting(Anw, window.Name, "Height", window.Height)
    If Height > Screen.Height Then Height = Screen.Height
  End If
  If Left <> window.Left Then window.Left = Left
  If Top <> window.Top Then window.Top = Top
  If Width > window.Width Then window.Width = Width
  If Height > window.Height Then window.Height = Height
  ws = GetSetting(Anw, window.Name, "WindowState", 0)
  If TypeOf window Is MDIForm And ws <> vbNormal Then window.WindowState = ws
  If Not (TypeOf window Is MDIForm) Then
    If ws <> vbNormal And window.BorderStyle = 2 And window.MaxButton = True And window.MinButton = True Then window.WindowState = ws
  End If
StatusText "AOBStandard.getWindowPos", "Ende", window.Name, LL.Wichtig
End Sub

Public Sub setWindowPos(ByRef window As Object)
Dim dh As Byte
Dim Anw As String
StatusText "AOBStandard.setWindowPos", "Start", window.Name, LL.Wichtig
dh = 0
    'If Optionen(Opt.EinSchirm) = False And ((Screen.Width / Screen.Height) > 16 / 10) And 1 = 0 Then dh = 1
    Anw = App.Title + "\Environ\" + CStr(dh)
     If window.WindowState <> vbMinimized Then
       SaveSetting Anw, window.Name, "WindowState", window.WindowState
       If window.WindowState <> vbMaximized Then
         SaveSetting Anw, window.Name, "Left", window.Left
         SaveSetting Anw, window.Name, "Top", window.Top
         SaveSetting Anw, window.Name, "Width", window.Width
         SaveSetting Anw, window.Name, "Height", window.Height
       End If
     End If
StatusText "AOBStandard.setWindowPos", "Ende", window.Name, LL.Wichtig
End Sub


' Return True if a file exists
Function FileExists(FileName As String) As Boolean
On Error GoTo ErrorHandler
' get the attributes and ensure that it isn't a directory
FileExists = (GetAttr(FileName) And vbDirectory) = 0
ErrorHandler:
' if an error occurs, this function returns False
err.Clear
On Error GoTo 0
End Function

'' Validate email address
Public Function ValidateEmailAddress(ByVal strEmailAddress As String) As Boolean
    On Error GoTo Catch
    
    Dim objRegExp As New RegExp
    Dim blnIsValidEmail As Boolean
    
    objRegExp.IgnoreCase = True
    objRegExp.global = True
    objRegExp.Pattern = "^([a-zA-Z0-9_\-\.]+)@[a-z0-9-]+(\.[a-z0-9-]+)*(\.[a-z]{2,6})$"
    
    blnIsValidEmail = objRegExp.Test(strEmailAddress)
    ValidateEmailAddress = blnIsValidEmail
      
    Exit Function
    
Catch:
    ValidateEmailAddress = False
    MsgBox "Module: " & MODULE_NAME & " - ValidateEmailAddress function" & vbCrLf & vbCrLf _
        & "Error#:  " & err.Number & vbCrLf & vbCrLf & err.Description
End Function

Public Function Exists(col, Index) As Boolean
On Error GoTo ExistsTryNonObject
    Dim o As Object

    Set o = col(Index)
    Exists = True
    Exit Function

ExistsTryNonObject:
    Exists = ExistsNonObject(col, Index)
End Function

Private Function ExistsNonObject(col, Index) As Boolean
On Error GoTo ExistsNonObjectErrorHandler
    Dim v As Variant

    v = col(Index)
    ExistsNonObject = True
    Exit Function

ExistsNonObjectErrorHandler:
    ExistsNonObject = False
End Function

Public Function IsFormLoaded(ByVal fName As String) _
  As Boolean
 
  Dim i As Integer
  IsFormLoaded = False
  For i = 0 To Forms.Count - 1
    If LCase$(Forms(i).Name) = LCase$(fName) Then
      IsFormLoaded = True
      Exit For
    End If
  Next i
End Function

