MT-Blacklist URL extractor


A primitive url extractor for Jay Allen's MT-
Blacklist utility for MovableType: http://www.jayallen.org/comment_spam/

For the warnings about using this piece of amateur code, please see:
http://www.hyperorg.com/blogger/mtarchive/002669.html



Sub FindURLStoBAN() 
' walks through selected 
'files to find bad urls
 Dim objApp As Application
 Dim objSelection As Selection
 Dim objItem As Object
 Dim ipstr As String
 Dim urlstr As String
 Dim ips As String
 Dim  us As String
 
 Set objApp = CreateObject("Outlook.Application")
 ' get the selected msgs
 
 Set objSel = objApp.ActiveExplorer.Selection
 
 x = 0
 For Each objItem In objSel
   If objItem.Class = 43 Then ' 43=mailitem
     msgtxt = objItem.Body ' get msg text
     ' Is this msg from mt-blacklist?
     p = InStr(msgtxt, "MT-Blacklist") 
     If p > 0 Then ' yes it is
      ' get the ip to ban
        p1 = InStr(msgtxt, "IP Address:")
        p1 = p1 + 12
        p2 = InStr(p1, msgtxt, vbCr)
        ips = Mid(msgtxt, p1, p2 - p1)
        ipstr = ipstr & vbCr & vbLf & ips
        ' get the url listed for the name
        p1 = InStr(msgtxt, "URL: ") + 5
        p2 = InStr(p1, msgtxt, vbCr)
        us = Mid(msgtxt, p1, p2 - p1)
        urlstr = urlstr & vbCr & vbLf & ucase(us)
        
        
        ' ----'Get urls in the text
		   udone = False: prevp = 1
		   ' uppercase it because I'm lazy
		   msgtxt = UCase(msgtxt)
		   While Not udone
		    u = ""
		    ' get next a href
		    p1 = InStr(prevp, msgtxt, "<A HREF=")
		    ' get end of href
		    p3 = InStr(p1 + 1, msgtxt, ">")
		    ' find end of href
		    If p1 > 0 And p3 > 0 Then
		      ' get /a
		       p2 = InStr(p1 + 1, msgtxt, "</A>")
		       ' if it has an end /a
		       If p2 > 0 Then
		          ' extract the string
		          u = Mid(msgtxt, p1 + 9, (p3 - (p1 + 11)))
		          ' note where it ended for next loop
		          prevp = p2
		         ' is it already in the string?
		         If InStr(1, urlstr, u) = 0 Then
		           urlstr = urlstr & vbCr & vbLf & u
		          End If
		      End If
		     End If
		     ' are we out of links?
		     if p1 = 0 Then udone = True
		   Wend
                   
        
                      
      End If ' if p > 0 msg from mtblacklist
     x = x + 1
 
     End If
  
 Next

 ' Fill the two textboxes

 mtblacklistfrm.iptxt.Text = ipstr
 mtblacklistfrm.urltxt.Text = urlstr
 mtblacklistfrm.Show
 Set objItem = Nothing
 
 
 End Sub