Liren Large Software Subsidy 10/10.iso/l/l408/2.img/EXAMPLES.EXE/EXAMPLES/INCLUTIL/INCLUTIL.SUB

Text File | 1992-10-12 | 7.8 KB | 259 lines

DefInt A-Z

Sub BadDriveMessage ()

    MsgBox "Invalid Drive or Drive Not Ready", 16

End Sub

Sub BadPathMessage ()

    MsgBox "Invalid path specified", 16

End Sub

Function IncludeExist% (Temp$)

    ' Function returns True if a file exists, else MhFalse
    ' First we check the current directory. If not found,
    ' we prepend the name of the INCLUDE paths, one at a
    ' time.
    Dim F As Integer
    WorkPath$ = IncludePath$
    TestPath$ = ""
TryAgain:
    On Error GoTo NotExist
    F = FreeFile
    If Len(TestPath$) Then
       If Right$(TestPath$, 1) <> "\" Then
          TestName$ = TestPath$ + "\" + Temp$
       Else
          TestName$ = TestPath$ + Temp$
       End If
    Else
       TestName$ = Temp$
    End If
    Open TestName$ For Input As #F
    Close F
    ' If we get here, then the file exists
    Temp$ = TestName$  'Reset the name to include the path
    IncludeExist% = True
    Exit Function
