mlog.bas

Some scheduling software.

Attribute VB_Name = "mLog"
Public Type RecSchedule
    ID As Integer
    Enabled As Boolean
    Title As String
    StartDate As Date
    EndDate As Date
    StartTimeHour As Integer
    StartTimeMinute As Integer
    EndTimeHour As Integer
    EndTimeMinute As Integer
    IntervalHour As Integer
    IntervalMinute As Integer
    EveryDay As Integer
    Notes As String
End Type
Public dummy As RecSchedule
Public rs() As RecSchedule
Public alertON As Boolean
Public Active_Sch As Integer
Public Manager_Enabled  As Boolean
Public Const vbext_ws_Min = 1

Public Function doAlert()
Dim i As Integer, j As Integer, ub As Integer
Dim str As String
Dim stt As Integer  ' Start Time
Dim stp As Integer  ' Stop Time
Dim crt As Integer  ' Current Time
    On Error GoTo ErrorHandle
    ub = UBound(rs)
    If ub = 0 Then Exit Function
    With Manager
        str = ""
        For i = 1 To ub
            stt = rs(i).StartTimeHour * 60 + rs(i).StartTimeMinute  ' Map betweeh 0 to 3600
            stp = rs(i).EndTimeHour * 60 + rs(i).EndTimeMinute      ' Map betweeh 0 to 3600
            crt = Hour(Time) * 60 + Minute(Time)                    ' Map betweeh 0 to 3600
            If rs(i).StartDate <= Date And Date <= rs(i).EndDate Then   ' Date is OK
                If stt < stp And stt <= crt And crt <= stp Then         ' stt < crt < stp
                    str = str & rs(i).Notes & vbCrLf
                End If
                If stt > stp And crt <= stt And stp <= crt Then         ' stp < crt < stt
                    str = str & rs(i).Notes & vbCrLf
                End If
            End If
        Next i
        If str <> "" Then
            alert.AlertMessage = str
            alert.Show vbModal, Manager
        End If
    End With
    DoEvents
    Exit Function

ErrorHandle:
    ErrLog "Error occurred in function doAlert()"
    DoEvents
    Exit Function
End Function

Public Function getTokenPair(str As String, token As String) As String
Dim i As Integer, j As Integer
Dim tmp As String, stp As String
Dim pair As Variant
    
    On Error GoTo ErrorHandle
    If Trim(str) = "" Then Exit Function
    If Trim(token) = "" Then Exit Function
    pair = Split(Trim(token), " ", , vbBinaryCompare)
    If UBound(pair) <> 1 Then Exit Function
    If Trim(pair(0)) = "" Then Exit Function
    If Trim(pair(1)) = "" Then Exit Function
    i = InStr(1, str, pair(0), vbBinaryCompare)
    j = InStr(1, str, pair(1), vbBinaryCompare)
    If i > 0 And j > 0 Then
        tmp = Mid(str, i + Len(pair(0)), j - i - Len(pair(0)))
    ElseIf i > 0 And j = 0 Then
        tmp = Mid(str, i + Len(pair(0)), Len(str) - i - Len(pair(0)))
    ElseIf i = 0 And j > 0 Then
        tmp = vbCrLf & Mid(str, 1, j - 1)
    Else
        tmp = vbCrLf & str
    End If
    getTokenPair = tmp
    DoEvents
    Exit Function

ErrorHandle:
    ErrLog ("Error occurred in function getTokenPair(str As String, token As String)")
    DoEvents
    Exit Function
End Function

Public Function loadRC()
Dim fnum As Integer
Dim fpath As String, str As String
Dim i As Integer, stt As Integer, stp As Integer
Dim Current As Boolean

    On Error Resume Next
    
    ReDim Preserve rs(0) As RecSchedule
    rs(0) = dummy
    
    fpath = App.Path & "\schedule.ini"
    If Dir(fpath) = "" Then GoTo ErrorHandle
    fnum = FreeFile
    Open fpath For Input As fnum
    
    i = 1
    Current = False
    While Not EOF(fnum)
        Input #fnum, str
        If Not Current Then
            If Left(str, 11) = "<RECORDSET>" Then
                Current = True
                ReDim Preserve rs(i) As RecSchedule
            End If
        End If
        If Current And Left(str, 11) = "<RECORDSET>" Then
            rs(i).ID = i
            rs(i).Enabled = CBool(getTokenPair(str, "<ENABLED> </ENABLED>"))
            rs(i).Title = getTokenPair(str, "<TITLE> </TITLE>")
            rs(i).StartDate = CDate(getTokenPair(str, "<STARTDATE> </STARTDATE>"))
            rs(i).EndDate = CDate(getTokenPair(str, "<ENDDATE> </ENDDATE>"))
            rs(i).StartTimeHour = CInt(getTokenPair(str, "<STARTIMETHOUR> </STARTIMETHOUR>"))
            rs(i).EndTimeHour = CInt(getTokenPair(str, "<ENDTIMEHOUR> </ENDTIMEHOUR>"))
            rs(i).IntervalHour = CInt(getTokenPair(str, "<INTERVALHOUR> </INTERVALHOUR>"))
            rs(i).StartTimeMinute = CInt(getTokenPair(str, "<STARTTIMEMINUTE> </STARTTIMEMINUTE>"))
            rs(i).EndTimeMinute = CInt(getTokenPair(str, "<ENDTIMEMINUTE> </ENDTIMEMINUTE>"))
            rs(i).IntervalMinute = CInt(getTokenPair(str, "<INTERVALMUNUTE> </INTERVALMUNUTE>"))
            rs(i).EveryDay = CInt(getTokenPair(str, "<EVERYDAY> </EVERYDAY>"))
            rs(i).Notes = getTokenPair(str, "<NOTES> </NOTES>")
            If InStr(1, str, "</RECORDSET>", vbBinaryCompare) <> 0 Then
                Current = False
                i = i + 1
            End If
        End If
        If Current And Left(str, 11) <> "<RECORDSET>" Then
            rs(i).Notes = rs(i).Notes & getTokenPair(str, "<NOTES> </NOTES>")
            If InStr(1, str, "</RECORDSET>", vbBinaryCompare) <> 0 Then
                Current = False
                i = i + 1
            End If
        End If
    Wend
    Close #fnum
    DoEvents
    Exit Function
    
