Option Compare Database
Option Explicit


Sub test()

SwitchToolbars (True)

End Sub

Function SwitchToolbars(onoff As Boolean)

'For Runtime
Exit Function

If (onoff) Then

DoCmd.ShowToolbar "Menüleiste", acToolbarYes '
DoCmd.ShowToolbar "Formularansicht", acToolbarYes
DoCmd.ShowToolbar "Datenbank", acToolbarYes
DoCmd.SetDisplayedCategories (True)
'ÄndernEigenschaft "StartupForm", dbText, "MHauptmenü"
ÄndernEigenschaft "StartupShowDBWindow", dbBoolean, True
ÄndernEigenschaft "StartupShowStatusBar", dbBoolean, True
ÄndernEigenschaft "AllowFullMenus", dbBoolean, True

Else

DoCmd.ShowToolbar "Menüleiste", acToolbarNo
DoCmd.ShowToolbar "Formularansicht", acToolbarNo
DoCmd.ShowToolbar "Datenbank", acToolbarNo
DoCmd.SetDisplayedCategories (False)
'ÄndernEigenschaft "StartupForm", dbText, "MHauptmenü"
ÄndernEigenschaft "StartupShowDBWindow", dbBoolean, False
ÄndernEigenschaft "StartupShowStatusBar", dbBoolean, False
ÄndernEigenschaft "AllowFullMenus", dbBoolean, False


End If


End Function


Function StartupValues()

'ÄndernEigenschaft "StartupShowDBWindow", dbBoolean, False
'ÄndernEigenschaft "StartupShowStatusBar", dbBoolean, False

End Function

Function ÄndernEigenschaft(strEigenschaftenname As String, varEigenschaftentyp As Variant, varEigenschaftenwert As Variant) As Integer
    Dim dbs As Database, prp As property
    Const conPropNotFoundError = 3270

    Set dbs = CurrentDb
    On Error GoTo Ändern_Fehler
    dbs.Properties(strEigenschaftenname) = varEigenschaftenwert
    ÄndernEigenschaft = True

Ändern_Ende:
    Exit Function

Ändern_Fehler:

If Err = conPropNotFoundError Then  ' Eigenschaft nicht gefunden.
        Set prp = dbs.CreateProperty(strEigenschaftenname, _
            varEigenschaftentyp, varEigenschaftenwert)
        dbs.Properties.Append prp
        Resume Next
    Else
        ' Unbekannter Fehler.
        ÄndernEigenschaft = False
        Resume Ändern_Ende
    End If
End Function


Function GetLocalParameter(Name1 As String) As Variant

GetLocalParameter = DFirst("[Wert]", "lParameter", "[Bezeichnung]='" + UCase(Name1) + "'")

End Function


Function GetParameter(Name1 As String) As Variant

GetParameter = DFirst("[Wert]", "TParameter", "[Bezeichnung]='" + UCase(Name1) + "'")

End Function

Sub SetParameter(Name1 As String, value1 As String)

Dim db1 As Database
Dim rs1 As Recordset
Dim found As Boolean

Set db1 = CurrentDb

Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM TParameter;")

found = False
rs1.MoveFirst
While (Not rs1.EOF)
 If (UCase(rs1!Bezeichnung) = UCase(Name1)) Then found = True
 rs1.MoveNext
Wend
rs1.Close

Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM TParameter;")

If found = True Then
 rs1.MoveFirst
 While (UCase(rs1!Bezeichnung) <> UCase(Name1))
  rs1.MoveNext
 Wend
 rs1.Edit
 rs1!Wert = value1
 rs1.Update
Else:
 rs1.AddNew
 rs1!Bezeichnung = Name1
 rs1!Wert = value1
 rs1.Update
End If

rs1.Close


End Sub


Sub SetLocalParameter(Name1 As String, value1 As String)

Dim db1 As Database
Dim rs1 As Recordset
Dim found As Boolean

Set db1 = CurrentDb

Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM lParameter;")

found = False
rs1.MoveFirst
While (Not rs1.EOF)
 If (UCase(rs1!Bezeichnung) = UCase(Name1)) Then found = True
 rs1.MoveNext
Wend
rs1.Close

Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Wert FROM lParameter;")

If found = True Then
 rs1.MoveFirst
 While (UCase(rs1!Bezeichnung) <> UCase(Name1))
  rs1.MoveNext
 Wend
 rs1.Edit
 rs1!Wert = value1
 rs1.Update
Else:
 rs1.AddNew
 rs1!Bezeichnung = Name1
 rs1!Wert = value1
 rs1.Update
End If

rs1.Close


End Sub




Function Qualitätsstufe(Oechsle) As Variant

If IsNull(Oechsle) Then
     Qualitätsstufe = Null
