Option Compare Database
Option Explicit
Declare Function SetWindowTextA Lib "user32" (ByVal hWnd As Long, ByVal lpString As String) As Long
Declare Function GetActiveWindow Lib "user32" () As Long
Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Declare Function GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Public Const strIniDatei = "Kassabuch.ini"
Public Const strMsg = "In Ihrer Anwendung ist folgendes Problem aufgetreten."
Public Const FDetail = 16314085
Public Const FKopf = 12167064
Public Const FSidebar = 14337975
Public eh As New ErrorHandling
Public strPfad As String
Public PfadData As String
Public PfadSQL As String
Public PfadProt As String
Public PfadDok As String
Public PfadVorlage As String
Public PfadImport As String
Public strFirma As String
Public FirmaID As Long
Public TabAutoEinbinden As Integer
Public aktJahr As Integer
Public aktDatum As String
Public AuswahlMA As Long
Public ZusatzText As String
Public Rechte() As Long
Public SQLRechte(1 To 5) As String
Public Benutzer As String
Public UserLang As String
Public Compi As String
Public strFussZeile As String
Public AllowQuit As Boolean
Public strVersion As String
Public lngSprache As Long
Public lngRecID As Long
Public g_strInfo As String
Public g_Aufteilen As Long
Public g_strSQL As String
Public r As Variant
Public lnRecnr As Long
Public lnAnzRec As Long
Function MainFormLoad()
On Error GoTo Err_FormLoad
Dim hWnd As Long
Dim dummy As String
Dim isIni As String
On Error Resume Next
DoCmd.RunCommand acCmdWindowHide
On Error GoTo Err_FormLoad
strPfad = left(CurrentDb.Name, Len(CurrentDb.Name) - Len(Dir(CurrentDb.Name)))
PfadData = Ini_Lesen("Pfad", "PfadData", strIniDatei)
PfadProt = strPfad
strFirma = "EDJV"
FirmaID = "0"
lngSprache = 0
strFussZeile = "Vertraulich"
CheckTabellen PfadData
strVersion = "Version 2.00 (01.12.2018) " & Dir(CurrentDb.Name)
hWnd = GetActiveWindow()
dummy = SetWindowTextA(hWnd, "Kassabuch " & strVersion)
Exit Function
Err_FormLoad:
MsgBox strMsg & Err & " / " & Err.Description, , "MainFormLoad"
AddError ("Runtime (MainFormLoad) ")
Resume Next
End Function
Function glAbmelden()
On Error Resume Next
AllowQuit = True
MainFormLoad
DoCmd.OpenForm ("frmLogin")
DoCmd.Close acForm, "frmmain"
End Function
Function glBeenden()
On Error Resume Next
If MsgBox("Möchten Sie das Programm wirklich verlassen", vbYesNoCancel, "Beenden") = vbYes Then
AddProt ("Programm Ende : " & strVersion & ", User: " & Benutzer)
AllowQuit = True
DoCmd.Quit acQuitSaveAll
End If
End Function
Public Function Ini_Lesen(ByVal Sektion As String, ByVal slKey As String, ByVal Datei As String) As String
On Error GoTo Err_Error
Dim retVal As String
Dim worked As Long
Dim IniDatei As String
IniDatei = CurrentProject.Path & "\" & Datei
retVal = String(255, " ")
worked = GetPrivateProfileString(Sektion, slKey, " ", retVal, Len(retVal), IniDatei)
Ini_Lesen = left(retVal, InStr(retVal, Chr(0)) - 1)
Exit Function
Err_Error:
MsgBox strMsg & Err & " / " & Err.Description, , "ini_Lesen"
Resume Next
End Function
Sub EnableShift(blnFlag As Boolean)
On Error GoTo Err_Error
Dim db As DAO.Database
Dim prp As DAO.Property
Set db = CurrentDb
db.Properties!AllowBypassKey = blnFlag
Exit_EnableShift:
Set prp = Nothing
Exit Sub
Err_Error:
If Err = 3270 Then
Set prp = db.CreateProperty("AllowBypassKey", dbBoolean, blnFlag)
db.Properties.Append prp
Resume Next
Else
MsgBox "Ausnahme Nr. " & str(Err.Number) & " " & Err.Description
Resume Exit_EnableShift
End If
End Sub
Function AendernStarteigenschaften(strName As String, varTyp As Variant, varWert As Variant) As Boolean
On Error GoTo Err_Error
Dim db As Database
Dim prp As Property
Const conPropNotError = 3270
Set db = CurrentDb
db.Properties(strName) = varWert
AendernStarteigenschaften = True
FunctionEnde:
Exit Function
Err_Error:
If Err = conPropNotError Then
Set prp = db.CreateProperty(strName, varTyp, varWert)
db.Properties.Append prp
Resume Next
Else
MsgBox Err.Description
AendernStarteigenschaften = False
Resume FunctionEnde
End If
End Function