ErrorHandle:
    ErrLog "Error occurred in function loadRC()"
    DoEvents
    Exit Function
End Function

Public Function saveRC()
Dim fnum As Integer
Dim fpath As String, str As String
Dim i As Integer, j As Integer
Dim Current As Boolean

    On Error Resume Next
    fpath = App.Path & "\schedule.ini"
    fnum = FreeFile
    Open fpath For Output As fnum
    Write #fnum, "Eye-Care V1.00"
    j = UBound(rs)
    If j < 0 Then Exit Function
    
    For i = 1 To j
        str = "<RECORDSET>"
        str = str & "<ID>" & rs(i).ID & "</ID>"
        str = str & "<ENABLED>" & rs(i).Enabled & "</ENABLED>"
        str = str & "<TITLE>" & rs(i).Title & "</TITLE>"
        str = str & "<STARTDATE>" & rs(i).StartDate & "</STARTDATE>"
        str = str & "<ENDDATE>" & rs(i).EndDate & "</ENDDATE>"
        str = str & "<STARTIMETHOUR>" & rs(i).StartTimeHour & "</STARTIMETHOUR>"
        str = str & "<ENDTIMEHOUR>" & rs(i).EndTimeHour & "</ENDTIMEHOUR>"
        str = str & "<INTERVALHOUR>" & rs(i).IntervalHour & "</INTERVALHOUR>"
        str = str & "<STARTTIMEMINUTE>" & rs(i).StartTimeMinute & "</STARTTIMEMINUTE>"
        str = str & "<ENDTIMEMINUTE>" & rs(i).EndTimeMinute & "</ENDTIMEMINUTE>"
        str = str & "<INTERVALMUNUTE>" & rs(i).IntervalMinute & "</INTERVALMUNUTE>"
        str = str & "<EVERYDAY>" & rs(i).EveryDay & "</EVERYDAY>"
        str = str & "<NOTES>" & rs(i).Notes & "</NOTES></RECORDSET>" & vbCrLf
        Write #fnum, str
    Next i

    Close #fnum
    DoEvents
    Exit Function
    
ErrorHandle:
    ErrLog "Error occurred in function saveRC()"
    DoEvents
    Exit Function
End Function

Public Function updateRC(sel As Integer)
Dim tmp As RecSchedule, i As Integer

    On Error Resume Next
    If sel = 0 Then
        With planner
            i = Active_Sch
            If i < 1 Then GoTo ErrorHandle
            If UBound(rs) < i Then ReDim Preserve rs(i) As RecSchedule
            rs(i).Title = .txtTitle
            rs(i).StartDate = .txtDate(0)
            rs(i).EndDate = .txtDate(1)
            rs(i).StartTimeHour = .cmbHour(0)
            rs(i).EndTimeHour = .cmbHour(1)
            rs(i).IntervalHour = .cmbHour(2)
            rs(i).StartTimeMinute = .cmbMinute(0)
            rs(i).EndTimeMinute = .cmbMinute(1)
            rs(i).IntervalMinute = .cmbMinute(2)
            rs(i).Notes = .txtNotes
            rs(i).EveryDay = .chkEveryday.Value
        End With
    ElseIf sel = 1 Then
        i = Active_Sch
        If i < 1 Then GoTo ErrorHandle
        If UBound(rs) < i Then GoTo ErrorHandle
        rs(i).Enabled = Manager.lstSchedules.Selected(i - 1)
    End If
    saveRC
    
    DoEvents
    Exit Function
    
ErrorHandle:
    ErrLog "Error occurred in function updateRC()"
    DoEvents
    Exit Function
End Function