Else
    
    Dim db1 As Database
    Dim rs1 As Recordset
    
    Set db1 = CurrentDb
    
    Qualitätsstufe = ""
    Set rs1 = db1.OpenRecordset("SELECT Bezeichnung,Von,Bis FROM TQualitaetsstufen;")
    
    rs1.MoveFirst
     
     While Not rs1.EOF
      If Oechsle >= rs1!Von And Oechsle <= rs1!Bis Then
       Qualitätsstufe = rs1!Bezeichnung
      End If
      rs1.MoveNext
     Wend
    rs1.Close

End If

End Function

Function QSNR(Oechsle As Long) As Long

If IsNull(Oechsle) Then
     QSNR = Null
Else
        
    Dim db1 As Database
    Dim rs1 As Recordset
    
    Set db1 = CurrentDb
    
    QSNR = Null
    Set rs1 = db1.OpenRecordset("SELECT QSNR,Von,Bis FROM TQualitaetsstufen;")
    
    rs1.MoveFirst
     
     While Not rs1.EOF
      If Oechsle >= rs1!Von And Oechsle <= rs1!Bis Then
       QSNR = rs1!QSNR
      End If
      rs1.MoveNext
     Wend
    rs1.Close
End If

End Function

Function Fileexist(filename As String) As Boolean

On Error GoTo NoFile

If FileSystem.GetAttr(filename) >= 0 Then
 Fileexist = True
Else
 Fileexist = False
End If

Exit Function

NoFile:
 Fileexist = False
 Exit Function

End Function


Function GetAppPath() As String

Dim db1 As Database
Set db1 = CurrentDb

'GetAppPath = Mid(db1.Name, 1, Len(db1.Name) - Len("WGMASTER.ACCDB"))
GetAppPath = Mid(db1.Name, 1, Len(db1.Name) - Len("WGMASTER2010.ACCDB"))


End Function

Function GetDataPath() As String

Dim datapath As String
datapath = DFirst("Data", "Mandanten", "MANR=" + Format(Forms!MMandantenauswahl!LMandanten))
GetDataPath = datapath

End Function

Function GetPathWithoutFilename(fullpath As String) As String

Dim str1 As String

str1 = fullpath

While Len(str1) > 0 And Mid(str1, Len(str1), 1) <> "\"
 str1 = Mid(str1, 1, Len(str1) - 1)
 If str1 = "" Then
  GetPathWithoutFilename = ""
  Exit Function
 End If
Wend

GetPathWithoutFilename = str1


End Function

Function GetLastMANR() As Long

Dim db1 As Database
Dim rs1 As Recordset
Dim found As Boolean

Set db1 = CurrentDb

Set rs1 = db1.OpenRecordset("SELECT * FROM Mandanten;")

GetLastMANR = -1
While (Not rs1.EOF)
 If rs1!Last = True Then
  GetLastMANR = rs1!MANR
 End If
 rs1.MoveNext
Wend
rs1.Close

End Function


Sub SetLastMANR(manr1 As Long)

Dim db1 As Database
Dim rs1 As Recordset
Dim found As Boolean

Set db1 = CurrentDb

Set rs1 = db1.OpenRecordset("SELECT * FROM Mandanten;")

found = False
While (Not rs1.EOF)

 If rs1!Last = True Then
  rs1.Edit
  rs1!Last = False
  rs1.Update
 End If
 If rs1!MANR = manr1 Then
  rs1.Edit
  rs1!Last = True
  rs1.Update
 End If
 rs1.MoveNext
Wend
rs1.Close

End Sub


Public Function Runden(value1 As Double, digits As Integer) As Double

Dim temp1 As Double

temp1 = value1 * (10 ^ digits)

If (temp1 * 10) Mod 10 = 5 Then
 temp1 = temp1 + 1
 temp1 = Fix(temp1)
 temp1 = temp1 / (10 ^ digits)
 Runden = temp1
Else
 Runden = CLng(value1 * (10 ^ digits)) / (10 ^ digits)
End If

End Function



Public Function GetAbschlägeAsString(LINR1 As Long) As String
 Const separator = " / "
 Const separator_length = 3
 Dim db1 As Database
 Dim rs1 As Recordset
 Dim resultString As String
 Set db1 = CurrentDb

 Set rs1 = db1.OpenRecordset("SELECT TAbschlaege.* FROM (TLieferungAbschlag INNER JOIN TAbschlaege ON TLieferungAbschlag.ASNR = TAbschlaege.ASNR) INNER JOIN TLieferungen ON TLieferungAbschlag.LINR = TLieferungen.LINR WHERE TLieferungen.LINR=" + Format(LINR1))
 
 resultString = ""
 While Not rs1.EOF
  resultString = resultString + separator + rs1!Bezeichnung
  rs1.MoveNext
 Wend
 rs1.Close
 If resultString <> "" Then resultString = Mid(resultString, 1 + separator_length)
 
 GetAbschlägeAsString = resultString

End Function


Public Function GetSNRAndSANRFromInput(SNRInput As String, SNR As String, SANR As String) As Boolean
Dim db1 As Database
Dim rs1 As Recordset

