Solved

A cheap 3d party string matching functionality

Posted on 1998-09-04
5
279 Views
Last Modified: 2008-03-06
Does anyone know where I can find a good set of VB friendly string matching functions like in awk/Perl. It can be freeware/shareware or 3d party product with a full implementation of regular expressions. I'm looking for is a set of function for string pattern matching like gsub(regexp, repl, string), match(string, regexp), split(string, array, regexp)
and so on. I'm interested only in the products with the price tag < $40
0
Comment
Question by:borisl
  • 2
  • 2
5 Comments
 
LVL 1

Expert Comment

by:mithomas
ID: 1433068
Since no one has answered your question in a while, maybe you'll be a little more flexible on price :-).
VideoSoft has an AWK control that is packaged in with their VSx products.  Check out VideoSoft® VS-OCX® 6.0 at http://www.videosoft.com.  Unfortunately, they don't have price info there (that I could find).
Good luck...
0
 

Author Comment

by:borisl
ID: 1433069
Mithomas, thanks for your help. I have Videosoft Awk but it doesn't have regular expression functionality (in fact they stated in the help file that that was their conscious design decision and the main difference with the "real" Awk). I'm flexible on price - if Regular expressions are just thrown in together with some other useful stuff I'll buy them, but it seems too much to pay $119 for regular expressions alone (Written in VB and therefore slow).
0
 
LVL 1

Expert Comment

by:mithomas
ID: 1433070
Sorry about that.  Clearly I have not used their offering, and am now wondering about the usefulness of their product.  Good luck (again)...
0
 
LVL 14

Accepted Solution

by:
waty earned 100 total points
ID: 1433071
Here are my usefule string routine for .... 0$

Option Explicit

Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long
Private Declare Function IsCharAlphaNumeric Lib "user32" Alias "IsCharAlphaNumericA" (ByVal cChar As Byte) As Long

Public Function GetToken(s As String, token As String, ByVal Nth As Integer) As String
   ' *** This function returns the Nth token in a string
   ' ***   Ex.  GetToken("This is a test.", " ", 2) = "is"
   
   Dim i As Integer
   Dim p As Integer
   Dim r As Integer

   If Nth < 1 Then
      GetToken = ""
      Exit Function
   End If

   r = 0

   For i = 1 To Nth
      p = r
      r = InStr(p + 1, s, token)
      If r = 0 Then
         If i = Nth Then
            GetToken = Mid$(s, p + 1, Len(s) - p)
         Else
            GetToken = ""
         End If
         Exit Function
      End If
   Next i

   GetToken = Mid$(s, p + 1, r - p - 1)

End Function

Public Function GetTokens(sToParse As String, sToken As String) As Variant
   ' *** Returns an array to tokenized values
   ' ***  Ex:  GetTokens("This is a test.", " ") = ({ "This", "is", "a", "test." })

   Dim nTokenLen       As Integer
   Dim nTokenCnt       As Integer
   Dim nOffset         As Long
   Dim nPrevOffset     As Long
   Dim aTokens()       As String

   nTokenLen = Len(sToken)
   nOffset = InStr(sToParse, sToken)

   Do While nOffset > 0
      ReDim Preserve aTokens(nTokenCnt)
      If nOffset - nPrevOffset > 1 Then
         aTokens(nTokenCnt) = Mid$(sToParse, nPrevOffset + 1, nOffset - 1 - nPrevOffset)
      Else
         aTokens(nTokenCnt) = ""
      End If

      nPrevOffset = nOffset
      nOffset = InStr(nOffset + nTokenLen, sToParse, sToken)
      nTokenCnt = nTokenCnt + 1
   Loop

   ReDim Preserve aTokens(nTokenCnt)
   aTokens(nTokenCnt) = Mid$(sToParse, nPrevOffset + 1)
   GetTokens = CVar(aTokens)

End Function

