basicmods.bas

英文版Access数据库编程

Attribute VB_Name = "BasicModules"
Option Explicit
'Created by: Roy Yong
'Basic modules where procedures and functions are stored and called for
'Global Variables
Global CurrentUser As SynonUser
Global dbWorkspace As Workspace
Global MySynonDatabase As Database
Global isOpen As Boolean 'Use to determine if database is connected
Global pathFileSettings As String
Global DBLocation As String
Global NumDOForm As Byte
Global NumPOForm As Byte

Private Declare Function GetPrivateProfileString Lib "kernel32" Alias "GetPrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Long, ByVal lpFileName As String) As Long
Private Declare Function WritePrivateProfileString Lib "kernel32" Alias "WritePrivateProfileStringA" (ByVal lpApplicationName As String, ByVal lpKeyName As Any, ByVal lpString As Any, ByVal lpFileName As String) As Long
Private Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Boolean) As Long
   
Private Declare Function GetMenuItemCount Lib "user32" (ByVal hMenu As Long) As Long
Private Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Private Declare Function DrawMenuBar Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function InitCommonControlsEx Lib "comctl32.dll" (iccex As tagInitCommonControlsEx) As Boolean

Private Const MF_BYPOSITION = &H400&
Private Const MF_REMOVE = &H1000&
Public Const ICC_USEREX_CLASSES = &H200
'Public Variables

'Custom Types
Public Type tagInitCommonControlsEx
   lngSize As Long
   lngICC As Long
End Type
Public Type SynonUser
    employeeID As String
    strUsername As String
    strPassword As String
    lastPassword As Date
    mustChange As Boolean
    isLocked As Boolean
    isDisabled As Boolean
    prvlgAdmin As Boolean
    prvlgAPS As Boolean
    prvlgARS As Boolean
    prvlgDOS As Boolean
    prvlgHRS As Boolean
    prvlgReport As Boolean
End Type
'Custom enumerated type
Public Enum ModeStatus
    Editing
    Viewing
End Enum

Public Enum eTrans
    credit
    debit
    transfer
End Enum

Public Enum form_Condition
    force_Change 'Requirement
    mild_Change 'Optional
End Enum

' Functions
Public Function GetFromINI(sSection As String, sKey As String, sDefault As String, sIniFile As String)
    Dim sBuffer As String, lRet As Long
    ' Fill String with 255 spaces
    sBuffer = String$(255, 0)
    ' Call DLL
    lRet = GetPrivateProfileString(sSection, sKey, "", sBuffer, Len(sBuffer), sIniFile)
    If lRet = 0 Then
        ' DLL failed, save default
        If sDefault <> "" Then AddToINI sSection, sKey, sDefault, sIniFile
        GetFromINI = sDefault
    Else
        ' DLL successful
        ' return string
        GetFromINI = Left(sBuffer, InStr(sBuffer, Chr(0)) - 1)
    End If
End Function

' Returns True if successful. If section does not
' exist it creates it.
Public Function AddToINI(sSection As String, sKey As String, sValue As String, sIniFile As String) As Boolean
    Dim lRet As Long
    ' Call DLL
    lRet = WritePrivateProfileString(sSection, sKey, sValue, sIniFile)
    AddToINI = (lRet)
End Function

Public Function getSettings(ByVal strSubject As String) As Variant
'gets settings from database which is shared among all users
If isOpen = True Then
    'Make sure database connected
    Dim settingRS As Recordset, settingSQL As String
    settingSQL = "SELECT * FROM Pub_settings WHERE Pub_settings.Subject='" & strSubject & "';"
    RSOpen settingRS, settingSQL, dbOpenSnapshot
    If Not settingRS.EOF Then
        getSettings = settingRS("Value")
    Else
        getSettings = ""
        ErrorNotifier 1011, "Unable to retrieve the primary settings due to invalid parameter passed. As a result, this program would not run as normal."
    End If
    settingRS.Close
    Set settingRS = Nothing
End If
End Function

Public Function getNextKeys(ByVal strSubject As String) As Variant
If isOpen = True Then
    'make sure database is connected
    Dim sRS As Recordset, sSQL As String
    sSQL = "SELECT DataValue FROM Misc WHERE DataType='" & strSubject & "';"
    RSOpen sRS, sSQL, dbOpenSnapshot
    If Not sRS.EOF Then
        getNextKeys = sRS("DataValue")
    Else
        getNextKeys = ""
        ErrorNotifier 1011, "Unable to retrieve the primary settings due to invalid parameter passed. As a result, this program would not run as normal."
    End If
    sRS.Close
    Set sRS = Nothing
End If
End Function

Sub Main()
    'This section of comments and some related codes taken from isExplorerBar project
        ' we need to call InitCommonControls before we
        ' can use XP visual styles.  Here I'm using
        ' InitCommonControlsEx, which is the extended
        ' version provided in v4.72 upwards (you need
        ' v6.00 or higher to get XP styles)
        On Error Resume Next
        ' this will fail if Comctl not available
        '  - unlikely now though!
        Dim iccex As tagInitCommonControlsEx
        With iccex
            .lngSize = LenB(iccex)
            .lngICC = ICC_USEREX_CLASSES
        End With
        InitCommonControlsEx iccex

        ' now start the application
    
        On Error GoTo 0
        'Loads the very first form
    'End of copied code
    frmLogin.Show
    pathFileSettings = App.Path & "\settings.ini"