NotExist:
    If Len(WorkPath$) Then  ' If INCLUDE path not exhausted
       ' If the include file name already has a colon or backslash,
       ' there's no sense checking with prepended paths.
       If InStr(Temp$, ":") > 0 Or InStr(Temp$, "\") > 0 Then
          Resume Getout
       End If
       F = InStr(WorkPath$, ";")
       If F = 0 Then
          F = Len(WorkPath$) + 1
       End If
       TestPath$ = Left$(WorkPath$, F - 1)
       WorkPath$ = Mid$(WorkPath$, F + 1)
       Resume TryAgain
    Else
       Resume Getout
    End If
Getout:
    IncludeExist% = MhFalse

End Function

Function ConvertToQ$ (Temp$)

    ' This function takes a string with '*' and converts
    ' the asterisk to ?'s for comparison purposes with
    ' wildcard matches.

    Dim I As Integer, A As Integer, Count As Integer
    MainName$ = Temp$   ' in case no separators found
    ' Separate into main filename and extension
    For I = Len(Temp$) To 1 Step -1
        A = Asc(Mid$(Temp$, I, 1))
        Select Case A
            Case 46      ' Period - found extension
                MainName$ = Left$(Temp$, I - 1)
                Extension$ = Mid$(Temp$, I + 1)
                Exit For   ' Done
            Case 47, 58, 92 ' Forw slash, colon or backslash
                Exit For   ' Done
        End Select
    Next
    A = InStr(MainName$, "*")
    If A Then
        Count = 8
        For I = A - 1 To 1 Step -1
            ' Find first separator so we know how many ?'s to add
            A = Asc(Mid$(MainName$, I, 1))
            Select Case A
                Case 47, 58, 92 ' Forw slash, colon or backslash
                Exit For
                Case Else
                Count = Count - 1
            End Select
        Next
        MainName$ = Left$(MainName$, A - 1) + String$(Count, "?")
    End If
    A = InStr(Extension$, "*")
    If A Then
        Extension$ = Left$(Extension$, A - 1) + String$(3, "?")
        Extension$ = Left$(Extension$, 3)' Shorten to 3
    End If
    Extension$ = Left$(Extension$ + Question$, 3)' Fill out to 3
    MainName$ = Left$(MainName$ + Question$, 8)' Fill out to 8
    ConvertToQ$ = UCase$(MainName$ + "." + Extension$)

End Function

Function WildCardCompare% (S1$, S2$)

    ' This routine compares two strings, either one of
    ' which (or both) has the wildcard characters "?".

    ' Function returns True if they match, MhFalse if not
    Dim I As Integer, A As Integer, B As Integer
    If Len(S1$) = Len(S2$) Then
       For I = 1 To Len(S1$)
           A = Asc(Mid$(S1$, I, 1))
           If A <> 63 Then  ' If not a question mark
              B = Asc(Mid$(S1$, I, 1))
              ' If not a question mark, and they're not equal
              If (B <> 63) And (A <> B) Then
                 WildCardCompare% = MhFalse
                 Exit Function
              End If
           End If
       Next
       ' If we got here, then all chars compare
       WildCardCompare% = True
    Else
       WildCardCompare% = MhFalse    ' Can't match if lengths not same
    End If

End Function

Function IsIncludeFile$ (CodeLine$)

    ' This function examines CodeLine$ for either
    ' '$INCLUDE or Rem $Include statements. If it finds
    ' such a line, with a valid file name, then the
    ' function result is the name of the file, else
    ' the function result is null.

    ' It also compares dates and times of files, if you
    ' have checked that option button.

    ' On entry, CodeLine$ must be uppercase

    Dim IsRem As Integer, A As Integer
    If Len(CodeLine$) < 13 Then
       ' Can't be '$INCLUDE:'x' or longer
       IsInclude$ = ""
       Exit Function
    End If
    IsRem = MhFalse
    ' If line begins with apostrophe
    If Asc(CodeLine$) = 39 Then
        IsRem = True
        CodeLine$ = StripWhiteSpace$(Mid$(CodeLine$, 2))
    ElseIf InStr(CodeLine$, Remark1$) = 1 Or InStr(CodeLine$, Remark2$) = 1 Then
        IsRem = True
        CodeLine$ = StripWhiteSpace$(Mid$(CodeLine$, 4))
    End If
    If IsRem Then  ' See if it's $INCLUDE
        If InStr(CodeLine$, Include$) = 1 Then
            ' Isolate file name
            CodeLine$ = StripWhiteSpace$(Mid$(CodeLine$, Len(Include$) + 1))
            If Asc(CodeLine$) = 39 Then '  file name is surrounded by apostrope
                ' Search for second apostrophe
                A = InStr(2, CodeLine$, Apostrophe$)
                If A Then
                    IncludeFileName$ = Mid$(CodeLine$, 2, A - 2)
                    If IncludeExist(IncludeFileName$) Then
                        If MainForm.IncOption(0).Value Then ' Forced update
                           IsIncludeFile$ = IncludeFileName$
                        ElseIf MainForm.IncOption(1).Value Then
                           If MhFileDateCompare%(IncludeFileName$, OldFileName$) = -1 Then
                              IsIncludeFile$ = IncludeFileName$
                           Else
                              SkippedFiles = SkippedFiles + 1
                           End If
                        End If
                    End If
                End If
            End If
        End If
    End If

End Function

Function StripWhiteSpace$ (Temp$)

    ' This function strips leading spaces and tabs
    ' from a string.
    Dim WhiteSpace As Integer
    WhiteSpace = 0
    For J = 1 To Len(Temp$)
        A = Asc(Mid$(Temp$, J, 1))
        Select Case A
            Case 9, 32     ' Tabs & spaces
            WhiteSpace = WhiteSpace + 1
            Case Else
            Exit For     ' Done
        End Select
    Next
    ' Strip leading whitespace
    StripWhiteSpace$ = Mid$(Temp$, WhiteSpace + 1)

End Function

Sub FormatPath (YourForm As Form, Temp$, Divisor)

    ' This procedure formats the path so it fits
    ' into the textbox.
    Do
       A& = GetTextExtent(YourForm.hDC, Temp$, Len(Temp$)) Mod 65536
       If A& <= YourForm.FileOpenCurDir.Width \ Divisor Then
          ' If text will fit into our label, then get out
          Exit Do
       End If
       ' Get rid of everything between 1st/last backslash
       For I = Len(Temp$) To 1 Step -1
           If Asc(Mid$(Temp$, I, 1)) = 92 Then ' found backslash
              J = I
              Exit For
           End If
       Next
       I = InStr(Temp$, "\")
       Temp$ = Left$(Temp$, I) + "..." + Mid$(Temp$, J)
    Loop

    YourForm.FileOpenCurDir.Caption = Temp$
    YourForm.FileOpenCurDir.Refresh

End Sub

Function FileExist% (Temp$)

    ' Determines if a file exists.

    ' Returns True if file exists, else MhFalse
    Dim NextFile As Integer
    NextFile = FreeFile
    On Error GoTo ExistError
    Open Temp$ For Input As #NextFile
    Close #NextFile
    FileExist% = True
    Exit Function

ExistError:
    On Error GoTo 0
    FileExist% = MhFalse
    Resume EE2
EE2:

End Function