basicmods.bas

英文版Access数据库编程

strComboBox.Clear
On Error GoTo ErrHandler
RSOpen comboRS, "SELECT Cities.City FROM Cities WHERE Cities.StateID='" & strStateID & "';", dbOpenSnapshot
While Not comboRS.EOF
    strComboBox.addItem comboRS("City")
    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 FillCombo(ByRef strComboBox As ComboBox, ByVal strSQL As String, ByVal strItem As String)
Dim comboRS As Recordset

'On Error GoTo ErrHandler
RSOpen comboRS, strSQL, dbOpenSnapshot
While Not comboRS.EOF
    If IsNull(comboRS(strItem)) = False Then
        strComboBox.addItem comboRS(strItem)
    End If
    comboRS.MoveNext
Wend
comboRS.Close
Set comboRS = Nothing

ErrHandler:
    Exit Sub
End Sub

Public Sub ConnDB()
On Error GoTo ErrHandler
DBLocation = GetFromINI("Database", "Path", "", pathFileSettings)
Set dbWorkspace = DBEngine.Workspaces(0)
Set MySynonDatabase = dbWorkspace.OpenDatabase(DBLocation)

isOpen = True

ErrHandler:
If Err.Number <> 0 Then
    If Err.Number = 3044 Then 'Cannot find database
        isOpen = False
        Set dbWorkspace = Nothing
        Set MySynonDatabase = Nothing
        ErrorNotifier Err.Number, "Unable to locate database given the file path. Check your settings under Options."
        DoEvents
    End If
End If
End Sub

Public Sub RSOpen(ByRef strRecordset As Recordset, ByVal strQuery As String, Optional ByVal connLocking As RecordsetTypeEnum)
If isOpen = False Then
    Call ConnDB
End If
If IsMissing(connLocking) = True Then
    connLocking = dbOpenDynaset
End If
Set strRecordset = MySynonDatabase.OpenRecordset(strQuery, connLocking)
End Sub

Public Sub closeDB()
MySynonDatabase.Close
Set MySynonDatabase = Nothing
End Sub

Public Function isDateValid(ByVal bDay As Byte, ByVal bMonth As Byte, ByVal iYear As Integer) As Boolean
'Attempts to verify if a date is valid or not. Values are passed by parameter.
isDateValid = True
If (bDay < 0) Or (bMonth < 0) Or (iYear < 0) Then
    isDateValid = False
Else
    Select Case bMonth
        Case 1, 3, 5, 7, 8, 10, 12
            If bDay > 31 Then
                isDateValid = False
            End If
        Case 4, 6, 9, 11
            If bDay > 30 Then
                isDateValid = False
            End If
        Case 2
            If iYear Mod 2 = 0 Then
                If bDay > 29 Then
                    isDateValid = False
                End If
            Else
                If bDay > 28 Then
                    isDateValid = False
                End If
            End If
        Case Else
            isDateValid = False
    End Select
End If
End Function
Public Function processCustTransaction(ByVal transDate As String, ByVal description As String, ByVal transType As eTrans, ByVal accountID As String, ByVal amount As Single) As Boolean
Dim proSQL As String
Dim proRS As Recordset
proSQL = "SELECT * FROM cust_transactions"
Set proRS = MySynonDatabase.OpenRecordset(proSQL, dbOpenDynaset, dbAppendOnly)
On Error GoTo ErrHandler
proRS.AddNew
proRS("date") = transDate
If transType = credit Then
    proRS("credit") = amount
ElseIf transType = debit Then
    proRS("debit") = amount
End If
proRS("notes") = description
proRS("CustomerID") = accountID
proRS.Update

'Fulfilling double entry rule
proSQL = "SELECT CurrentBalance FROM Customers WHERE CustomerID='" & accountID & "';"
Set proRS = MySynonDatabase.OpenRecordset(proSQL, dbOpenDynaset)
proRS.Edit
If transType = credit Then
    proRS("CurrentBalance") = proRS("CurrentBalance") - amount
Else
    proRS("CurrentBalance") = proRS("CurrentBalance") + amount
End If
proRS.Update

proRS.Close
Set proRS = Nothing
processCustTransaction = True

ErrHandler:
If Err.Number <> 0 Then
    processCustTransaction = False
End If
End Function

Public Function processSuppTransaction(ByVal transDate As String, ByVal description As String, ByVal transType As eTrans, ByVal accountID As String, ByVal amount As Single) As Boolean
Dim proSQL As String
Dim proRS As Recordset
proSQL = "SELECT * FROM supp_transactions"
Set proRS = MySynonDatabase.OpenRecordset(proSQL, dbOpenDynaset, dbAppendOnly)
On Error GoTo ErrHandler
proRS.AddNew
proRS("date") = transDate
If transType = credit Then
    proRS("debit") = amount
ElseIf transType = debit Then
    proRS("credit") = amount
End If
proRS("notes") = description
proRS("SupplierID") = accountID
proRS.Update

