Programmer 7500/MAX_PROGRAMMERS.iso/VISUAL_B/CODIGO_1/FP_DEMO/GIFPDEMO.BAS

BASIC Source File | 1994-01-18 | 10.8 KB | 313 lines

Option Explicit
DefInt A-Z

Global Const MODELESS = 0
Global Const MODAL = 1

Global Const FPERR_NULL_STRING = -1
Global Const FPERR_NULL_DELIMITER = -2

Global Const FP_DELIM_FIRST = 0
Global Const FP_DELIM_LAST = -1

Function DlmStrNumFields% (StringIn$, Delimiter$)

    DlmStrNumFields% = DS_CountDlms(StringIn$, Delimiter$) + 1

End Function

Function FileOpenDialog$ ()
'------------------------------------------------
'-- Display the common dialog strictly for the
'   purpose of getting a File Spec.
'------------------------------------------------

    frmMain!cmdlgMain.Filter = "All Files (*.*)|*.*"
    frmMain!cmdlgMain.Action = 1
    FileOpenDialog$ = frmMain!cmdlgMain.Filename


End Function

Function fpCollapsePath$ (PathSpec$, MaxChars%)
'---------------------------------------------------
'-- Takes a PathSpec such as "C:\VB\SAMPLES\VBCOMM"
'   and removes intermediate directory names until
'   the path spec is <= MaxChars%. If any directory
'   names are removed and ellipsis(...) will be
'   inserted to denote that fact.
'---------------------------------------------------
    Dim WorkingPath$
    Dim Delim$
    Dim NumDelims%
    Dim MaxDirLen%
    Dim DirToTrim$
    Dim TrimmedDir$
    Dim DelimPos%
    Dim LeftSide$
    Dim RightSide$

    '-- First we'll check to see if we even need
    '   to bother doing anything.
    If Len(PathSpec$) > MaxChars% Then
        WorkingPath$ = PathSpec$
        Delim$ = "\"

        '-- Replace the first directory with an
        '   ellipsis. If the path contains only
        '   one directory then we need to trim
        '   it and prepend the ellipsis to it.
        NumDelims% = DS_CountDlms(WorkingPath$, Delim$)
        If NumDelims% > 1 Then
            '-- Replace the first directory
            '   with an ellipsis.
            WorkingPath$ = DS_PutField(WorkingPath$, Delim$, 2, "...")
        Else
            '-- There's only 1 directory, and it's
            '   too long so we have to trim it.
            DirToTrim$ = DS_GetField(WorkingPath$, Delim$, 2)
            '-- The max length of the directory
            '   name has to allow for "C:\..."
            MaxDirLen% = MaxChars% - (Len("C:\..."))
            TrimmedDir$ = "..." & Right(DirToTrim$, MaxDirLen%)
            WorkingPath$ = DS_PutField(WorkingPath$, Delim$, 2, TrimmedDir$)
        End If

        '-- Now we have to do it all again, but this time
        '   we leave the first directory (now an ellipsis)
        '   and handle the rest.
        While Len(WorkingPath$) > MaxChars%
            NumDelims% = DS_CountDlms(WorkingPath$, Delim$)
            If NumDelims% > 2 Then
                '-- If there's more than 1 directory
                '   then just remove the directory.
                WorkingPath$ = DS_RemoveField(WorkingPath$, Delim$, 3)
            Else
                '-- We're down to 1 directory again so
                '   remove the first ellipsis and trim
                '   the current directory, prepending
                '   an ellipsis to it.
                WorkingPath$ = DS_RemoveField(WorkingPath$, Delim$, 2)
                DirToTrim$ = DS_GetField(WorkingPath$, Delim$, 2)
                '-- The max length of the directory
                '   name has to allow for "C:\..."
                MaxDirLen% = MaxChars% - (Len("C:\..."))
                TrimmedDir$ = "..." & Right(DirToTrim$, MaxDirLen%)
                WorkingPath$ = DS_PutField(WorkingPath$, Delim$, 2, TrimmedDir$)
            End If

            If Len(WorkingPath$) = MaxChars% + 1 Then
                '-- This is an exception case just to conform
                '   to the "Windows" guidelines of how the
                '   truncation should be done. It just removes
                '   the second delimiter.
                DelimPos% = fpSplitString(WorkingPath$, Delim$, 2, LeftSide$, RightSide$)
                WorkingPath$ = LeftSide$ & RightSide$
            End If

        Wend

    End If

    fpCollapsePath$ = WorkingPath$

End Function

Function fpFileFromFileSpec$ (FileSpec$)
    Dim Delim$
    Dim NumDelims%

    If Len(FileSpec$) Then
        Delim$ = "\"
        NumDelims% = DS_CountDlms(FileSpec$, Delim$)
        fpFileFromFileSpec$ = DS_GetField(FileSpec$, Delim$, NumDelims% + 1)
    Else
        '-- We're here because the String passed
        '   was a null string.
        fpFileFromFileSpec$ = ""
    End If

End Function

Sub fpLoadListFromDlmStr (theList As Control, DlmStr$, Delim$)
    Dim NumItems%
    Dim i%
    Dim Item$

    NumItems% = DlmStrNumFields(DlmStr$, Delim$)
    For i% = 1 To NumItems%
        Item$ = US_Trim(DS_GetField(DlmStr$, Delim$, i%))
        If Len(Item$) Then
            theList.AddItem Item$
        End If
    Next i%

End Sub

