Option Explicit ' ' rasx 05/25/1999 '
Public Function CountStr(ByVal Str As String, SubStr As String, _ Optional StartPos = 1) As Long
Dim lngCount
If VBA.VarType(StartPos) <> vbEmpty Then _
If VBA.VarType(StartPos) <> vbInteger Then _
If VBA.VarType(StartPos) <> vbLong Then VBA.Err.Raise 450
Do
lngCount = VBA.InStr(StartPos, Str, SubStr)
StartPos = lngCount + VBA.Len(SubStr)
If lngCount > 0 Then
CountStr = CountStr + 1
Else
Exit Do
End If
Loop
End Function
Public Function GetCharPos(ByVal Str As String, ByVal Chars As String, _ Optional ByVal Iterations = -1) As Long ' 'This function returns the char' position of the first character 'in Chars. If Iterations = 0 then the position of the last occurrence 'of Chars is returned. ' If VBA.VarType(Iterations) <> vbInteger Then If VBA.VarType(Iterations) <> vbLong Then VBA.Err.Raise 450 End If
Dim lngIn As Long
Dim lngOut As Long
Dim lngLoop As Long
lngIn = 1: lngOut = -1
Select Case Iterations
Case -1
Do
lngOut = VBA.InStr(lngIn, Str, Chars)
If lngOut Then
lngIn = lngOut + 1
Else
Exit Do
End If
Loop
Case Else
Do While lngLoop < Iterations
lngOut = VBA.InStr(lngIn, Str, Chars)
If lngOut Then
lngIn = lngOut + 1
Else
Exit Do
End If
lngLoop = lngLoop + 1
Loop
End Select
GetCharPos = lngIn - 1
End Function
Public Function GetDigits(ByVal Str As String, _ Optional ByVal IncludeDecimal = False) As String ' 'This function returns only numeric characters. 'and, optionally, one decimal point. ' Dim lngCount As Long Dim strChar As String Dim strRet As String Dim strCmp As String
If IncludeDecimal Then
strCmp = "1234567890."
Else
strCmp = "1234567890"
End If
For lngCount = 1 To Len(Str)
strChar = Mid$(Str, lngCount, 1)
If InStr(strCmp, strChar) > 0 Then
strRet = strRet & strChar
End If
Next
GetDigits = strRet
End Function
Public Function GetSubStr(ByVal Str As String, _ Optional ByVal StartCol = 0, _ Optional ByVal EndCol = 0, _ Optional ByVal StartChar = Empty, _ Optional ByVal EndChar = Empty) As String 'For all cases, this function returns what is between 'the characters and/or columns searched. This design 'assumes the leftmost column is column 1 so that 'character position equals column position.
Dim lngLength As Long
On Error GoTo GetSubStr_Err
'Check Optional input.
If VBA.VarType(StartCol) <> vbInteger Then
If VBA.VarType(StartCol) <> vbLong Then VBA.Err.Raise 450
End If
If VBA.VarType(EndCol) <> vbInteger Then
If VBA.VarType(EndCol) <> vbLong Then VBA.Err.Raise 450
End If
If VBA.VarType(StartChar) <> vbString Then
If VBA.VarType(StartChar) <> vbEmpty Then VBA.Err.Raise 450
End If
If VBA.VarType(EndChar) <> vbString Then
If VBA.VarType(EndChar) <> vbEmpty Then VBA.Err.Raise 450
End If
If StartChar = EndChar And VBA.Len(StartChar) And VBA.Len(EndChar) Then
VBA.MsgBox "Error: This function cannot handle strings" _
& " with separators.", _
vbCritical + vbOKOnly, "GetSubStr Error"
GoTo GetSubStr_Exit
End If
If VBA.Len(StartChar) > 1 Or VBA.Len(EndChar) > 1 Then
VBA.MsgBox "Error: This function cannot searches with strings" _
& " of length greater than one.", _
vbCritical + vbOKOnly, "GetSubStr Error"
GoTo GetSubStr_Exit
End If
'Searched on single characters only.
If VBA.Len(StartChar) And VBA.Len(EndChar) Then
lngLength = VBA.InStr(1, Str, EndChar) _
- VBA.InStr(1, Str, StartChar)
GetSubStr = VBA.Mid$(Str, VBA.InStr(1, Str, StartChar) + 1, lngLength - 1)
'Searched on column numbers only.
ElseIf StartCol >= 1 And EndCol >= 1 Then
lngLength = EndCol - StartCol
GetSubStr = VBA.Mid$(Str, StartCol, lngLength)
'Searched on known starting column and known end character.
ElseIf StartCol >= 1 And VBA.Len(EndChar) Then
lngLength = VBA.InStr(1, Str, EndChar) - StartCol
GetSubStr = VBA.Mid$(Str, StartCol, lngLength)
'Searched on known starting character and known end column.
ElseIf VBA.Len(StartChar) And EndCol >= 1 Then
lngLength = EndCol - VBA.InStr(1, Str, StartChar)
GetSubStr = VBA.Mid$(Str, VBA.InStr(1, Str, StartChar) + 1, lngLength - 1)
End If
GetSubStr_Exit: Exit Function
GetSubStr_Err: Select Case VBA.Err Case Else VBA.MsgBox VBA.Err.Description, vbCritical + vbOKOnly, "GetSubStr Error" Resume GetSubStr_Exit
End Select
End Function
Public Function InsNewLines(ByVal InpString As String, _ ByVal LineLen As Long) As String
Dim lngPosCrLfIn As Long
Dim lngPosCrLfOut As Long
Dim lngPosSpc As Long
Dim strSpc As String
Dim strIn As String
Dim strOut As String
strSpc = VBA.Space$(1)
strIn = InpString
Do
lngPosCrLfIn = GetCharPos(strIn, vbCrLf, 1)
lngPosSpc = GetCharPos(strIn, strSpc, 1)
If lngPosCrLfIn <= LineLen And lngPosCrLfIn > 0 _
And (VBA.Len(strOut) - lngPosCrLfIn) + lngPosCrLfOut < LineLen Then
'Substring contains a linebreak and carriage return
'and its length is smaller than LineLen.
strOut = strOut & VBA.Mid$(strIn, 1, lngPosCrLfIn + 1)
strIn = VBA.Mid$(strIn, lngPosCrLfIn + 2)
ElseIf lngPosSpc > 0 Then
'Split strIn at the last position of the space character.
strOut = strOut & VBA.Mid$(strIn, 1, lngPosSpc - 1)
strIn = VBA.Mid$(strIn, lngPosSpc + 1)
'Store last position of carriage return and line feed in strOut.
lngPosCrLfOut = GetCharPos(strOut, vbCrLf)
If VBA.Len(strOut) - lngPosCrLfOut >= LineLen Then
'Break line.
strOut = strOut & vbCrLf
Else
'Don't break line.
strOut = strOut & strSpc
End If
ElseIf lngPosSpc = 0 Then
'In prose this must be the end of the string.
strOut = strOut & strIn
strIn = Empty
End If
Loop Until strIn = Empty
InsNewLines = strOut
End Function
Public Function PathExists(ByVal PathName As String, _ Optional ByVal PathAttr = vbNormal) As Boolean
On Error Resume Next
If VBA.VarType(PathAttr) <> vbInteger Then _
If VBA.VarType(PathAttr) <> vbLong Then VBA.Err.Raise 450
PathExists = Not (VBA.Dir(PathName, PathAttr) = Empty)
End Function
Public Function ReplaceChars(ByVal Str As String, ByVal OldChars As String, _ Optional ByVal NewChars = Empty, Optional Iterations = -1, _ Optional StartPos = 1, Optional ByVal UpCase = False) As String ' 'This function was conceived in the old days 'before the VBA.Replace() method. ' Dim lngCounter As Long, lngLoop As Long Dim lngNewPos As Long
If VBA.VarType(NewChars) <> vbEmpty Then _
If VBA.VarType(NewChars) <> vbString Then VBA.Err.Raise 450
If VBA.VarType(Iterations) <> vbEmpty Then _
If VBA.VarType(Iterations) <> vbInteger Then _
If VBA.VarType(Iterations) <> vbLong Then VBA.Err.Raise 450
If VBA.VarType(StartPos) <> vbEmpty Then _
If VBA.VarType(StartPos) <> vbInteger Then _
If VBA.VarType(StartPos) <> vbLong Then VBA.Err.Raise 450
If VBA.VarType(UpCase) <> vbEmpty Then _
If VBA.VarType(UpCase) <> vbBoolean Then VBA.Err.Raise 450
If Iterations = -1 Then
'Count how many times OldChars appears.
Iterations = CountStr(Str, OldChars)
End If
ReplaceChars = Str
If NewChars <> Empty Then
lngLoop = VBA.InStr(StartPos, Str, OldChars, vbBinaryCompare)
For lngCounter = 1 To Iterations
Str = Mid$(Str, StartPos, lngLoop - 1) & NewChars & VBA.Mid$(Str, lngLoop + VBA.Len(OldChars))
ReplaceChars = Str
lngNewPos = lngLoop + VBA.Len(NewChars)
lngLoop = VBA.InStr(lngNewPos, Str, OldChars, vbBinaryCompare)
Next
Else
If UpCase Then
lngLoop = VBA.InStr(StartPos, Str, OldChars, vbBinaryCompare)
For lngCounter = 1 To Iterations
Str = VBA.Mid$(Str, 1, lngLoop - 1) & VBA.UCase$(OldChars) _
& VBA.Mid$(Str, lngLoop + VBA.Len(OldChars))
ReplaceChars = Str
lngNewPos = lngLoop + VBA.Len(NewChars)
lngLoop = VBA.InStr(lngNewPos, Str, OldChars, vbBinaryCompare)
Next
Else
lngLoop = VBA.InStr(1, Str, OldChars)
For lngCounter = 1 To Iterations
Str = VBA.Mid$(Str, 1, lngLoop - 1) & VBA.Mid$(Str, lngLoop + VBA.Len(OldChars))
ReplaceChars = Str
lngNewPos = lngLoop + VBA.Len(NewChars)
lngLoop = VBA.InStr(lngNewPos, Str, OldChars, vbBinaryCompare)
Next
End If
End If
End Function
Public Function SearchLine(ByVal Str As String, _ ByVal SearchStr As String) As String
'This function returns the line containing SearchStr
'where "line" implies Str contains several vbCrLf char's.
Dim lngLen As Long
Dim lngStart As Long
Dim lngEnd As Long
lngLen = VBA.Len(Str)
If VBA.InStr(1, Str, SearchStr) = 0 Then Exit Function
lngStart = 1
lngEnd = VBA.InStr(lngStart, Str, vbCrLf)
Do
SearchLine = GetSubStr(Str, lngStart, lngEnd)
If VBA.InStr(1, SearchLine, SearchStr) Then Exit Do
lngStart = lngEnd + 2 'Recall that vbCrLf is two char's!
lngEnd = VBA.InStr(lngStart, Str, vbCrLf)
Loop
End Function
Public Function TitleCase(ByVal Str As String) As String
Dim lngLoop As Long
Dim strMid As String
'Handle the remaining characters.
For lngLoop = 1 To VBA.Len(Str)
strMid = VBA.Mid$(Str, lngLoop, 2)
If strMid = " """ Or strMid = " '" Then
'Respond to leading quotes.
strMid = VBA.Mid$(Str, lngLoop, 3)
VBA.Mid(Str, lngLoop, 3) = VBA.UCase(strMid)
ElseIf strMid Like " ?" Then
VBA.Mid(Str, lngLoop, 2) = VBA.UCase(strMid)
End If
Next lngLoop
'Handle simple grammar rules.
'Articles:
Str = ReplaceChars(Str, " The ", " the ")
Str = ReplaceChars(Str, " A ", " a ")
'Common Prepositions:
Str = ReplaceChars(Str, " Against ", " against ")
Str = ReplaceChars(Str, " Along ", " along ")
Str = ReplaceChars(Str, " At ", " at ")
Str = ReplaceChars(Str, " Between ", " between ")
Str = ReplaceChars(Str, " By ", " by ")
Str = ReplaceChars(Str, " Down ", " down ")
Str = ReplaceChars(Str, " For ", " for ")
Str = ReplaceChars(Str, " In ", " in ")
Str = ReplaceChars(Str, " Of ", " of ")
Str = ReplaceChars(Str, " On ", " on ")
Str = ReplaceChars(Str, " Over ", " over ")
Str = ReplaceChars(Str, " To ", " to ")
Str = ReplaceChars(Str, " Up ", " up ")
Str = ReplaceChars(Str, " With ", " with ")
'Handle the first character.
strMid = VBA.Mid$(Str, 1, 1)
VBA.Mid(Str, 1, 1) = VBA.UCase(strMid)
TitleCase = Str
End Function