Chip 1999 September/CHIPCD_9_99.iso/software/uaktualnienia/OptionPackPL/iis4_07.cab/Member.cls

Text File | 1998-04-27 | 17KB | 502 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "Member"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Option Explicit

Function AddNew(ByVal strFileDSN As String, ByVal strFirstName As String, ByVal strLastName As String, ByVal strMiddleName As String, ByVal strKnownAs As String, _
     ByVal strGender As String, ByVal strAddress1 As String, ByVal strAddress2 As String, ByVal strCity As String, ByVal strState As String, ByVal strPostCode As String, _
     ByVal strCountry As String, ByVal strHomePhone As String, ByVal strBusinessPhone As String, ByVal strFax As String, ByVal strEmail As String, _
     ByVal strWebSite As String, ByVal strMeal As String, ByVal strSeating As String, _
     ByVal strExitRow As String, ByVal lngMileage As Long)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim lngAccountID As Long
    Dim cnn As New ADODB.Connection
    Dim arrReturn(2)
    Dim strPassword As String

    arrReturn(0) = 0
    strPassword = InventPassword()

    'TakeANumber generates a unique account number and insures that no one will
    'concurrently choose the same number

    ' This method is in another class, so have to "objContext.CreateInstance"
    '   Note that should not CreateObject in this circumstance, because if
    '   CreateObject, will get a NEW transaction that cannot see the work
    '   done in this (calling) transaction
    Dim TakeANum As Object
    Set TakeANum = objContext.CreateInstance("MTS_TakeANumber.TakeANumber")
    lngAccountID = TakeANum.GetANumber(strFileDSN, "AccountID")

    strSQL = "INSERT INTO Member " & _
                          "(Password, " & _
                          "AccountID, " & _
                          "FirstName, " & _
                          "LastName, " & _
                          "MiddleName, " & _
                          "KnownAs, " & _
                          "Gender, " & _
                          "Address1, " & _
                          "Address2, " & _
                          "City, " & _
                          "State, " & _
                          "PostCode, " & _
                          "Country, " & _
                          "HomePhone, " & _
                          "BusinessPhone, " & _
                          "Fax, " & _
                          "Email, " & _
                          "Mileage, " & _
                          "WebSite, " & _
                          "Meal, " & _
                          "Seating, " & _
                          "ExitRow)"

    strSQL = strSQL & _
                        "VALUES ('" & _
                                SQLEncode(strPassword) & "', " & _
                                lngAccountID & ", '" & _
                                SQLEncode(strFirstName) & "', '" & _
                                SQLEncode(strLastName) & "', '" & _
                                SQLEncode(strMiddleName) & "', '" & _
                                SQLEncode(strKnownAs) & "', '" & _
                                SQLEncode(strGender) & "', '" & _
                                SQLEncode(strAddress1) & "', '" & _
                                SQLEncode(strAddress2) & "', '" & _
                                SQLEncode(strCity) & "', '" & _
                                SQLEncode(strState) & "', '" & _
                                SQLEncode(strPostCode) & "', '" & _
                                SQLEncode(strCountry) & "', '" & _
                                SQLEncode(strHomePhone) & "', '" & _
                                SQLEncode(strBusinessPhone) & "', '" & _
                                SQLEncode(strFax) & "', '" & _
                                SQLEncode(strEmail) & "', " & _
                                lngMileage & ", '" & _
                                SQLEncode(strWebSite) & "', '" & _
                                SQLEncode(strMeal) & "', '" & _
                                SQLEncode(strSeating) & "', '" & _
                                SQLEncode(strExitRow) & "')"

    cnn.Open "FileDSN=" & strFileDSN
    cnn.Execute (strSQL)

    objContext.SetComplete
    AddNew = lngAccountID
    Exit Function

ErrorHandler:
    If Not cnn Is Nothing Then Set cnn = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.AddNew()", Err.Description

End Function