Function fpParsePathAndFilename% (FileSpec$, outPath$, outFilename$)
    Dim Delim$

    Delim$ = "\"
    fpParsePathAndFilename% = fpSplitString(FileSpec$, Delim$, FP_DELIM_LAST, outPath$, outFilename$)

End Function

Function fpParseString% (StringToParse$, Delimiter$, arrParsedItems$())
'----------------------------------------------------------------------
'-- Returns: Number of items parsed if successful
'            FPERR_NULL_STRING if StringToParse was a null string ("")
'            FPERR_NULL_DELIMITER if Delimiter was a null string ("")
'----------------------------------------------------------------------
    Dim NumItems%
    Dim FieldNum%
    Dim i%

    If Len(StringToParse$) Then
        If Len(Delimiter$) Then
            NumItems% = DS_CountDlms(StringToParse$, Delimiter$) + 1
            If NumItems% > 0 Then
                '-- We use NumItems% - 1 here because
                '   our array is 0 based
                ReDim arrParsedItems$(NumItems% - 1)
                For i% = 0 To NumItems% - 1
                    '-- We use i% + 1 to get the field number because
                    '   DS_GetField is 1 based rather than 0 based
                    FieldNum% = i% + 1
                    arrParsedItems$(i%) = US_Trim(DS_GetField(StringToParse$, Delimiter$, FieldNum%))
                Next i%
            End If

            fpParseString% = NumItems%

        Else
            '-- We're here because the Delimiter passed
            '   was a null string.
            fpParseString% = FPERR_NULL_DELIMITER
        End If
    Else
        '-- We're here because the String passed
        '   was a null string.
        fpParseString% = FPERR_NULL_STRING
    End If

End Function

Function fpPathFromFileSpec$ (FileSpec$)
'-------------------------------------------------
'-- NOTE: You could easily use fpSplitString to
'         accomplish this task but this shows you
'         a simple way if you don't want all the
'         extra overhead.
'-------------------------------------------------
    Dim Delim$
    Dim NumDelims%
    Dim LastDelimPos&

    If Len(FileSpec$) Then
        Delim$ = "\"
        NumDelims% = DS_CountDlms(FileSpec$, Delim$)
        LastDelimPos& = DS_FindDlm(FileSpec$, Delim$, NumDelims%)
        fpPathFromFileSpec$ = Left$(FileSpec$, LastDelimPos& - 1)
    Else
        '-- We're here because the String passed
        '   was a null string.
        fpPathFromFileSpec$ = ""
    End If

End Function

Function fpSplitString% (StringToSplit$, Delimiter$, OccurrenceNumber%, outLeftHalf$, outRightHalf$)
'----------------------------------------------------
'-- Splits a string into two parts. The split occurs
'   at the specified occurrence of the specified
'   delimiter. outLeftHalf and outRightHalf will hold
'   the two parts of the string upon return.
'
'-- You can specify an occurrence number for the
'   delimiter if you know that you want to split
'   the string at a specific occurrence or you can
'   use FP_DELIM_FIRST or FP_DELIM_LAST to split
'   the string at the first or last delimiter.
'
'-- Returns: Byte position where split occurred if
'            successful. 0 inidicates no delimiter
'            was found in which case outLeftHalf is
'            filled with the original string and
'            outRightHalf is a null string.
'
'            FPERR_NULL_STRING if StringToParse was a
'            null string ("")
'
'            FPERR_NULL_DELIMITER if Delimiter was a
'            null string ("")
'----------------------------------------------------
    Dim DelimOccurrence%
    Dim SplitPos&

    If Len(StringToSplit$) Then
        If Len(Delimiter$) Then
            Select Case OccurrenceNumber%
                Case FP_DELIM_FIRST
                    DelimOccurrence% = 1
                Case FP_DELIM_LAST
                    DelimOccurrence% = DS_CountDlms(StringToSplit$, Delimiter$)
                Case Else
                    DelimOccurrence% = OccurrenceNumber%
            End Select

            SplitPos& = DS_FindDlm(StringToSplit$, Delimiter$, DelimOccurrence%)

            If SplitPos& <> 0 Then
                outLeftHalf$ = Left$(StringToSplit$, SplitPos& - 1)
                outRightHalf$ = Right$(StringToSplit$, Len(StringToSplit$) - SplitPos&)
            Else
                '-- If no delimiters were found then the
                '   left half gets the whole shebang and
                '   the right half gets nothing.
                outLeftHalf$ = StringToSplit$
                outRightHalf$ = ""
            End If

            fpSplitString% = CInt(SplitPos&)

        Else
            '-- We're here because the Delimiter passed
            '   was a null string.
            fpSplitString% = FPERR_NULL_DELIMITER
        End If
    Else
        '-- We're here because the String passed
        '   was a null string.
        fpSplitString% = FPERR_NULL_STRING
    End If

End Function

Function fpWordCount& (StringToCount$)
'--------------------------------------------------
'-- Returns: Number of words if successful.
'            FPERR_NULL_STRING if a null string
'             was passed in as a parameter.
'
'-- NOTE! This is not a "real" word count function
'         in that it only counts the number of
'         spaces which separate words. There are
'         certainly more accurate, less literal
'         algorithms available but if you need a
'         rough estimate then it doesn't get much
'         simpler than this.
'--------------------------------------------------
    Dim Delim$

    If Len(StringToCount$) Then
        Delim$ = " "
        fpWordCount& = DS_CountDlms(StringToCount$, Delim$) + 1
    Else
        '-- We're here because the String passed
        '   was a null string.
        fpWordCount& = FPERR_NULL_STRING
    End If

End Function