Exported VBA
This commit is contained in:
501
wgmaster/vba/MMisc.bas
Normal file
501
wgmaster/vba/MMisc.bas
Normal file
@ -0,0 +1,501 @@
|
||||
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
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user