src.txt.bak

Some scheduling software.

Public Function SaveSchedule()
'Public Function WriteInitial(str As String) As Boolean
Dim fnum As Integer, fpath As String, str As String

    On Error GoTo ErrorHandle
    fpath = App.path & "\schedule.inf"
    fnum = FreeFile
    Open fpath For Output As fnum

    Write #fnum, "Eye-Care V1.00" & Chr(10)
    Write #fnum, "Creation Date " & Date & Chr(10)
    str =
    Close #fnum
    WriteInitial = True
    Exit Function

ErrorHandle:
    Close #fnum
    WriteInitial = False
    ErrorLog "Error in function WriteInitial(" & str & ")"
    Exit Function
End Function
End Function


Public Function FG2_Select()
' Select a cell and display Title, Author, Subject and Keywords in
' the textboxes.
Dim lRow As Long, lRows As Long
Dim i As Integer
    On Error GoTo ErrorHandle
    With frmPDFBrowser
        lRow = .FlexGrid1.row
        lRows = .FlexGrid1.Rows
        If lRow <> 0 And lRow <> lRows - 1 Then
            .lblFileName = .FlexGrid1.TextMatrix(lRow, 1)
            .txtTitle = .FlexGrid1.TextMatrix(lRow, 2)
            .txtAuthor = .FlexGrid1.TextMatrix(lRow, 3)
            .txtSubject = .FlexGrid1.TextMatrix(lRow, 4)
            .txtKeywords = .FlexGrid1.TextMatrix(lRow, 5)
        End If
    End With
    
    Exit Function
ErrorHandle:
    ErrorLog "Error in function FG2_Select()"
    Exit Function
End Function

Public Function Add2Collection() As Boolean
' Catches the selected row in FlexGrid and deposit into FlexGrid1
Dim lRow As Long, lRow1 As Long, iCol As Integer, iCol1 As Integer
Dim i As Long, InCollection As Boolean
Dim lRows As Long, lRows1 As Long, iCols As Integer, iCols1 As Integer
Dim boo As Boolean
    On Error GoTo ErrorHandle
    lRow = frmPDFBrowser.FlexGrid.row
    iCol = frmPDFBrowser.FlexGrid.col
    lRows1 = frmPDFBrowser.FlexGrid1.Rows
    iCols1 = frmPDFBrowser.FlexGrid1.Cols
    InCollection = False
    With frmPDFBrowser
        For i = 1 To lRows1 - 2
            If .FlexGrid1.TextMatrix(i, 1) = .FlexGrid.TextMatrix(lRow, 1) Then
                InCollection = True
            End If
        Next i
        If InCollection = False Then
            .FlexGrid1.Rows = lRows1 + 1
            .FlexGrid1.TextMatrix(lRows1 - 1, 0) = lRows1 - 1
            .FlexGrid1.TextMatrix(lRows1 - 1, 1) = .FlexGrid.TextMatrix(lRow, 1)
            .FlexGrid1.TextMatrix(lRows1 - 1, 2) = .FlexGrid.TextMatrix(lRow, 2)
            .FlexGrid1.TextMatrix(lRows1 - 1, 3) = .FlexGrid.TextMatrix(lRow, 3)
            .FlexGrid1.TextMatrix(lRows1 - 1, 4) = .FlexGrid.TextMatrix(lRow, 4)
            .FlexGrid1.TextMatrix(lRows1 - 1, 5) = .FlexGrid.TextMatrix(lRow, 5)
            boo = WriteRecords(frmPDFBrowser.strCollName, .FlexGrid1, True)
        End If
    End With
    Add2Collection = True
    
    Exit Function
ErrorHandle:
    Add2Collection = False
    ErrorLog "Error in function Add2Collection()"
    Exit Function
End Function

Public Function OpenPDF()
' Open selected row in FlexGrid and FlexGrid and opens in PDF Reader
Dim lRow As Integer
Dim str As String

    On Error GoTo ErrorHandle
    With objFG
        lRow = .row
        If lRow <> 0 And lRow <> .Rows - 1 Then
            str = Trim(.TextMatrix(lRow, 1))
            If str <> "" Then
                frmPDFBrowser.pdfdoc.LoadFile Trim(str)
                frmPDFBrowser.SSTab.Tab = 1
                strOpenPDF = str
                frmPDFBrowser.Caption = "Open File ... " & str
                frmPDFBrowser.Refresh
            End If
        End If
    End With
    Exit Function

ErrorHandle:
    ErrorLog "Error in function OpenPDF()"
    Exit Function
End Function

Public Function DeleteList(objFG As MSFlexGrid)
' Deletes selected row.
Dim lRows As Long, iCols As Integer
Dim lRow As Long, iCol As Integer
Dim i As Long

    On Error GoTo ErrorHandle
    With objFG
        lRows = .Rows
        iCols = .Cols
        lRow = .row
        iCol = .col
        If lRow <> lRows - 1 Then
            For i = lRow To lRows - 2
                .TextMatrix(i, 1) = .TextMatrix(i + 1, 1)
                .TextMatrix(i, 2) = .TextMatrix(i + 1, 2)
                .TextMatrix(i, 3) = .TextMatrix(i + 1, 3)
                .TextMatrix(i, 4) = .TextMatrix(i + 1, 4)
                .TextMatrix(i, 5) = .TextMatrix(i + 1, 5)
            Next i
            .Rows = lRows - 1
            WriteRecords Dir1.path, objFG
        Else: End If
    End With

    Exit Function
ErrorHandle:
    ErrorLog "Error in function DeleteList()"
    Exit Function
End Function


