url vb 正则表达式
VB6引用：Microsoft VBScript Regular Exdivssions 5.5
==================================
Public Function IsUrl(ByVal strTmp As String) As Boolean
On Error GoTo Z
Dim objIntPattern
IsUrl = False
Set objIntPattern = New RegExp
objIntPattern.Pattern = "^(http://|https://){0,1}[A-Za-z0-9][A-Za-z0-9\-\.]+[A-Za-z0-9]\.[A-Za-z]{2,}[\43-\176]*$"
objIntPattern.Global = True
IsUrl = objIntPattern.Test(strTmp)
Set objIntPattern = Nothing
Z:
End Function
Private Sub Command1_Click()
MsgBox IsUrl( "http://www.sohu.com")
End Sub
VB.Net：
=============================================================
Public Shared Function IsUrl(ByVal strTmp As String) As Boolean
On Error GoTo Z
Dim objIntPattern As New System.Text.RegularExdivssions.Regex( "^(http://|https://){0,1}[A-Za-z0-9][A-Za-z0-9\-\.]+[A-Za-z0-9]\.[A-Za-z]{2,}[\43-\176]*$")
Return objIntPattern.IsMatch(strTmp)
Z:
End Function
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
MsgBox (IsUrl( "http://www.sohu.com"))
End Sub
=====================================================================================
vb从文件中提取所有url，显示到文本框中
Private Sub Command1_Click()
Dim F As String
F = "D:\新建文件夹\新建文件夹\自动邮箱提取发送系统\temp_file\email_web.txt"
Call GetAllStr(F, " href=" & Chr(34), Chr(34))
End Sub
Private Sub GetAllStr(F As String, Find1 As String, Find2 As String)
Dim nStr As String, H As Long, B() As Byte, S As Long
Dim FindStart As Long, IsFond As Boolean, Str1 As String, nFond As String
On Error GoTo Cuo
S = FileLen(F)
ReDim B(1 To S)
H = FreeFile
Open F For Binary As #H
Get #H, , B
Close #H
nStr = StrConv(B, vbUnicode)
FindStart = 1
Do
Str1 = GetStr(nStr, FindStart, Find1, Find2, IsFond)
If Not IsFond Then Exit Do
If Str1 <> "" Then nFond = nFond & Str1 & vbCrLf
XiaS:
Loop
Text1.Text = F & vbCrLf & "查找结果：" & vbCrLf & nFond
Exit Sub
Cuo:
MsgBox "文件没有找到：" & vbCrLf & F, vbInformation
End Sub
Private Function GetStr(nStr As String, FindStart As Long, StrQ As String, StrH As String, Optional IsFond As Boolean) As String
Dim sQ As Long, sH As Long, LongQ As Long, LongH As Long
IsFond = False
LongQ = Len(StrQ): LongH = Len(StrH)
If LongQ > 0 Then sQ = InStr(FindStart, nStr, StrQ, vbTextCompare) Else sQ = FindStart
If sQ = 0 Then Exit Function
If LongH > 0 Then sH = InStr(sQ + LongQ, nStr, StrH, vbTextCompare) Else sH = 1 + Len(nStr)
If sH = 0 Then Exit Function
GetStr = Mid(nStr, sQ + LongQ, sH - sQ - LongQ)
FindStart = sH + LongH
IsFond = True
End Function
说明：此函数对 HREF=' 和 HREF= 不起做用