'Fulfilling double entry rule
proSQL = "SELECT CurrentBalance FROM Suppliers WHERE SupplierID='" & accountID & "';"
Set proRS = MySynonDatabase.OpenRecordset(proSQL, dbOpenDynaset)
proRS.Edit
If transType = credit Then
    proRS("CurrentBalance") = proRS("CurrentBalance") + amount
Else
    proRS("CurrentBalance") = proRS("CurrentBalance") - amount
End If
proRS.Update

proRS.Close
Set proRS = Nothing
processSuppTransaction = True

ErrHandler:
If Err.Number <> 0 Then
    processSuppTransaction = False
End If
End Function

Public Sub insertLog(ByVal strLog As String)
If isOpen Then
    'Insert into systems log
    MySynonDatabase.Execute "INSERT INTO Logging VALUES ('" & CurrentUser.strUsername & "','" & strLog & "','" & FormatDateTime(Now(), vbLongTime) & "','" & Format$(Now(), "dd/mm/yyyy") & "');"
End If
End Sub

Public Function NumToString(ByVal nNumber As Currency) As String
'Written by Scott Seligman. Copied from www.freevbcode.com/ShowCode.asp?ID=343
Dim bNegative As Boolean
Dim bHundred As Boolean

If nNumber < 0 Then
    bNegative = True
End If

nNumber = Abs(Int(nNumber))

If nNumber < 1000 Then
    If nNumber \ 100 > 0 Then
        NumToString = NumToString & _
             NumToString(nNumber \ 100) & " hundred"
        bHundred = True
    End If
    nNumber = nNumber - ((nNumber \ 100) * 100)
    Dim bNoFirstDigit As Boolean
    bNoFirstDigit = False
    Select Case nNumber \ 10
        Case 0
            Select Case nNumber Mod 10
                Case 0
                    If Not bHundred Then
                        NumToString = NumToString & " zero"
                    End If
                Case 1: NumToString = NumToString & " one"
                Case 2: NumToString = NumToString & " two"
                Case 3: NumToString = NumToString & " three"
                Case 4: NumToString = NumToString & " four"
                Case 5: NumToString = NumToString & " five"
                Case 6: NumToString = NumToString & " six"
                Case 7: NumToString = NumToString & " seven"
                Case 8: NumToString = NumToString & " eight"
                Case 9: NumToString = NumToString & " nine"
            End Select
            bNoFirstDigit = True
        Case 1
            Select Case nNumber Mod 10
                Case 0: NumToString = NumToString & " ten"
                Case 1: NumToString = NumToString & " eleven"
                Case 2: NumToString = NumToString & " twelve"
                Case 3: NumToString = NumToString & " thirteen"
                Case 4: NumToString = NumToString & " fourteen"
                Case 5: NumToString = NumToString & " fifteen"
                Case 6: NumToString = NumToString & " sixteen"
                Case 7: NumToString = NumToString & " seventeen"
                Case 8: NumToString = NumToString & " eighteen"
                Case 9: NumToString = NumToString & " nineteen"
            End Select
            bNoFirstDigit = True
        Case 2: NumToString = NumToString & " twenty"
        Case 3: NumToString = NumToString & " thirty"
        Case 4: NumToString = NumToString & " forty"
        Case 5: NumToString = NumToString & " fifty"
        Case 6: NumToString = NumToString & " sixty"
        Case 7: NumToString = NumToString & " seventy"
        Case 8: NumToString = NumToString & " eighty"
        Case 9: NumToString = NumToString & " ninety"
    End Select
    If Not bNoFirstDigit Then
        If nNumber Mod 10 <> 0 Then
            NumToString = NumToString & "-" & _
                          Mid(NumToString(nNumber Mod 10), 2)
        End If
    End If
Else
    Dim nTemp As Currency
    nTemp = 10 ^ 12 'trillion
    Do While nTemp >= 1
        If nNumber >= nTemp Then
            NumToString = NumToString & _
                          NumToString(Int(nNumber / nTemp))
            Select Case Int(Log(nTemp) / Log(10) + 0.5)
                Case 12: NumToString = NumToString & " trillion"
                Case 9: NumToString = NumToString & " billion"
                Case 6: NumToString = NumToString & " million"
                Case 3: NumToString = NumToString & " thousand"
            End Select
           
            nNumber = nNumber - (Int(nNumber / nTemp) * nTemp)
        End If
        nTemp = nTemp / 1000
    Loop
End If

If bNegative Then
    NumToString = " negative" & NumToString
End If
    
End Function

Public Function DollarToString(ByVal nAmount As Currency) As String
'Written by Scott Seligman. Copied from www.freevbcode.com/ShowCode.asp?ID=343

    Dim nDollar As Currency
    Dim nCent As Currency
    
    nDollar = Int(nAmount)
    nCent = (Abs(nAmount) * 100) Mod 100
    
    DollarToString = NumToString(nDollar) & " dollar"
    
    If Abs(nDollar) <> 1 Then
        DollarToString = DollarToString & "s"
    End If
    
    DollarToString = DollarToString & " and" & _
                     NumToString(nCent) & " cent"
                     
    If Abs(nCent) <> 1 Then
        DollarToString = DollarToString & "s"
    End If
    
End Function