Function Update(ByVal strFileDSN As String, ByVal lngAccountID As Long, ByVal strFirstName As String, ByVal strLastName As String, ByVal strMiddleName As String, ByVal strKnownAs As String, _
     ByVal strGender As String, ByVal strAddress1 As String, ByVal strAddress2 As String, ByVal strCity As String, ByVal strState As String, ByVal strPostCode As String, _
     ByVal strCountry As String, ByVal strHomePhone As String, ByVal strBusinessPhone As String, ByVal strFax As String, ByVal strEmail As String, _
     ByVal strWebSite As String, ByVal strMeal As String, ByVal strSeating As String, _
     ByVal strExitRow As String)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim cnn As New ADODB.Connection
    strSQL = "UPDATE Member " & _
        "SET FirstName = '" & SQLEncode(strFirstName) & "'," & _
            "LastName = '" & SQLEncode(strLastName) & "'," & _
            "MiddleName = '" & SQLEncode(strMiddleName) & "'," & _
            "KnownAs = '" & SQLEncode(strKnownAs) & "'," & _
            "Gender = '" & SQLEncode(strGender) & "'," & _
            "Address1 = '" & SQLEncode(strAddress1) & "'," & _
            "Address2 = '" & SQLEncode(strAddress2) & "'," & _
            "City = '" & SQLEncode(strCity) & "'," & _
            "State = '" & SQLEncode(strState) & "'," & _
            "PostCode = '" & SQLEncode(strPostCode) & "'," & _
            "Country = '" & SQLEncode(strCountry) & "'," & _
            "HomePhone = '" & SQLEncode(strHomePhone) & "'," & _
            "BusinessPhone = '" & SQLEncode(strBusinessPhone) & "'," & _
            "Fax = '" & SQLEncode(strFax) & "'," & _
            "Email = '" & SQLEncode(strEmail) & "'," & _
            "WebSite = '" & SQLEncode(strWebSite) & "'," & _
            "Meal = '" & SQLEncode(strMeal) & "'," & _
            "Seating = '" & SQLEncode(strSeating) & "'," & _
            "ExitRow = '" & SQLEncode(strExitRow) & "'" & _
        "WHERE AccountID = " & lngAccountID

    cnn.Open "FILEDSN=" & strFileDSN
    cnn.Execute strSQL

    objContext.SetComplete

    Exit Function

ErrorHandler:
    If Not cnn Is Nothing Then Set cnn = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.Update()", Err.Description

End Function

Function ChangePassword(ByVal strFileDSN As String, ByVal lngAccountID As Long, _
     ByVal strPassword As String)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim cnn As New ADODB.Connection
    strSQL = "UPDATE Member " & _
        "SET Password = '" & SQLEncode(strPassword) & "' " & _
        "WHERE AccountID = " & lngAccountID

    cnn.Open "FILEDSN=" & strFileDSN
    cnn.Execute strSQL

    objContext.SetComplete

    Exit Function

ErrorHandler:
    If Not cnn Is Nothing Then Set cnn = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.ChangePassword()", Err.Description

End Function

Function Remove(ByVal strFileDSN As String, ByVal lngAccountID As Long)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim cnn As New ADODB.Connection

    strSQL = "DELETE FROM Member WHERE AccountID = " & lngAccountID
    cnn.Open "FILEDSN=" & strFileDSN
    cnn.Execute strSQL

    objContext.SetComplete

    Exit Function

ErrorHandler:
    If Not cnn Is Nothing Then Set cnn = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.Remove()", Err.Description

End Function

Function UpdateInterests(ByVal strFileDSN As String, ByVal lngAccountID As Long, Interests)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim cnn As New ADODB.Connection, varItem As Variant

    strSQL = "DELETE FROM MembersInterests WHERE AccountID = " & lngAccountID

    cnn.Open "FILEDSN=" & strFileDSN
    cnn.Execute strSQL
    For Each varItem In Interests
        strSQL = "INSERT INTO MembersInterests (AccountID, InterestID) " & _
                "VALUES (" & lngAccountID & "," & varItem & ")"
        cnn.Execute strSQL
    Next

    objContext.SetComplete
    UpdateInterests = 0

    Exit Function

ErrorHandler:
    If Not cnn Is Nothing Then Set cnn = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.UpdateInterests()", Err.Description

End Function

Private Function SQLEncode(str As String) As String

    Dim vntPosition As Variant

    If IsNull(str) Or str = "" Then

    Else
        vntPosition = InStr(str, "'")
        Do While vntPosition <> 0
            str = Mid(str, 1, vntPosition - 1) & "`'`" & Mid(str, vntPosition + 1)
            vntPosition = InStr(vntPosition + 2, str, "'")
        Loop
    End If
    SQLEncode = str

End Function

Private Function InventPassword() As String

    Dim strPass As String, x
    Randomize

    For x = 1 To 5
        strPass = strPass & Chr(Int((25 * Rnd) + 65))
    Next

    InventPassword = strPass

End Function

Function GetForID(ByVal strFileDSN As String, ByVal lngAccountID As Long) As Variant

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim rst As New ADODB.Recordset

    strSQL = "SELECT FirstName," & _
                "LastName," & _
                "MiddleName," & _
                "KnownAs," & _
                "Password," & _
                "Gender," & _
                "Address1," & _
                "Address2," & _
                "City," & _
                "State," & _
                "PostCode," & _
                "Country," & _
                "HomePhone," & _
                "BusinessPhone," & _
                "Fax," & _
                "Email," & _
                "WebSite," & _
                "Mileage," & _
                "Seating," & _
                "Smoking," & _
                "Bulkhead," & _
                "ExitRow," & _
                "Meal," & _
                "Comment " & _
            "FROM Member WHERE AccountID = " & lngAccountID

    rst.CursorLocation = adUseServer
    rst.Open strSQL, "FILEDSN=" & strFileDSN, adOpenStatic, adLockReadOnly, adCmdText

    objContext.SetComplete
    Set GetForID = rst
    Exit Function

