home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Programming Tool Box
/
SIMS_2.iso
/
vb_code1
/
fp_demo
/
gifpdemo.bas
< prev
next >
Wrap
BASIC Source File
|
1994-01-18
|
11KB
|
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