' String functions.
' Converts a double to a string
' Note:  numbers after the decimal place
'        are ignored.
Function Int2String(ByVal l As Double) As String
   Dim tmp As String
   Dim str As String
   Dim i As Integer
   Dim J As Integer

   tmp = Format(l, "000000000000")
   str = ""

   ' Opps... it's more than 999 trillion
   ' One could easily add bigger number
   ' support.
   If Len(tmp) > 12 Then
      Int2String = ""
      Exit Function
   End If


   ' zero is a special case.
   ' you may want to change this to "no"
   ' as in "no dollars and 12/100" for writing
   ' checks.

   If Val(tmp) = 0 Then
      Int2String = "zero"
      Exit Function
   End If


   i = Val(Left$(tmp, 3))
   If i <> 0 Then
      GoSub do_hundreds
      str = str + " trillion"
   End If

   i = Val(Mid$(tmp, 4, 3))
   If i <> 0 Then
      GoSub do_hundreds
      str = str + " million"
   End If

   i = Val(Mid$(tmp, 7, 3))
   If i <> 0 Then
      GoSub do_hundreds
      str = str + " thousand"
   End If


   i = Val(Right$(tmp, 3))
   If i <> 0 Then
      GoSub do_hundreds
   End If

   Int2String = str
   Exit Function



do_hundreds:
   If i > 99 Then
      J = i
      i = i \ 100
      GoSub do_ones
      str = str + " hundred"
      i = J Mod 100
   End If

   If i <> 0 Then
      GoSub do_tens
   End If
   Return

do_tens:
   Select Case i Mod 100
      Case 90 To 99:
         str = str + " ninety"
         GoSub do_ones
      Case 80 To 89:
         str = str + " eighty"
         GoSub do_ones
      Case 70 To 79:
         str = str + " seventy"
         GoSub do_ones
      Case 60 To 69:
         str = str + " sixty"
         GoSub do_ones
      Case 50 To 59:
         str = str + " fifty"
         GoSub do_ones
      Case 40 To 49:
         str = str + " fourty"
         GoSub do_ones
      Case 30 To 39:
         str = str + " thirty"
         GoSub do_ones
      Case 20 To 29:
         str = str + " twenty"
         GoSub do_ones

      Case 19: str = str + " nineteen"
      Case 18: str = str + " eighteen"
      Case 17: str = str + " seventeen"
      Case 16: str = str + " sixteen"
      Case 15: str = str + " fifteen"
      Case 14: str = str + " fourteen"
      Case 13: str = str + " thirteen"
      Case 12: str = str + " twelve"
      Case 11: str = str + " eleven"
      Case 10: str = str + " ten"

      Case Else
         GoSub do_ones
   End Select
   Return


do_ones:
   If i < 10 Or i Mod 10 = 0 Then
      str = str + " "
   Else
      str = str + "-"
   End If

   Select Case i Mod 10
      Case 9: str = str + "nine"
      Case 8: str = str + "eight"
      Case 7: str = str + "seven"
      Case 6: str = str + "six"
      Case 5: str = str + "five"
      Case 4: str = str + "four"
      Case 3: str = str + "three"
      Case 2: str = str + "two"
      Case 1: str = str + "one"
   End Select

   Return
End Function

'
' Returns 0 if the string is alpha.
' otherwise returns the position of the first character
' that failed the test.
'
Public Function IsStringAlpha(s As String) As Long
   Dim i As Long

   For i = 1 To Len(s)
      If IsCharAlpha(Asc(Mid$(s, i, 1))) = 0 Then
         IsStringAlpha = i
         Exit Function
      End If
   Next i

   IsStringAlpha = 0
End Function

'
' Returns 0 if the string is alphaNumeric
' otherwise returns the position of the first character
' that failed the test.
'
Public Function IsStringAlphaNumeric(s As String) As Long
   Dim i As Long

   For i = 1 To Len(s)
      If IsCharAlphaNumeric(Asc(Mid$(s, i, 1))) = 0 Then
         IsStringAlphaNumeric = i
         Exit Function
      End If
   Next i

   IsStringAlphaNumeric = 0
End Function

'
' Returns 0 if the string is Numeric
' otherwise returns the position of the first character
' that failed the test.
'
Public Function IsStringNumeric(s As String) As Long
   Dim i As Long
   Dim J As Byte

   For i = 1 To Len(s)
      J = Asc(Mid$(s, i, 1))
      If IsCharAlphaNumeric(J) = 1 Then
         If IsCharAlpha(J) = 1 Then
            IsStringNumeric = i
            Exit Function
         End If
      Else
         IsStringNumeric = i
         Exit Function
      End If
   Next i

   IsStringNumeric = 0