Public Function displayRC(i As Integer)
Dim tmp As RecSchedule
    
    On Error Resume Next
    If i < 1 Then GoTo ErrorHandle
    With planner
        .txtTitle = rs(i).Title
        .txtDate(0) = rs(i).StartDate
        .txtDate(1) = rs(i).EndDate
        .cmbHour(0).Text = rs(i).StartTimeHour
        .cmbHour(1).Text = rs(i).EndTimeHour
        .cmbHour(2).Text = rs(i).IntervalHour
        .cmbMinute(0).Text = rs(i).StartTimeMinute
        .cmbMinute(1).Text = rs(i).EndTimeMinute
        .cmbMinute(2).Text = rs(i).IntervalMinute
        .txtNotes = rs(i).Notes
        .chkEveryday.Value = rs(i).EveryDay
        .Refresh
    End With

    DoEvents
    Exit Function
    
ErrorHandle:
    ErrLog "Error occurred in function displayRC(i)"
    DoEvents
    Exit Function
End Function

Public Function initialize()
Dim dt As Date, i As Integer, str As String
    On Error Resume Next
    
    dummy.Title = "New Title"
    dummy.ID = 0
    dummy.Enabled = False
    dummy.StartDate = Date
    dummy.EndDate = Date + 7
    dummy.StartTimeHour = 12
    dummy.StartTimeMinute = 0
    dummy.EndTimeHour = 12
    dummy.EndTimeMinute = 0
    dummy.IntervalHour = 1
    dummy.IntervalMinute = 0
    dummy.EveryDay = 0
    dummy.Notes = "EMPTY"
End Function

Public Function populateLst(i As Integer)
Dim record As Variant
Dim boo As Boolean, j As Integer, ub As Integer
    On Error Resume Next
    With Manager
        .lstSchedules.Clear
        ub = UBound(rs)
        For j = 0 To ub
            If j <> 0 Then
                .lstSchedules.AddItem rs(j).Title
                If rs(j).Enabled = True Then .lstSchedules.Selected(j - 1) = True
            End If
        Next j
        If ub > 0 And i < ub Then
            .lstSchedules.ListIndex = i
            Active_Sch = i + 1
        End If
    End With
End Function

Public Function mv_UP()
Dim i As Integer
Dim record As RecSchedule
    On Error Resume Next
    With Manager
        i = .lstSchedules.ListIndex
        If i <> 0 And i <> -1 Then
            i = i + 1
            record = rs(i)
            rs(i) = rs(i - 1)
            rs(i - 1) = record
            Call populateLst(i - 2)
            saveRC
        End If
    End With
End Function

Public Function mv_DOWN()
Dim i As Integer
Dim record As RecSchedule
    On Error Resume Next
    With Manager
        i = .lstSchedules.ListIndex
        If i <> .lstSchedules.ListCount - 1 And i <> -1 Then
            i = i + 1
            record = rs(i)
            rs(i) = rs(i + 1)
            rs(i + 1) = record
            Call populateLst(i)
            saveRC
        End If
    End With
End Function

Public Function mv_COPY()
Dim i As Integer, ub As Integer, j As Integer
Dim record As RecSchedule
    On Error Resume Next
    With Manager
        i = .lstSchedules.ListIndex
        ub = UBound(rs)
        If i <> -1 Then
            i = i + 1
            ReDim Preserve rs(ub + 1) As RecSchedule
            For j = ub + 1 To 1 Step -1
                If j <= i Then
                Else
                    rs(j) = rs(j - 1)
                End If
            Next j
            Call populateLst(i)
            saveRC
        End If
    End With
End Function

Public Function mv_DELETE()
Dim i As Integer
Dim record As RecSchedule
    On Error Resume Next
    With Manager
        i = .lstSchedules.ListIndex
        ub = UBound(rs)
        If i <> -1 And ub > 1 Then
            For j = 1 To ub - 1
                If j < i + 1 Then
                Else
                    rs(j) = rs(j + 1)
                End If
            Next j
            ReDim Preserve rs(ub - 1)
        End If
        If i <> -1 And ub = 1 Then
            ReDim Preserve rs(0)
            rs(0) = dummy
        End If
        saveRC
        Call populateLst(i)
    End With
End Function

Public Function mv_NEW()
Dim i As Integer, ub As Integer
Dim record As RecSchedule
    On Error Resume Next
    With Manager
        i = .lstSchedules.ListIndex
        ub = UBound(rs)
        ReDim Preserve rs(ub + 1) As RecSchedule
        rs(ub + 1) = dummy
        populateLst ub
        mv_EDIT
        populateLst ub
        saveRC
    End With
End Function

Public Function mv_EDIT()
    Active_Sch = Manager.lstSchedules.ListIndex + 1
    displayRC Active_Sch
    planner.Show vbModal, Manager
End Function

Public Function ErrLog(str As String)
Dim fnum As Integer
    On Error Resume Next
    fnum = FreeFile
    Open "err.txt" For Append As fnum
    Write #fnum, InText & vbCrLf
    Close fnum
End Function