Public Function loadPDF(path As String, bolInclude As Boolean)
Dim row As Long, col As Integer, i As Integer, j As Long
Dim tmp As Variant
Dim fol As Folder
Dim fso As New FileSystemObject
Dim fols As Folders
Dim fils As Files
Dim fil As File
Dim tmp_arr(5) As String
Dim InCollection As Boolean

    On Error GoTo ErrorHandle

    Set fol = fso.GetFolder(path)
    Set fols = fol.SubFolders
    Set fils = fol.Files
    
    ReDim exten(0) As String
    exten(0) = "pdf"

    For Each fil In fils
        DoEvents
        For i = LBound(exten) To UBound(exten)
            DoEvents
            If fso.GetExtensionName(fil.path) = exten(i) Then
                With frmPDFBrowser
                    .lblIndicator.Caption = fol.path & "\" & fil.Name
                    .Refresh
                    row = .FlexGrid.Rows
                    col = .FlexGrid.Cols
                    
                    InCollection = False
                    For j = 1 To .FlexGrid1.Rows - 2
                        If .FlexGrid1.TextMatrix(j, 1) = fil.path Then
                            tmp_arr(0) = .FlexGrid1.TextMatrix(j, 1)
                            tmp_arr(1) = .FlexGrid1.TextMatrix(j, 2)
                            tmp_arr(2) = .FlexGrid1.TextMatrix(j, 3)
                            tmp_arr(3) = .FlexGrid1.TextMatrix(j, 4)
                            tmp_arr(4) = .FlexGrid1.TextMatrix(j, 5)
                            tmp = tmp_arr
                            InCollection = True
                        End If
                    Next j
                    
                    If Not InCollection Then
                        tmp = ExtractDocInfo(fil.path)
                    End If

                    .FlexGrid.Rows = row + 1
                    .FlexGrid.Cols = 6
                    .FlexGrid.TextMatrix(row - 1, 0) = row - 1
                    .FlexGrid.TextMatrix(row - 1, 1) = fil.path
                    .FlexGrid.TextMatrix(row - 1, 2) = tmp(1)
                    .FlexGrid.TextMatrix(row - 1, 3) = tmp(2)
                    .FlexGrid.TextMatrix(row - 1, 4) = tmp(3)
                    .FlexGrid.TextMatrix(row - 1, 5) = tmp(4)
    '                .FlexGrid.CellWidth = Int(.FlexGrid.Width / 5)
                    Set tmp = Nothing
                End With
            End If
        Next i
        DoEvents
    Next fil

    If bolInclude Then
        For Each fol In fols
            loadPDF fol.path, bolInclude
        Next
    End If
    
    Exit Function
ErrorHandle:
    ErrorLog "Error in function loadPDF()"
    Exit Function
End Function

Public Function ExtractDocInfo(str As String) As Variant
' This module extracts Author, Subject, Title, and Keyword
' from file str. ExtractDocInfo is returned as a 4 element
' string array. If any element is not found, an empty string.

Dim i As Integer, j As Integer, slice As Integer
Dim L1 As Long, L2 As Long, L3 As Integer
Dim str1 As String
Dim str2 As String * 512
Dim str3 As String * 8
Dim ver As String
Dim T1 As Integer, T2 As Integer, T3 As Integer, T4 As Integer
Dim tmp(4) As String

    On Error GoTo ErrorHandle
    tmp(1) = ""
    tmp(2) = ""
    tmp(3) = ""
    tmp(4) = ""
    T1 = 0
    T2 = 0
    T3 = 0
    T4 = 0

    If Dir(str) <> "" Then
        slice = 512
        j = Int(FileLen(str) / slice)
        j = j + 1
        
        Open str For Binary Access Read As #1
    
        Get #1, , str3
        If (str3 = "%PDF-1.4") Then
            ver = "1.4"
        ElseIf (str3 = "%PDF-1.2") Then
            ver = "1.2"
        End If
        
        For i = 1 To j
            Get #1, , str2
            
            If ver = "1.2" Then
                L1 = InStr(1, str2, "/Title (", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, ")", vbBinaryCompare)
                    L3 = Len("/Title (")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(1) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T1 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                L1 = InStr(1, str2, "/Author (", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, ")", vbBinaryCompare)
                    L3 = Len("/Author (")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(2) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T2 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                L1 = InStr(1, str2, "/Subject (", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, ")", vbBinaryCompare)
                    L3 = Len("/Subject (")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(3) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T3 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                L1 = InStr(1, str2, "/Keywords (", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, ")", vbBinaryCompare)
                    L3 = Len("/Keywords (")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(4) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T4 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                DoEvents
            ElseIf ver = "1.4" Then
                L1 = InStr(1, str2, "<pdf:Title>", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, "</pdf:Title>", vbBinaryCompare)
                    L3 = Len("<pdf:Title>")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(1) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T1 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                L1 = InStr(1, str2, "<pdf:Author>", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, "</pdf:Author>", vbBinaryCompare)
                    L3 = Len("<pdf:Author>")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(2) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T2 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                L1 = InStr(1, str2, "<pdf:Subject>", vbBinaryCompare)
                If L1 <> 0 Then
                    L2 = InStr(L1, str2, "</pdf:Subject>", vbBinaryCompare)
                    L3 = Len("<pdf:Subject>")
                    If L1 <> 0 And L2 <> 0 Then
                        tmp(3) = Mid(str2, L1 + L3, L2 - L3 - L1)
                        T3 = 1
                        If (T1 + T2 + T3 + T4 = 4) Then
                            Close 1
                            ExtractDocInfo = tmp
                            Exit Function
                        End If
                    End If
                End If
                
                L1 = InStr(1, str2, "<pdf:Keywords>", vbBinaryCompare)
                If L1 <> 0 Then