End Function

' Trim a string returned from a system function.
'ie. kill the 0.
Public Function STrim(s As String) As String
   Dim i As Integer
   Dim s2 As String

   s2 = Trim(s)
   i = InStr(s2, Chr$(0))

   If i > 0 Then
      s2 = Left$(s2, i - 1)
   End If

   STrim = s2
End Function

Function TitleCaps(InString As String) As String
   ' *** Changing Strings to Title Case
   ' *** Useful for certain type of applications (eg for names and addresses etc),
   ' *** being able to Title Caps (ie capitalise first letter of each word) is achieved
   ' *** with the following function.
   ' *** However, be careful with names such as McDonalds as it will become Mcdonalds.
   ' *** Perhaps it would be a good idea to edit the code to cope with this...
   ' *** of applications (eg for names and addresses etc), being able to Title Caps
   ' *** (ie capitalise first letter of each word) is achieved with the following function.
   ' *** However, be careful with names such as McDonalds as it will become Mcdonalds.
   ' *** Perhaps it would be a good idea to edit the code to cope with this...

   Dim OutString        As String
   Dim CurrentLetter    As String
   Dim CurrentWord      As String
   Dim TCaps            As String
   Dim StrCount         As Integer

   ' *** Converts [instring] to Title Caps (as best it can!)
   OutString = ""
   If InString = "" Then
      TitleCaps = ""
      Exit Function
   End If

   CurrentWord = ""
   For StrCount = 1 To Len(InString)
      CurrentLetter = Mid(InString, StrCount, 1)
      CurrentWord = CurrentWord + CurrentLetter
      If InStr(" .,/\;:-!?[]()#", CurrentLetter) <> 0 Or _
            StrCount = Len(InString) Then
         TCaps = UCase(Left(CurrentWord, 1)) + _
               LCase(Right(CurrentWord, Len(CurrentWord) - 1))
         OutString = OutString + TCaps
         CurrentWord = ""
      End If
   Next
   TitleCaps = OutString

End Function

Function ReplaceString(sSearch As String, sSearchFor As String, sReplaceWith As String) As String
   ' *** Searches the sSearch variable for sSearchFor
   ' *** and replaces it with sReplaceWith.

   On Error GoTo ERROR__ReplaceString

   Dim lFoundLoc        As Long   ' Location of match.
   Dim lLenRemove       As Long   ' Length of string being replaced.

   ' *** Set length of original text to skip.
   lLenRemove = Len(sSearchFor)    ' Set location of match.

   lFoundLoc = InStr(1, sSearch, sSearchFor)

   ' If sSearchFor isn't found in sSearch
   ' just return the original string.
   If lFoundLoc = 0 Then
      ReplaceString = sSearch
      ' If match is found, return original string up to match
      ' location, concatenate new text, and search the rest of
      ' the string recursively for additional matches.
   Else
      ReplaceString = Left(sSearch, lFoundLoc - 1) & sReplaceWith & ReplaceString(Mid(sSearch, lFoundLoc + lLenRemove), sSearchFor, sReplaceWith)
   End If

EXIT_ReplaceString:
   Exit Function