ErrorHandler:
    If Not rst Is Nothing Then Set rst = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.GetForID()", Err.Description

End Function

Function ListForName(ByVal strFileDSN As String, ByVal strLastName As String)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim rst As New ADODB.Recordset

    strSQL = "SELECT FirstName," & _
                "LastName," & _
                "MiddleName," & _
                "KnownAs," & _
                "Gender," & _
                "Address1," & _
                "Address2," & _
                "City," & _
                "State," & _
                "PostCode," & _
                "Country," & _
                "HomePhone," & _
                "BusinessPhone," & _
                "Fax," & _
                "Email," & _
                "WebSite," & _
                "Mileage," & _
                "Comment " & _
            "FROM Member WHERE LastName = '" & strLastName & "'"

    rst.CursorLocation = adUseServer
    rst.Open strSQL, "FILEDSN=" & strFileDSN, adOpenStatic, adLockReadOnly, adCmdText

    objContext.SetComplete
    Set ListForName = rst

    Exit Function

ErrorHandler:
    If Not rst Is Nothing Then Set rst = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.ListForName()", Err.Description

End Function

Function CheckPassword(ByVal strFileDSN As String, ByVal lngAccountID As Long, ByVal strPassword As String)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim rst As New ADODB.Recordset

    strSQL = "SELECT Password FROM Member WHERE AccountID = " & lngAccountID

    rst.CursorLocation = adUseServer
    rst.Open strSQL, "FILEDSN=" & strFileDSN, adOpenForwardOnly, adLockReadOnly

    'check to see if an account exists for that ID, if so then check password
    If rst.EOF Then
        CheckPassword = 0
    ElseIf rst("Password") = strPassword Then
        CheckPassword = 1
    Else
        CheckPassword = 0
    End If

    objContext.SetComplete

    Exit Function

ErrorHandler:
    If Not rst Is Nothing Then Set rst = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.CheckPassword()", Err.Description

End Function


Function ListInterests(ByVal strFileDSN As String, ByVal lngAccountID As Long)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim rst As New ADODB.Recordset

    strSQL = "SELECT Interests.InterestID, " & _
                    "Interests.InterestDescription, " & _
                    "MembersInterests.AccountID, " & _
                    "InterestCategories.Description " & _
             "FROM (Interests INNER JOIN InterestCategories " & _
                        "ON Interests.CategoryID = InterestCategories.CategoryID) " & _
                    "LEFT JOIN MembersInterests " & _
                        "ON Interests.InterestID = MembersInterests.InterestID " & _
                        "AND MembersInterests.AccountID =  " & lngAccountID & _
             "ORDER BY InterestCategories.SortOrder,  " & _
                       "Interests.InterestDescription"

    rst.CursorLocation = adUseServer
    rst.Open strSQL, "FILEDSN=" & strFileDSN, adOpenStatic, adLockReadOnly, adCmdText

    objContext.SetComplete
    Set ListInterests = rst

    Exit Function

ErrorHandler:
    If Not rst Is Nothing Then Set rst = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.ListInterests()", Err.Description

End Function

Function GetMileage(ByVal strFileDSN As String, ByVal lngAccountID As Long)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim rst As New ADODB.Recordset

    strSQL = "SELECT Mileage FROM Member WHERE AccountID = " & lngAccountID

    rst.CursorLocation = adUseServer
    rst.Open strSQL, "FILEDSN=" & strFileDSN, adOpenStatic, adLockReadOnly, adCmdText

    objContext.SetComplete
    GetMileage = rst("Mileage")

    Exit Function

ErrorHandler:
    If Not rst Is Nothing Then Set rst = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.GetMileage()", Err.Description

End Function

Function GetPassword(ByVal strFileDSN As String, ByVal lngAccountID As Long)

    Dim objContext As ObjectContext
    Set objContext = GetObjectContext

    On Error GoTo ErrorHandler

    Dim strSQL As String
    Dim rst As New ADODB.Recordset

    strSQL = "SELECT Password FROM Member WHERE AccountID = " & lngAccountID

    rst.CursorLocation = adUseServer
    rst.Open strSQL, "FILEDSN=" & strFileDSN, adOpenStatic, adLockReadOnly, adCmdText

    objContext.SetComplete
    GetPassword = rst("Password")

    Exit Function

ErrorHandler:
    If Not rst Is Nothing Then Set rst = Nothing

    objContext.SetAbort
    Err.Raise Err.Number, "Member.GetPassword()", Err.Description

End Function