SonghaySystem(::)

The Funky Knowledgebase:
Visual Basic for Applications

Code: String Handling Functions from 1999; StringServices.bas

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

This document was last reviewed on Thursday, January 20, 2005 at 12:44 PM PST.

Copyright© 2010 by Bryan D. Wilhite All rights reserved. No part of this material may be used or reproduced in any form or by any means, or stored in a database or retrieval system, without prior written permission of the publisher except in the case of brief quotations embodied in critical articles and reviews. Making copies of any part of this material for any purpose other than your own personal use is a violation of United States copyright laws.

The information provided by Bryan D. Wilhite at kintespace.com is provided “as is” without warranty of any kind. In no event shall Bryan D. Wilhite or any of his affiliates be liable for any damages whatsoever including, but not limited to, direct, indirect, incidental, consequential, loss of business profits or special damages due to material published by Bryan D. Wilhite or any of his affiliates.

SonghaySystem(::)

The Funky Knowledgebase:Visual Basic for Applications

Code: String Handling Functions from 1999; StringServices.bas

The Funky Knowledgebase:
Visual Basic for Applications