publicmod.bas

一个测试网络链接速度的工具源码。测试你的网络连接速率。

Attribute VB_Name = "PublicMod"
' *************  网络测速器 ***************
' 作者:~蝸牜尐籽~ QQ:45524562
' 邮箱:[e-mail]

' ********************* 网页处理模块 *********************
Option Explicit

Public Type aLink
    txt As String
    href As String
End Type

Public WebPathUrl As String '测速网页路径
Public NowWebSped As Double '测试完的速度
Public SnailErr As Boolean

Public snLinks() As aLink, snInput(1) As String

'函数名称  : GetString(字符串,字符串A,字符串B)
'举    例  : GetString("<td>1234567890</td>","<td>","</td>") ===> "1234567890"
'作    用  : 获取固定字符串 在字符串A与B之间的字符
Public Function GetString(ByVal snStr As String, ByVal FstStr As String, ByVal SecStr As String) As String     '取两字符串间的字符串
    Dim FstLen As Long, SecLen As Long, MaxLen As Long
    Dim FstNum As Long, SecNum As Long, NowNum As Long
    Dim MidStr As String, tmp As String
    
    FstLen = Len(FstStr)
    SecLen = Len(SecStr)
    MaxLen = Len(snStr)
    NowNum = 1
On Error GoTo ErrMsg:
'开始查找中间字符串
    While NowNum <= MaxLen
        FstNum = InStr(NowNum, snStr, FstStr) '获取第1个字符位置
        SecNum = InStr(FstNum + FstLen + 1, snStr, SecStr) '获取第2个字符位置
        
        If SecNum = 0 Or FstNum = 0 Then Exit Function
        
        MidStr = Mid(snStr, FstNum + FstLen, SecNum - FstNum - FstLen)
        NowNum = SecNum + SecLen
        tmp = "&nbsp;|<br>|<BR>|<SPAN class=text_hui>|</SPAN>|<A class=A03 title=如果此地址信息不对，请点这里注册。。。 href=" & Chr(34) & "http://www.linkwan.com/gb/broadmeter/VisitorInfo/RigisterIP.htm" & Chr(34) & " target=_Blank>|" & _
              "</A>|<td>|</td>|<TD>|</TD>|" & vbCrLf & "|上传速度温度计|" & _
              "<font style=" & Chr(34) & "font-size: 14pt" & Chr(34) & " face=" & Chr(34) & "Arial" & Chr(34) & " color=" & Chr(34) & "#FF00FF" & Chr(34) & ">"
        MidStr = RpNum(Trim(MidStr), tmp)
        MidStr = RpNum(MidStr, "&gt;", ">")
        MidStr = RpNum(MidStr, "&lt;", "<")
        GetString = GetString & MidStr & " "
        DoEvents
    Wend
    Exit Function
ErrMsg:
    Err.Clear
    GetString = "获取失败"
End Function
'函数名称  : GetWebLink(浏览控件,网页带有的字符串)
'举    例  : GetWebLink(snWeb,"SpeedTest.asp")
'作    用  : 获取网页内的超级连接
Public Function GetWebLink(ByVal snWeb As Object, Optional SearchStr As String = "")
On Error GoTo ErrMsg:
Dim vDoc As Object, vTag As Object
Dim i As Long, Num As Integer, tmp() As aLink
    Set vDoc = snWeb.Document
    Num = 0
    ReDim tmp(vDoc.All.length - 1) As aLink
    For i = 0 To vDoc.All.length - 1
        If LCase(vDoc.All(i).tagName) = "a" Then
            Set vTag = vDoc.All(i)
            If InStrRev(LCase(vTag.href), LCase(SearchStr)) > 0 Then
                tmp(Num).href = vTag.href
                tmp(Num).txt = vTag.innerHTML
                Num = Num + 1
            End If
        End If
        DoEvents
    Next i
ReDim snLinks(Num - 1) As aLink
For i = 0 To UBound(tmp)
    If tmp(i).txt <> Empty Then snLinks(i) = tmp(i)
    DoEvents
Next i
Exit Function
ErrMsg:
    Err.Clear
    SnailErr = True
    Num = MsgBox("互联网资源不可用！本程序即将关闭！" & vbCrLf & "是否关闭？", 36, "获取信息")
    If Num = 6 Then End
End Function
'函数名称  : Hex2Chr()
'举    例  : Hex2Chr("%B8%A3%BD%A8%CF%C3%C3%C5%28%CF%C3%C3%C5%BA%A3%C3%CB%BF%C6%BC%BC%D3%D0%CF%DE%B9%AB%CB%BE%29")
'作    用  : 将网页字符串转成文字       '福建厦门(厦门海盟科技有限公司)
Public Function Hex2Chr(ByVal snChr As String)
Dim i As Integer, tmp() As String, Stp As Integer
Dim StrCont As String, ChrNum As Long
Dim ErrStr As String
    StrCont = ""
    tmp = Split(snChr, "%") '获取数组大小
    i = 1
    While i <= UBound(tmp)
        If i >= UBound(tmp) Then '判断是否溢出
            ChrNum = Val("&h" & Left(tmp(i - 1), 2))
        Else
            ChrNum = Val("&h" & Left(tmp(i), 2) & Left(tmp(i + 1), 2))
        End If
        If ChrNum > 0 Then '如果是英文
            If Len(tmp(i)) > 2 Then '判断当前的字符是否带有其它符号
                ErrStr = Mid(tmp(i), 3, Len(tmp(i)) - 2)
            Else
                ErrStr = ""
            End If
            StrCont = StrCont & Chr(Val("&h" & Left(tmp(i), 2))) & ErrStr
            Stp = 1
        Else                '如果是中文字符
            If Len(tmp(i + 1)) > 2 Then '判断当前的字符是否带有其它符号
                ErrStr = Mid(tmp(i + 1), 3, Len(tmp(i + 1)) - 2)
            Else
                ErrStr = ""
            End If
            StrCont = StrCont & Chr(ChrNum) & ErrStr
            Stp = 2
        End If
        i = i + Stp
        DoEvents
    Wend
    Hex2Chr = StrCont
End Function

'函数名称  : RpNum()
'举    例  : RpNum("<br><BR>","<br>|</td>")
'作    用  : 过滤多个字符串
Public Function RpNum(ByVal snChr As String, ByVal snSpt As String, Optional reSpt As String = "") As String
    Dim sptNum() As String, i As Integer
    Dim sptTmp As String
        sptTmp = snChr
        sptNum = Split(snSpt, "|")
        For i = 0 To UBound(sptNum)
            sptTmp = Replace(sptTmp, sptNum(i), reSpt)
        Next i
            RpNum = sptTmp
End Function