vrental_engine.cls

ado+ACCE

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "VRENTAL_ENGINE"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'Option Base 1
Function CheckPermission(Level As Integer, Fcode As Integer) As Boolean
Dim loop1, loop2, counter As Integer
Dim str As String
Dim db As Database
Dim rec As Recordset
Set db = OpenDatabase(App.Path & "\Permission.mdb" _
             , False, False, ";pwd=AdmiN")
Set rec = db.OpenRecordset("PermissionTable", dbOpenTable)
counter = 0
    rec.MoveFirst
For loop1 = 1 To Level
    str = Trim(rec.Fields("Permissions"))
    For loop2 = 1 To 7
        If loop2 = Fcode And loop1 = Level Then
           If Int(Val(Mid(str, loop2, 1))) = 1 Then
              CheckPermission = True
              Exit Function
           Else
              MsgBox "You don't have the permission to use this feature.  ", vbInformation, "Access Denied"
              CheckPermission = False
              Exit Function
           End If
        End If
        counter = counter + 1
    Next loop2
    If rec.EOF = False Then rec.MoveNext
Next loop1

Set db = Nothing
Set rec = Nothing
End Function
Function Date_GETDATE(NumberOfDaysFromJanYear1 As Long) As String
    Dim YearCount As Integer
    Dim Days, i, iMonth(12) As Integer
    Dim GET_Day As Long
    Dim strDay As String
    'Get Day
     GET_Day = NumberOfDaysFromJanYear1 Mod 7
     
   Select Case GET_Day
    Case 1: strDay = "Sunday"
    Case 2: strDay = "Monday"
    Case 3: strDay = "Tuesday"
    Case 4: strDay = "Wednesday"
    Case 5: strDay = "Thursday"
    Case 6: strDay = "Friday"
    Case 0: strDay = "Saturday"
   End Select
    
    iMonth(1) = 31 'Jan
    iMonth(2) = 28 'Feb
    iMonth(3) = 31 'Mar
    iMonth(4) = 30 'Apr
    iMonth(5) = 31 'May
    iMonth(6) = 30 'Jun
    iMonth(7) = 31 'Jul
    iMonth(8) = 31 'Aug
    iMonth(9) = 30 'Sep
    iMonth(10) = 31 'Oct
    iMonth(11) = 30 'Nov
    iMonth(12) = 31 'Dec
    
    'Get Year
    YearCount = 1
    Days = 365
    Do While NumberOfDaysFromJanYear1 > Days
       NumberOfDaysFromJanYear1 = NumberOfDaysFromJanYear1 - Days
       If NumberOfDaysFromJanYear1 > 0 Then YearCount = YearCount + 1
       If YearCount Mod 4 = 0 Then
          Days = 366
       Else
          Days = 365
       End If
    Loop
    
    'Get Month and Day
    If YearCount Mod 4 = 0 Then iMonth(2) = 29
    If NumberOfDaysFromJanYear1 <> 0 Then
      i = 1
      Do While NumberOfDaysFromJanYear1 > iMonth(i)
         NumberOfDaysFromJanYear1 = NumberOfDaysFromJanYear1 - iMonth(i)
         i = i + 1
      Loop
    Else
      i = 12
      NumberOfDaysFromJanYear1 = 31
    End If
    
   Date_GETDATE = str(i) & "/" & Trim(str(NumberOfDaysFromJanYear1)) & "/" & Trim(str(YearCount))
    
End Function
Function Date_CountNumberOfDaysFromJan1Year1ToDec31YearEntered(YearEntered As Long) As Long
    Dim TotalDays, Year As Long
    Dim Days, DaysInAYear, counter As Integer

    TotalDays = 730500 ' No. Of days from 1/1/1 to 12/31/2000
    counter = 1
    DaysInAYear = 365
'730499
    For Year = 2001 To YearEntered
        For Days = 1 To DaysInAYear
            TotalDays = TotalDays + 1
        Next Days
        counter = counter + 1
        If counter = 4 Then  ' Leap Year
            counter = 0
            DaysInAYear = 366
        Else
            DaysInAYear = 365
        End If
    Next Year

    Date_CountNumberOfDaysFromJan1Year1ToDec31YearEntered = TotalDays

End Function
Function Date_CountDaysInAYear(DateEntered As String) As Integer
Dim DateDay, DateMonth, DateYear, iMonth(12), _
    loop1, TotalDays As Integer

iMonth(1) = 31 'Jan
iMonth(2) = 28 'Feb
iMonth(3) = 31 'Mar
iMonth(4) = 30 'Apr
iMonth(5) = 31 'May
iMonth(6) = 30 'Jun
iMonth(7) = 31 'Jul
iMonth(8) = 31 'Aug
iMonth(9) = 30 'Sep
iMonth(10) = 31 'Oct
iMonth(11) = 30 'Nov
iMonth(12) = 31 'Dec

   DateYear = Year(DateEntered)
   DateMonth = Month(DateEntered)
   DateDay = Day(DateEntered)
'Check if year is leapyear
If DateYear Mod 4 = 0 Then iMonth(2) = 29
TotalDays = 0
For loop1 = 1 To DateMonth
   If loop1 = DateMonth Then TotalDays = TotalDays + DateDay
   If loop1 < DateMonth Then TotalDays = TotalDays + iMonth(loop1)
Next loop1