Set db1 = CurrentDb
Set rs1 = db1.OpenRecordset("SELECT * FROM TSortenAttributeEingabe WHERE SNREingabe='" + SNRInput + "'")
If Not rs1.EOF Then
 SNR = rs1("SNR")
 SANR = rs1("SANR")
 GetSNRAndSANRFromInput = True
Else
 GetSNRAndSANRFromInput = False
End If
rs1.Close

End Function

Public Function GetGebietGLNR(SNR As String, QSNR As Long, GLNR As Long) As Long
Dim db1 As Database
Dim rs1 As Recordset

Set db1 = CurrentDb
Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR + "' AND MinQSNR<=" + Format(QSNR) + " AND GLNR=" + Format(GLNR))
If rs1.EOF Then
 rs1.Close
 'Standardgebiet nehmen
 Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR))
End If
GetGebietGLNR = rs1("WBGNR")
rs1.Close

End Function

Public Function GetGebiet(SNR As String, QSNR As Long, GLNR As Long) As String
Dim db1 As Database
Dim rs1 As Recordset

Set db1 = CurrentDb
Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR + "' AND MinQSNR<=" + Format(QSNR) + " AND GLNR=" + Format(GLNR))
If rs1.EOF Then
 rs1.Close
 'Standardgebiet nehmen
 Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR))
End If
GetGebiet = DFirst("Bezeichnung", "TGebiete", "WBGNR=" + Format(rs1("WBGNR")))
rs1.Close

End Function


Public Function GetHerkunft(SNR1 As String, QSNR1 As Long, GNR1 As Long) As String
Dim db1 As Database
Dim rs1 As Recordset
Dim WBGNR1 As Long
Dim RGNR1 As Long
Dim GLNR1 As Long

GLNR1 = DFirst("GLNR", "TGemeinden", "GNR=" + Format(GNR1))
Set db1 = CurrentDb
Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR1 + "' AND MinQSNR<=" + Format(QSNR1) + " AND GLNR=" + Format(GLNR1))
If Not rs1.EOF Then
 'Spezialeintrag für diese Sorte und Qualität existiert
 WBGNR1 = rs1("WBGNR")
Else
 rs1.Close
 'Standardgebiet nehmen
 Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR1))
 WBGNR1 = rs1("WBGNR")
End If
rs1.Close
RGNR1 = DFirst("RGNR", "TGebiete", "WBGNR=" + Format(WBGNR1))

If Not IsNull(DFirst("Herkunftsbezeichnung", "TQualitaetsstufen", "QSNR=" + Format(QSNR1))) Then
 Select Case DFirst("Herkunftsbezeichnung", "TQualitaetsstufen", "QSNR=" + Format(QSNR1))
  Case "Land": GetHerkunft = "Österreich"
  Case "Region":  GetHerkunft = DFirst("Bezeichnung", "TRegionen", "RGNR=" + Format(RGNR1))
  Case "Gebiet":  GetHerkunft = DFirst("Bezeichnung", "TGebiete", "WBGNR=" + Format(WBGNR1))
  Case "Grosslage": GetHerkunft = DFirst("Bezeichnung", "TGrosslagen", "GLNR=" + Format(GLNR1))
  Case "Gemeinde": GetHerkunft = DFirst("Bezeichnung", "TGemeinden", "GNR=" + Format(GNR1))
 End Select
Else
 GetHerkunft = DFirst("Bezeichnung", "TRegionen", "RGNR=" + Format(RGNR1))
End If


End Function
Public Function GetHerkunftBKI(SNR1 As String, QSNR1 As Long, GNR1 As Long) As String
Dim db1 As Database
Dim rs1 As Recordset
Dim WBGNR1 As Long
Dim RGNR1 As Long
Dim GLNR1 As Long

GLNR1 = DFirst("GLNR", "TGemeinden", "GNR=" + Format(GNR1))
Set db1 = CurrentDb
Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslageGebietSorte WHERE SNR='" + SNR1 + "' AND MinQSNR<=" + Format(QSNR1) + " AND GLNR=" + Format(GLNR1))
If Not rs1.EOF Then
 'Spezialeintrag für diese Sorte und Qualität existiert
 WBGNR1 = rs1("WBGNR")
Else
 rs1.Close
 'Standardgebiet nehmen
 Set rs1 = db1.OpenRecordset("SELECT WBGNR FROM TGrosslagen WHERE GLNR=" + Format(GLNR1))
 WBGNR1 = rs1("WBGNR")
End If
rs1.Close
RGNR1 = DFirst("RGNR", "TGebiete", "WBGNR=" + Format(WBGNR1))

If QSNR1 < 3 Then
 GetHerkunftBKI = DFirst("Herkunftsbezeichnung", "TQualitaetsstufen", "QSNR=" + Format(QSNR1))
Else
 GetHerkunftBKI = DFirst("BKIKuerzel", "TGebiete", "WBGNR=" + Format(WBGNR1))
End If

End Function