Next: webrti.bas
Up: Code Listing
Previous: unlock.mak
'
' Author: Terence Kelly
' Date: 8 September 1995
'
' This module, currently named "UTILITY.BAS", will contain utility
' functions which should be useful in a wide variety of general
' applications. Many of these functions will perform mundane string
' manipulations. I'm accustomed to powerful string manipulation
' languages like AWK and PERL, and the functions here should provide
' some of the abilities we take for granted in those languages.
'
' Error handling is an issue which, as of 7/27/95, I have not
' considered in great detail. I'll probably avoid the issue for
' as long as possible. Error handling really should be added to
' all of these functions to make them bulletproof.
'
Sub AppendToFIle (ByVal Filename$, ByVal Message$)
'
' Append given message string to given file without modification.
' This function should trap errors because it is possible for a
' file to be "locked" in DOS's brain-damaged way (if a file is
' "open", it cannot be deleted or written or even *read*!), in
' which case this would fail.
'
AppendToFile_Filenumber% = FreeFile
Open Filename$ For Append As #AppendToFile_Filenumber%
Print #AppendToFile_Filenumber%, Message$;
Close #AppendToFile_Filenumber%
End Sub
Sub ClobberFile (ByVal Filename$, ByVal Message$)
'
' Write given contents to specified file, overwriting whatever
' is there. There should be an error handler here.
'
If InStr(Filename$, "*") Or InStr(Filename$, "?") Then
Exit Sub ' no wildcards allowed
End If
Filenumber% = FreeFile
Open Filename$ For Output As #Filenumber%
Print #Filenumber%, Message$;
Close #Filenumber%
End Sub
Function CondenseWhitespace (ByVal S$) As String
'
' Given a string, convert all consecutive sequences of spaces,
' tabs and newlines into a single space. Does NOT strip leading
' & trailing whitespace.
'
LastWasSpace% = False
For I& = 1 To Len(S$)
C% = Asc(Mid$(S$, I&, 1))
Select Case C%
Case 8, 9, 10, 13, 32 ' backspace, tab, LF, CR, space
If LastWasSpace% = False Then
R$ = R$ & " "
End If
LastWasSpace% = True
Case Else
R$ = R$ & Chr$(C%)
LastWasSpace% = False
End Select
Next
CondenseWhitespace = R$
End Function
Function CRLF () As String
'
' Return string consisting of carriage return plus linefeed.
' It is probably inefficient to use this function in most
' cases. Better to use a global constant.
'
CRLF = Chr$(13) & Chr$(10)
End Function
Sub Delay (ByVal N%)
'
' Wait a specified number of seconds (up to an artificial limit).
'
' This is a crude way to wait an interval. A more sophisticated
' method would be to use a VB timer control.
'
If N% > 120 Then
Delay_interval% = 120
Else
Delay_interval% = N%
End If
BeginTime = Now
Do While DateDiff("s", BeginTime, Now) < Delay_interval%
Loop
End Sub
Function Filecontents (ByVal Filename$) As String
'
' Given a filename, returns a string containing the entire
' contents of the given file. Return empty string if file
' doesn't exist.
'
' WARNING: error checking here is minimal or nonexistent.
' This function is intended for use with text files only;
' I don't know what would happen if it were fed a binary file.
' Also, there is a limit on the length of a Visual Basic string.
' If this function is fed a file longer than that limit, results
' are undefined.
'
Dim Filenumber As Integer
Dim strReturnValue As String
On Error GoTo FileContents_Error
Filecontents = "" ' return empty string if file doesn't exist
If Dir$(Filename$) = "" Then Exit Function
strReturnValue = ""
Filenumber = FreeFile
Open Filename For Input As #Filenumber
Do While Not EOF(Filenumber)
strReturnValue = strReturnValue & Input$(1, #Filenumber)
Loop
Close Filenumber
Filecontents = strReturnValue
Exit Function
FileContents_Error:
R$ = "Error number " & Err & " (VB) in function "
Filecontents = R$ & "FileContents: " & Error$
Exit Function
End Function
Function HexExtract (ByVal H$, ByVal pos%, ByVal length%) As Long
'
' Given a Hex string, a bit position, and a length, return the
' long value of the binary number of given length beginning at
' given bit position within given hex string. For instance,
' given hex string "9C", position 3, length 3, return 7:
' 9CH = 10011100 binary, bit string of length 3 beginning at
' position 3 is 111 = 7. First bit position is zero, at the
' LEFT of the string.
'
' This function is mostly useful for decoding the stuff returned
' by the Tektronix scope FP? command.
'
If length% <= 0 Or pos% < 0 Or HexToDecimal(H$) <= 0 Then
HexExtract = 0
Exit Function
End If
firstchar% = (pos% \ 4) + 1
lastchar% = ((pos% + length% - 1) \ 4) + 1
T1& = HexToDecimal(Mid$(H$, firstchar%, lastchar% - firstchar% + 1))
power% = 3 - ((pos% + length% - 1) Mod 4)
T2& = Int(T1& \ (2 ^ power%))
HexExtract = T2& Mod (2 ^ length%)
End Function
Function HexToDecimal (ByVal S$) As Long
'
' This is really rather silly, since the Val function recognizes
' and convert hex numbers. I wrote this before learning about
' this aspect of Val. This function has somewhat more range than
' Val, however: according to the manual Val converts "&HFFFF" to
' -1, whereas my function shouldn't choke on it so quickly.
'
' Use this only for long hex numbers; use Val for short ones.
'
' Given a string containing a hexidecimal number, return the
' number as a decimal integer. If number is invalid, return -1.
'
' Exhaustively tested on numbers 0 thru 255 (decimal) on
' 9 August 1995
'
R& = 0
PlaceValue& = 1
For I& = Len(S) To 1 Step -1
Select Case Mid(S$, I&, 1)
Case "0"
R& = R& + PlaceValue& * 0
Case "1"
R& = R& + PlaceValue& * 1
Case "2"
R& = R& + PlaceValue& * 2
Case "3"
R& = R& + PlaceValue& * 3
Case "4"
R& = R& + PlaceValue& * 4
Case "5"
R& = R& + PlaceValue& * 5
Case "6"
R& = R& + PlaceValue& * 6
Case "7"
R& = R& + PlaceValue& * 7
Case "8"
R& = R& + PlaceValue& * 8
Case "9"
R& = R& + PlaceValue& * 9
Case "A", "a"
R& = R& + PlaceValue& * 10
Case "B", "b"
R& = R& + PlaceValue& * 11
Case "C", "c"
R& = R& + PlaceValue& * 12
Case "D", "d"
R& = R& + PlaceValue& * 13
Case "E", "e"
R& = R& + PlaceValue& * 14
Case "F", "f"
R& = R& + PlaceValue& * 15
Case Else
GoTo HexToDecimal_Error
End Select
PlaceValue& = PlaceValue& * 16
Next
HexToDecimal = R&
Exit Function
HexToDecimal_Error:
HexToDecimal = -1
Exit Function
End Function
Sub HexToDecimal_Test ()
'
' Rename this "Main" to test Hex conversion function easily.
'
For I% = 1 To 255
testv$ = Hex$(I%)
rv& = HexToDecimal(testv$)
msg$ = "I = " & I% & ": " & testv$ & " -> " & rv& & " -> "
msg$ = msg$ & Hex$(rv&)
MsgBox msg$
Next
End Sub
Function NumFiles (ByVal pat$) As Long
'
' Given a pathname (wildcard characters allowed) return the
' total number files with the given extension in the given
' directory.
'
count& = 0
file$ = Dir$(pat$)
While file$ <> ""
count& = count& + 1
file$ = Dir$
Wend
NumFiles = count&
End Function
Function NumOccur (ByVal S$, ByVal C$) As Long
'
' Given a string S, return the number of C characters within it.
'
N& = 0
For I& = 1 To Len(S$)
If Mid$(S$, I&, 1) = C$ Then N& = N& + 1
Next
NumOccur = N&
End Function
Function Split (ByVal S$, ByVal N%, ByVal Delim$) As String
'
' Given a string S, return the Nth field where fields are
' delimited by one or more Delim characters. Return empty string
' if N = 0 or number of fields is less than N. Inspired by the
' (far superior!) awk and perl "split" functions. Delim must be
' a single character. Passed many tests 7/27/95. Updated
' without testing 8/8/95 to replace "As" in declaration with
' type-definition suffixes. This shouldn't cause problems.
'
' This should really be re-written to count fields the way
' awk does, at least in the case of non-whitespace delimiters.
'
Dim I As Integer
Dim B As Integer ' Beginning of argument to return
Dim E As Integer ' End of argument to return
Const CASE_SENSITIVE = 0 ' Page 285 of _Language_Reference_
Split = "" ' Return zero-length string by default
If Len(Delim) <> 1 Or N < 1 Or Len(S) < 1 Then Exit Function
B = 0
E = 0
' Set B to beginning of Nth field
For I = 1 To N
B = B + 1
While Mid$(S, B, 1) = Delim And B <= Len(S)
B = B + 1
Wend
If I < N Then
While Mid$(S, B, 1) <> Delim And B <= Len(S)
B = B + 1
Wend
End If
If B > Len(S) Then Exit Function
Next I
' Set E to end of Nth field
E = B
While Mid$(S, E, 1) <> Delim And E <= Len(S)
E = E + 1
Wend
Split = Mid$(S, B, E - B)
End Function
Function StrSub (ByVal in$, ByVal old$, ByVal nu$) As String
'
' Given a string, convert every instance of old to nu.
'
R$ = ""
Temp$ = in$
I% = 0
Do While InStr(Temp$, old$)
I% = InStr(Temp$, old$)
R$ = R$ & Left$(Temp$, I% - 1) & nu$
Temp$ = Mid$(Temp$, I% + Len(old$))
Loop
StrSub = R$ & Temp$
End Function