502 lines
11 KiB
QBasic
502 lines
11 KiB
QBasic
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
|
|
|
|
|
|
|
|
|
|
|