Binaryworld - Create your own Image/Link extractor tool using Regular Expressions ... [ VB -> Regular Expression ]

This is a very simple code to present use of Regular expression to solve some complex text operation which is kinda impossible using inbuilt string functions available in Visual Basic.

For More information Visit the following MSDN article

http://msdn.microsoft.com/library/en-us/dnclinic/html/scripting051099.asp

or

http://binaryworld.net/Main/CodeListing.aspx?LanguageId=0&SearchText=regular%20expression

Step-By-Step Example
- Create a standard exe project
- Add one commandbutton, two textbox controls, one list box and one combo box
- Set text MultiLine=true
- Add the following code form1

Click here to copy the following block

Private Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Const DEMO_URL = "http://www.google.com"

Public Function GetHTMLTextFromURL(Optional url As String = "http://www.binaryworld.net", Optional SaveOnDisk As Boolean = False, Optional LocalPath As String = "C:\dow.htm") As String
  Const TEMP_FILE = "c:\_tmp"

  On Error GoTo errHandler

  Dim lngRetVal As Long

  If SaveOnDisk = True Then
    lngRetVal = URLDownloadToFile(0, url, LocalPath, 0, 0)
    If lngRetVal = 0 Then GetHTMLTextFromURL = LocalPath
  Else
    lngRetVal = URLDownloadToFile(0, url, TEMP_FILE, 0, 0)
    If lngRetVal <> 0 Then
      GetHTMLTextFromURL = ""
    Else
      GetHTMLTextFromURL = ReadFromFile(TEMP_FILE)
    End If

    On Error Resume Next
    Kill TEMP_FILE
  End If

  Exit Function

errHandler:
  'lblErr = Err.Description
  On Error Resume Next
  Kill TEMP_FILE
End Function

Public Function SaveToFile(Content As String, _
FilePath As String, Optional Append As Boolean = False) _
As Boolean
  Dim iFile As Integer
  iFile = FreeFile
  If Append Then
    Open FilePath For Append As #iFile
  Else
    Open FilePath For Output As #iFile
  End If

  Print #iFile, Content
  SaveToFile = True

ErrorHandler:
  Close #iFile
End Function