ERROR__ReplaceString:
   ' Print error to Debug window and don't interrupt query.
   Debug.Print "Error Replacing String """ & sSearchFor & """ with """ & sReplaceWith & """ in text """ & sSearch & """"
   ' If there is an error, return original string
   ' and exit the function.
   ReplaceString = sSearch
   Resume EXIT_ReplaceString

End Function

Public Function ReplicateString(sStr As String, nNbr As Integer) As String
   ' *** Returns a string containing nNbr time the sStr string
   ' *** Like the space function

   Dim nI         As Integer
   Dim sTmp       As String

   sTmp = ""

   For nI = 1 To nNbr
      sTmp = sTmp & sStr
   Next

   ReplicateString = sTmp

End Function

Public Function CountTokens(sStr As String, sItem As String) As Integer
   ' *** Count the number of items in sStr

   Dim nPos       As Integer
   Dim nCount     As Integer

   nPos = InStr(sStr, sItem)
   nCount = 0

   Do While nPos > 0
      nCount = nCount + 1

      nPos = InStr(nPos + 1, sStr, sItem)
   Loop

   CountTokens = nCount

End Function

Function FileReplaceString(sFileIn As String, sSearchFor As String, sReplaceWith As String) As Boolean
   ' *** Searches in sFile file for sSearchFor
   ' *** and replaces it with sReplaceWith.

   Dim nFileIn    As Integer
   Dim nFileOut   As Integer

   Dim sFileOut   As String

   Dim sTmp       As String
   Dim sText      As String

   On Error GoTo ERROR_FileReplaceString

   sFileOut = GetTempFileName()

   ' *** Open the file to read all the text file
   nFileIn = FreeFile
   Open sFileIn For Input As #nFileIn

   ' *** Save as temporary
   nFileOut = FreeFile
   Open sFileOut For Output As #nFileOut

   sText = ""
   Do While EOF(nFileIn) = False
      Input #nFileIn, sTmp
      sText = ReplaceString(sTmp, sSearchFor, sReplaceWith)
      Write #nFileOut, , sText

   Loop
   Close #nFileIn
   Close #nFileOut

   ' *** Copy the temporary to the original
   FileCopy sFileOut, sFileIn

   ' *** Delete the temporary file
   Kill sFileOut

   FileReplaceString = True
   Exit Function

ERROR_FileReplaceString:
   If (Len(sFileOut) > 0) Then Kill sFileOut

   FileReplaceString = False

   Exit Function

End Function

Public Function Join(Source() As String, Optional sDelim As String = " ") As String
   ' *** Join arrays elements
   
   Dim sOut As String, iC As Integer
   
   On Error GoTo errh:
   For iC = LBound(Source) To UBound(Source) - 1
      sOut = sOut & Source(iC) & sDelim
   Next
   sOut = sOut & Source(iC)
   Join = sOut
   
   Exit Function
errh:
   Err.Raise Err.Number

End Function

Public Function Split(ByVal sIn As String, Optional sDelim As String, Optional nLimit As Long = -1, Optional bCompare As VbCompareMethod = vbBinaryCompare) As Variant
   ' *** Split a string into a variant array
   
   Dim sRead As String, sOut() As String, nC As Integer
   
   If sDelim = "" Then
      Split = sIn
   End If
   
   sRead = ReadUntil(sIn, sDelim, bCompare)
   
   Do
      ReDim Preserve sOut(nC)
      sOut(nC) = sRead
      nC = nC + 1
      If nLimit <> -1 And nC >= nLimit Then Exit Do
      sRead = ReadUntil(sIn, sDelim)
   Loop While sRead <> ""
   ReDim Preserve sOut(nC)
   sOut(nC) = sIn
   Split = sOut

End Function

Private Function ReadUntil(ByRef sIn As String, sDelim As String, Optional bCompare As VbCompareMethod = vbBinaryCompare) As String
   
   Dim nPos As String
   nPos = InStr(1, sIn, sDelim, bCompare)
   If nPos > 0 Then
      ReadUntil = Left(sIn, nPos - 1)
      sIn = Mid(sIn, nPos + Len(sDelim))
   End If

End Function

Public Function StrReverse(ByVal sIn As String) As String
   ' *** To reverse a string
   
   Dim nC As Integer, sOut As String
   For nC = Len(sIn) To 1 Step -1
      sOut = sOut & Mid(sIn, nC, 1)
   Next
   StrReverse = sOut

End Function

Public Function InStrRev(ByVal sIn As String, sFind As String, Optional nStart As Long = 1, Optional bCompare As VbCompareMethod = vbBinaryCompare) As Long
   ' *** Similar to InStr but searches from end of string
   
   Dim nPos As Long
   
   sIn = StrReverse(sIn)
   sFind = StrReverse(sFind)
   nPos = InStr(nStart, sIn, sFind, bCompare)
   If nPos = 0 Then
      InStrRev = 0
   Else
      InStrRev = Len(sIn) - nPos - Len(sFind) + 2
   End If

End Function

Public Function Replace(sIn As String, sFind As String, sReplace As String, Optional nStart As Long = 1, Optional nCount As Long = -1, Optional bCompare As VbCompareMethod = vbBinaryCompare) As String
   ' *** To find a particular string and replace it
   
   Dim nC As Long, nPos As Integer, sOut As String
   
   sOut = sIn
   nPos = InStr(nStart, sOut, sFind, bCompare)
   If nPos = 0 Then GoTo EndFn:
   Do
      nC = nC + 1
      sOut = Left(sOut, nPos - 1) & sReplace & _
            Mid(sOut, nPos + Len(sFind))
      If nCount <> -1 And nC >= nCount Then Exit Do
      nPos = InStr(nStart, sOut, sFind, bCompare)
   Loop While nPos > 0
   
EndFn:
   Replace = sOut

End Function

Function Soundex(sSource As String) As String
   ' *** SoundEx converts names into alpha-numeric codes which
   ' *** represent the way the word sounds.
   ' *** It allows searching of a database even if the user can't spell.
   
   Dim sSoundex            As String
   Dim sCurrentCharacter   As String
   Dim sLastCharacter      As String
   Dim iVar                As Integer
   
   sSource = UCase$(sSource)
   sSoundex = Left(sSource, 1)
   iVar = 2

   Do While Not Len(sSoundex) = 4
      Do While Mid$(sSource, iVar, 1) = sLastCharacter And iVar <= Len(sSource)
         iVar = iVar + 1
      Loop

      If iVar > Len(sSource) Then
         sSoundex = sSoundex & "0"
      Else
         sCurrentCharacter = Mid$(sSource, iVar, 1)
         If InStr("BFPV", sCurrentCharacter) Then
            sSoundex = sSoundex & "1"
         ElseIf InStr("CGJKQSXZ", sCurrentCharacter) Then
            sSoundex = sSoundex & "2"
         ElseIf InStr("DT", sCurrentCharacter) Then
            sSoundex = sSoundex & "3"
         ElseIf InStr("L", sCurrentCharacter) Then
            sSoundex = sSoundex & "4"
         ElseIf InStr("MN", sCurrentCharacter) Then
            sSoundex = sSoundex & "5"
         ElseIf InStr("R", sCurrentCharacter) Then
            sSoundex = sSoundex & "6"
         Else
         End If
      End If
      sLastCharacter = sCurrentCharacter
      iVar = iVar + 1
   Loop
   Soundex = sSoundex
End Function

Function Soundex2(sSource As String) As String
   ' *** SoundEx converts names into alpha-numeric codes which
   ' *** represent the way the word sounds.
   ' *** It allows searching of a database even if the user can't spell.
   ' *** This code includes two different
   ' ** SoundEx functions but both do essentially the same thing.

   Dim iVar1      As Integer
   Dim iVar2      As Integer
   Dim sTemp2     As Integer
   Dim iLen       As Integer
   Dim iChar      As Integer
   Dim aIndex     As String * 26
   Dim sTemp1     As String

   If Len(Trim$(sSource)) = 0 Then
      Exit Function
   End If

   aIndex = "01230120022455012623010202"

   For iVar1 = 1 To 26
      If Mid$(aIndex, iVar1, 1) = "0" Then Mid$(aIndex, iVar1, 1) = Chr$(0)
   Next iVar1

   If Len(sSource) Then
      iVar2 = 1
      sTemp1 = "0000"
      iLen = Len(sSource)
      For iChar = 1 To iLen
         sTemp2 = Asc(Mid$(sSource, iChar, 1)) And &H5F
         If iVar2 = 1 Then
            Mid$(sTemp1, iVar2, 1) = Chr$(sTemp2)
            iVar2 = iVar2 + 1
         Else
            sTemp2 = Asc(Mid$(aIndex, sTemp2 - &H40, 1))
            If sTemp2 Then
               If Asc(Mid$(sTemp1, iVar2 - 1, 1)) <> sTemp2 Then
                  Mid$(sTemp1, iVar2, 1) = Chr$(sTemp2)
                  iVar2 = iVar2 + 1
               End If
            End If
            If iVar2 > 4 Then Exit For
         End If
      Next iChar
   Else
      sTemp1 = ""
   End If
   Soundex2 = sTemp1
   
End Function

Function IsValidString(sStr As String, sInvalid As String) As Boolean
   ' >>> Determine if a String Contains Only Valid Characters
   
   Dim nI         As Integer
   
   For nI = 1 To Len(sInvalid)
      If InStr(1, sStr, Mid$(sInvalid, nI, 1), 0) Then
         IsValidString = False
         Exit Function
      End If
   Next
   IsValidString = True
   
End Function

Public Function CRC_Code(sCRC_String As String, bCRC_Make As Boolean, Optional vCRC_Number As Variant) As Boolean
   ' #VBIDEUtils#************************************************************
   ' * Programmer Name  : Waty Thierry
   ' * Web Site         : www.geocities.com/ResearchTriangle/6311/
   ' * E-Mail           : waty.thierry@usa.net
   ' * Date             : 24/09/98
   ' * Time             : 14:47
   ' * Module Name      : String
   ' * Module Filename  : String_Module
   ' * Procedure Name   : CRC_Code
   ' * Parameters       :
   ' *                    sCRC_String As String
   ' *                    bCRC_Make As Boolean
   ' *                    Optional vCRC_Number As Variant
   ' **********************************************************************
   ' * Comments         :
   ' * Creates a number that coresponds to a specific
   ' * string. Allows you to check if the string has been modified.
   ' * Usefull for sensitive data. Hard to crack since user does
   ' * not know how the CRC code was created.
   ' * Pass a string to derive CRC code from or to check against a
   ' *      CRC code
   ' * To make a CRC code pass a string to make the code from and
   ' *     pass true to bCRC_Make
   ' *     'Eg. Some_vCRC_Number = CRC_Code (Some_String, True)
   ' *     'Returns the CRC Number derived from the string
   ' * To check a CRC code pass a string to check against, pass Fa
   ' *     lse to bCRC_Make and pass the CRC code to check
   ' * Eg. CRC_Match_Boolean = CRC_Code (Some_String, False, Some_
   ' *     vCRC_Number)
   ' *     'Returns True if the CRC code matches the string
   ' *
   ' *
   ' **********************************************************************
   
   Dim nHold      As Long
   Dim A          As Integer

   If bCRC_Make = True Then

      For A = 1 To Len(sCRC_String)
         nHold = nHold + Asc(Mid(sCRC_String, A, 1))
      Next

      CRC_Code = nHold
   ElseIf bCRC_Make = False Then

      For A = 1 To Len(sCRC_String)
         nHold = nHold + Asc(Mid(sCRC_String, A, 1))
      Next


      If nHold = CLng(vCRC_Number) Then
         CRC_Code = True
      Else
         CRC_Code = False
      End If

   End If

End Function

0
 

Author Comment

by:borisl
ID: 1433072
Waty, your functions, though useful, are certainly not regular expression handling functionality I'm looking for. However as  my chances to get any answer to this question are slim by now, and you always try to help people and maintain an excelent Web site, I will except it. Thanks.  
0

Featured Post

Better Security Awareness With Threat Intelligence

See how one of the leading financial services organizations uses Recorded Future as part of a holistic threat intelligence program to promote security awareness and proactively and efficiently identify threats.

Join & Write a Comment

The debugging module of the VB 6 IDE can be accessed by way of the Debug menu item. That menu item can normally be found in the IDE's main menu line as shown in this picture.   There is also a companion Debug Toolbar that looks like the followin…
I was working on a PowerPoint add-in the other day and a client asked me "can you implement a feature which processes a chart when it's pasted into a slide from another deck?". It got me wondering how to hook into built-in ribbon events in Office.
As developers, we are not limited to the functions provided by the VBA language. In addition, we can call the functions that are part of the Windows operating system. These functions are part of the Windows API (Application Programming Interface). U…
Get people started with the process of using Access VBA to control Excel using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Excel. Using automation, an Access application can laun…

760 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

23 Experts available now in Live!

Get 1:1 Help Now