End Sub

'Public procedures
Public Sub DisableClose(frm As Form, Optional _
  Disable As Boolean = True)
    'Setting Disable to False disables the 'X',
     'otherwise, it's reset

    Dim hMenu As Long
    Dim nCount As Long
    
    If Disable Then
        hMenu = GetSystemMenu(frm.hwnd, False)
        nCount = GetMenuItemCount(hMenu)
        
        Call RemoveMenu(hMenu, nCount - 1, MF_REMOVE Or _
            MF_BYPOSITION)
        Call RemoveMenu(hMenu, nCount - 2, MF_REMOVE Or _
            MF_BYPOSITION)
    
        DrawMenuBar frm.hwnd
    Else
        GetSystemMenu frm.hwnd, True
        
        DrawMenuBar frm.hwnd
    End If
End Sub

Public Sub ValidMsg(ByVal strMssg As String, strTitle As String)
MsgBox strMssg, vbExclamation + vbOKOnly, strTitle
End Sub

Public Sub CriticalMsg(ByVal strMssg As String, strTitle As String)
MsgBox strMssg, vbCritical + vbOKOnly, strTitle
End Sub

Public Sub InfoMsg(ByVal strMssg As String, strTitle As String)
MsgBox strMssg, vbInformation + vbOKOnly, strTitle
End Sub

Public Sub SelText(ByRef strControlName As Control)
'Highlights the string within the control
On Error Resume Next
strControlName.SelStart = 0
strControlName.SelLength = Len(strControlName.Text)
End Sub

Public Sub CapCon(ByRef strControlName As Control)
'Converts the string passed in to upper case
On Error Resume Next
strControlName.Text = UCase(strControlName.Text)
End Sub
Public Sub OnlyNum(ByRef strAscii As Integer)
'Strict limitations. Non-digital keys converted to 0
Select Case strAscii
Case Asc("0") To Asc("9")
    'Do nothing
Case vbKeyBack
    'do nothing
Case Else
    strAscii = 0
End Select
End Sub

Public Sub onlyPassword(ByRef strAscii As Integer)
Select Case strAscii
    Case Asc("A") To Asc("Z"), Asc("a") To Asc("z"), Asc("0") To Asc("9"), Asc("_"), vbKeySpace, vbKeyBack
    'Do nothing
    Case Else
        strAscii = 0
End Select
End Sub

Public Sub ErrorNotifier(ByVal ErrNumber As Long, ByVal ErrDescription As String)
Dim errorRS As Recordset, errorSQL As String
Screen.MousePointer = 0
CriticalMsg "Error No: " & ErrNumber & vbCrLf & "Description: " & ErrDescription & vbCrLf & "Please contact system administrator.", "Critical Error"
If isOpen = True Then
    errorSQL = "INSERT INTO Error_Logging VALUES ('" & Format$(Now(), "dd/mm/yyyy") & "','" & CStr(ErrNumber) & "','" & ErrDescription & "');"
    On Error GoTo ErrHandler
    MySynonDatabase.Execute errorSQL
End If
ErrHandler:
If Err.Number <> 0 Then
    Exit Sub
End If
End Sub

Public Sub OnlyAlpha(ByRef strAscii As Integer)
'Strict limitations. Non-alphabet keys converted to 0
Select Case strAscii
Case Asc("A") To Asc("Z")
    'Do nothing
Case Asc("a") To Asc("z")
    'Do nothing
Case vbKeyBack, vbKeySpace
    'Do nothing
Case Else
    strAscii = 0
End Select
End Sub

Public Sub tickerKeys(ByRef strAscii As Integer)
Select Case strAscii
    Case Asc("."), Asc("!"), Asc(","), Asc("("), Asc(")"), Asc(":"), Asc(";"), Asc("?"), Asc("/"), Asc("0") To Asc("9")
        'Do nothing
    Case Else
        OnlyAlpha strAscii
End Select
End Sub

Public Sub FillComboCountry(ByRef strComboBox As ComboBox)
Dim cmbRS As Recordset

On Error GoTo ErrHandler
RSOpen cmbRS, "SELECT Countries.CountryID FROM Countries;", dbOpenSnapshot
While Not cmbRS.EOF
    strComboBox.addItem cmbRS("CountryID")
    cmbRS.MoveNext
Wend

cmbRS.Close
Set cmbRS = Nothing
ErrHandler:
If Err.Number <> 0 Then
    Exit Sub
End If
End Sub

Public Sub FillComboState(ByRef strComboBox As ComboBox, ByVal strCountryID As String)
Dim comboRS As Recordset, tmpString As String
tmpString = strComboBox.Text
strComboBox.Clear
On Error GoTo ErrHandler
RSOpen comboRS, "SELECT States.StateID FROM States WHERE States.CountryID='" & strCountryID & "';", dbOpenSnapshot
While Not comboRS.EOF
    strComboBox.addItem comboRS("StateID")
    comboRS.MoveNext
Wend
comboRS.Close
Set comboRS = Nothing
strComboBox.Text = tmpString
ErrHandler:
If Err.Number <> 0 Then
    Exit Sub
End If
End Sub

Public Sub FillComboCity(ByRef strComboBox As ComboBox, ByVal strStateID As String)
Dim comboRS As Recordset, tmpString As String
tmpString = strComboBox.Text