Public Function ReadFromFile(FilePath As String) As String
  On Error GoTo errHandler

  Dim iFile As Integer

  '//Check for File Path
  If Dir(FilePath) = "" Then Exit Function

  On Error GoTo errHandler:

  iFile = FreeFile
  Open FilePath For Input As #iFile
  ReadFromFile = Input(LOF(iFile), #iFile)
errHandler:
  If iFile > 0 Then Close #iFile
End Function

'//Example to find all Sub matches in a match
Function GetSubMatch(inpStr, inpPattern, Optional MatchIndex As Integer = 0) As String
  On Error Resume Next

  Dim regEx, oMatch, oMatches
  'Set regEx = New RegExp
  Set regEx = CreateObject("VBScript.RegExp")

  regEx.Pattern = inpPattern  ' Set pattern.
  regEx.IgnoreCase = True ' Set case insensitivity.
  regEx.Global = True   ' Set global applicability.

  ' Get the Matches collection
  Set oMatches = regEx.Execute(inpStr)
  'Debug.Print regEx.Test(inpStr)
  Set oMatch = oMatches(0) '//get first match
  ' Get the sub-matched parts of the address.
  retStr = oMatch.SubMatches(MatchIndex)

  GetSubMatch = retStr
End Function

Function GetAllMatch(patrn As String, strng As String, Optional SubMatchIndex As Integer = -1) As Collection
  Dim c As New Collection
  Dim regEx, Match, Matches, i  ' Create variable.
  'Set regEx = New RegExp ' Create regular expression.
  Set regEx = CreateObject("VBScript.RegExp")

  regEx.Pattern = patrn  ' Set pattern.
  regEx.IgnoreCase = True ' Set case insensitivity.
  regEx.Global = True   ' Set global applicability.

  Set Matches = regEx.Execute(strng)  ' Execute search.
  For Each Match In Matches ' Iterate Matches collection.
    i = i + 1
    'retStr = retStr & "Match " & I & " found at position "
    'retStr = retStr & Match.FirstIndex & ". Match Value is "  '
    'retStr = retStr & Match.Value & "'." & vbCrLf
    If SubMatchIndex >= 0 Then
      c.Add Match.SubMatches(SubMatchIndex)
    Else
      c.Add Match.Value
    End If
  Next
  Set GetAllMatch = c
End Function

Private Sub Command1_Click()
  Dim strRegX As String, strRegXHREF As String
  Dim colmatches As New Collection

  '//Download from a URL
  Me.Caption = "Downloading the html page..."
  Text1.Text = GetHTMLTextFromURL(Text2)  '//Must be valid http URL starting with http://
  Me.Caption = "APIDemo"

  '//----or----

  '//Load from Disk
  'Text1.Text = ReadFromFile("c:\test.htm")
  Call RegXDemo

End Sub

Private Sub Form_Load()
  Text2.Text = "http://binaryworld.net"
  Command1.Caption = "&Go"
  Combo1.AddItem "Find Only href from <A> tag"
  Combo1.AddItem "Find all <A> tags"
  Combo1.AddItem "Find only linked text"
  Combo1.AddItem "Find Only src from <img> tag"
  Combo1.AddItem "Find all <img> tags"
  Combo1.ListIndex = 0
End Sub

Sub RegXDemo()
  Dim strRegX As String
  Debug.Print String(80, "=")
  List1.Clear
  Select Case Combo1.ListIndex
    Case 0        '//Link from <A> tag
      strRegX = "<\s*A(.*?)href=['""]*(.*?)['""](.*?)>(.*?)<\s*/A\s*>"
      Debug.Print strRegX
      Set colmatches = GetAllMatch(strRegX, Text1, 1)  '//This will return only url of href attribute of <A> tag
    Case 1        '//Full <A> tag
      strRegX = "<\s*A(.|\n)*?\s*>((.|\n)*?)<\s*\/A\s*>"
      Set colmatches = GetAllMatch(strRegX, Text1)
    Case 2        '//Only text between <A> and </A> tags
      strRegX = "<\s*A(.*?)href=['""]*(.*?)['""](.*?)>(.*?)<\s*/A\s*>"
      Set colmatches = GetAllMatch(strRegX, Text1, 2)  '//This will return text between <A>text</A> tags
    Case 3        '//only image from <Img> tag
      strRegX = "<\s*IMG(.*?)src=['""]*(.*?)['""](.*?)>"
      Set colmatches = GetAllMatch(strRegX, Text1, 1)  '//This will return only src attribute of <IMG> tag
    Case 4        '//Full <img> tag
      strRegX = "<\s*IMG(.|\n)*?\s*>"
      Set colmatches = GetAllMatch(strRegX, Text1)
  End Select

  If colmatches.Count > 0 Then
    For i = 1 To colmatches.Count
      If colmatches(i) <> "" Then List1.AddItem colmatches(i): Debug.Print colmatches(i)
    Next
  End If

  Me.Caption = "Total " & i & " match found"

  ShowSamplePage
End Sub

Private Sub Form_Unload(Cancel As Integer)
  On Error Resume Next
  Kill "c:\Out.html"
End Sub

Private Sub List1_Click()
  If List1.ListIndex >= 0 Then

    MsgBox List1.List(List1.ListIndex)
    Clipboard.SetText List1.List(List1.ListIndex), ClipBoardConstants.vbCFText
  End If
End Sub

Sub ShowSamplePage()
  Dim strHTML As String, strItems As String, i, itm, url
  For i = 0 To List1.ListCount - 1
    Select Case Combo1.ListIndex
      Case 1, 2, 4
        itm = List1.List(i)
      Case 0, 3
        itm = Trim(List1.List(i))
        url = Trim(Text2)
        url = IIf(Right(url, 1) = "/" Or Right(url, 1) = "\", url, url & "/")

        If Left(itm, 1) <> "/" And Left(itm, 1) <> "\" Then
          '//we need to prefix base url only image is not full url i.e. "images/user.gif"
          If Left(itm, 4) <> "http" Then
            itm = url & itm
          End If
        Else
          itm = Mid(url, 1, Len(url) - 1) & itm  '//remnove "/" from base url
        End If

        If Combo1.ListIndex = 0 Then
          'itm = "<img src='" & itm & "'> " & "<a href='" & itm & "'>" & itm & "</a>"
          itm = "<a href='" & itm & "'>" & itm & "</a>"
        Else
          itm = "<img src='" & itm & "'> " & itm
        End If
    End Select

    strItems = strItems & "<TR><TD>" & itm & "</TD></TR>" & vbCrLf
  Next
  strHTML = "<HTML><HEAD><TITLE>" & List1.ListCount & " Items found</TITLE></HEAD>" & _
      "<BODY><TABLE><TR><TD><H2>Extracted Items (" & List1.ListCount & " Items found)</H2></TD></TR>" & strItems & "</TABLE></BODY></HTML>"

  Debug.Print strHTML

  SaveToFile strHTML, "C:\Out.html"
  Shell "explorer C:\Out.html", vbNormalFocus
End Sub