Date_CountDaysInAYear = TotalDays

End Function
Sub CopyFlexDataToExcel(Flex As MSFlexGrid)
On Error GoTo ErrHandler
Dim EXCELApp As Excel.Application
Dim EXCELWorkBook As Excel.Workbook
Dim Rows, Cols As Integer
Dim iRow, hCol, iCol As Integer
Dim New_Col As Boolean


    If Flex.Rows <= 1 Then
        MsgBox "No Data to extract", vbInformation, App.Title
        Exit Sub
    End If
    
    Set EXCELApp = CreateObject("Excel.application")
    Set EXCELWorkBook = EXCELApp.Workbooks.Add
    
    Dim New_Column As Boolean
    
    With Flex
        Rows = .Rows
        Cols = .Cols
        iRow = 0
        iCol = 1
        For hCol = 0 To Cols - 1
            For iRow = 1 To Rows
                EXCELApp.Cells(iRow + 1, iCol + 1).Value = .TextMatrix(iRow - 1, hCol)
            Next iRow
            iCol = iCol + 1
        Next hCol
    End With
    
    EXCELApp.Rows(2).Font.Bold = True
    EXCELApp.Cells.Select
    EXCELApp.Columns.AutoFit
    EXCELApp.Cells(1, 1).Select
    EXCELApp.Application.Visible = True
    
    Set EXCELWorkBook = Nothing
    Set EXCELApp = Nothing
    Flex.SetFocus
    MsgBox "Data has been successfully copied to Excel. ", vbInformation, "Success"
Exit Sub
ErrHandler:
  MsgBox "Unable to open EXCEL. ", vbInformation, "Info "
End Sub
Public Function ReplaceString(ByVal TextString As String, ByVal FromString As String, ByVal ToString As String)
Dim new_TextString As String
Dim Position As Integer

    Do While Len(TextString) > 0
        Position = InStr(TextString, FromString)
        If Position = 0 Then
            new_TextString = new_TextString & TextString
            TextString = ""
        Else
            new_TextString = new_TextString & Left$(TextString, Position - 1) & ToString
            TextString = Mid$(TextString, Position + Len(FromString))
        End If
    Loop

    ReplaceString = new_TextString
End Function
Function LogOnValidate(UserName As String, Password As String) As String

    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer

    LogOnValidate = 0
    
    Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb" _
             , False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("Users", dbOpenTable)
    
    rec.MoveFirst
    If rec.RecordCount > 0 Then
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            If rec.Fields("User Name") = UserName And _
                rec.Fields("Password") = Password Then
               
                LogOnValidate = "User ID : " & rec.Fields("UserID") & vbCrLf _
                                & "Date Entered : " & rec.Fields("Date Entered") & vbCrLf _
                                & "User Name : " & rec.Fields("User Name") & vbCrLf _
                                & "Password : " & rec.Fields("Password") & vbCrLf _
                                & "Access Level : " & rec.Fields("AccessLevel") & vbCrLf _
                                & "First Name : " & rec.Fields("First Name") & vbCrLf _
                                & "Middle Name : " & rec.Fields("Middle Name") & vbCrLf _
                                & "Family Name : " & rec.Fields("Family Name") & vbCrLf _
                                & "Birthday : " & rec.Fields("Birthday") & vbCrLf & "Age : " & str(GetAge(rec.Fields("Birthday"))) & vbCrLf _
                                & "Sex : " & rec.Fields("Sex") & vbCrLf _
                                & "Home Address : " & rec.Fields("Home Address") & vbCrLf _
                                & "Contact Number : " & rec.Fields("Contact Number") & vbCrLf _
                                & "Comments : " & rec.Fields("Comments") & vbCrLf
                Exit For
            Else
                LogOnValidate = ""
            End If
            rec.MoveNext  ' Move to the next record
        Next loop1
    End If
    
    db.Close
    
End Function

Public Sub ChangePassword(NewPWD As String, UserName As String)
     
    Dim db As Database
    Dim rec As Recordset
    Dim TDM As Variant
    Dim loop1 As Integer


    
    Set db = OpenDatabase(App.Path & "\Database\UsersDB.mdb" _
             , False, False, ";pwd=AdmiN")
    Set rec = db.OpenRecordset("Users", dbOpenTable)
    
    rec.MoveFirst
    If rec.RecordCount > 0 Then
        For loop1 = 1 To rec.RecordCount
            TDM = DoEvents()
            If rec.Fields("User Name") = UserName Then
                '' Start Change Password
                rec.Edit
                rec.Fields("Password") = NewPWD
                rec.Update
                '' End Change Password
            End If
        
            rec.MoveNext  ' Move to the next record
        Next loop1
     End If
     
      db.Close
End Sub
Function GetAge(myDate As Variant) As Integer
 Dim numyears, numMonths
 myDate = CDate(myDate)
 Dim TotalDays As Long
 TotalDays = DateDiff("y", myDate, Date)
 numyears = Abs(TotalDays / 365.25)
 numMonths = (numyears - Int(numyears)) * 365.25 / 30.4583
 GetAge = Int(numyears)
End Function

Function ReportFileStatus(filespec) As Boolean '' Check if file is present
   Dim fso, msg
   Set fso = CreateObject("Scripting.FileSystemObject")
   If (fso.FileExists(filespec)) Then
      msg = -1
   Else
      msg = 0
   End If