frmmain.frm

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

    Case 0
        cmdMin.Visible = True
        cmdExit.Visible = False
        cmdMax.Visible = False
    Case 1
        cmdMax.Visible = True
        cmdExit.Visible = False
        cmdMin.Visible = False
    Case 2
        cmdExit.Visible = True
        cmdMin.Visible = False
        cmdMax.Visible = False
    End Select
End Sub

Private Sub cmdExit_Click()
    Unload Me '退出按钮按下
    End
End Sub

Private Sub cmdMax_Click()
    'If Button = 1 Then Me.WindowState = vbMaximized '最大化按钮按下
End Sub

Private Sub cmdMin_Click()
    Me.WindowState = vbMinimized '最小化按钮按下
End Sub

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

' ********************* 主程序 *********************
Private Sub Form_Load()
Dim i As Integer, WindowRegion As Long
'初始化数据
    WebPathUrl = "http://www.linkwan.com/gb/broadmeter/SpeedAuto/"
    NowWebSped = 0
    snTestWeb.Navigate WebPathUrl
    snTest.Navigate "about:blank"
'自定义窗口数据
    Me.ScaleMode = vbPixels
    Me.AutoRedraw = True
    Me.BorderStyle = vbBSNone
      '调用自定义函数
      'WindowRegion = MakeRegion(Me)
      '矩形窗口改变为图片形状窗口
      'SetWindowRgn Me.hwnd, WindowRegion, True
'窗体比例对齐
Me.Move (Screen.Width - Me.Width) / 2, (Screen.Height - Me.Height) / 4

With MoveFrm
    .Caption = "":          .BackStyle = 0
    .Top = 1:               .Left = 0
    .Width = Me.ScaleWidth: .Height = 30
End With
'顶部按钮初始化设置
With cmdButon(0)
    .Top = 10: .Left = 425
    .Caption = "": .BackStyle = 0
End With
With cmdButon(1)
    .Top = 10: .Left = 445
    .Caption = "": .BackStyle = 0
End With
With cmdButon(2)
    .Top = 10: .Left = 465
    .Caption = "": .BackStyle = 0
End With
'系统按钮初始化设置
    cmdMin.Top = 10:  cmdMin.Left = 425:  cmdMin.Visible = False
    cmdMax.Top = 10:  cmdMax.Left = 445:  cmdMax.Visible = False
    cmdExit.Top = 10: cmdExit.Left = 465: cmdExit.Visible = False
'站点列表初始化设置
For i = 0 To 29
    With List(i)
        .Visible = False
        .ForeColor = &H80000002
        .MouseIcon = cmdMin.MouseIcon
        .MousePointer = 99
    End With
Next i
'翻页按钮初始化设置
With MoveP
    .Visible = False
    .MouseIcon = cmdMin.MouseIcon
    .MousePointer = 99
End With
With MoveN
    .Visible = False
    .MouseIcon = cmdMin.MouseIcon
    .MousePointer = 99
End With
'网速显示初始化设置
With imNumKbps(0)
    .Stretch = True
    .Visible = False
    .Top = 228
    .Left = 424
End With
With imNumKbps(1)
    .Stretch = False
    .Visible = False
    .Top = 228
    .Left = 424
End With
'关于按钮初始化设置
about.MouseIcon = cmdMin.MouseIcon
about.MousePointer = 99
'数据初始化设置
lbOK.Visible = False
tmCheck.Enabled = False '暂时没有用
vbPageNum = 0
PcNum = 0
snPCNum = 0
SnailErr = False
End Sub
'鼠标在窗体移动时还原默认数值
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim i As Integer
    cmdExit.Visible = False
    cmdMin.Visible = False
    cmdMax.Visible = False
For i = 0 To 29
    List(i).ForeColor = &H80000002
Next i
End Sub
'点击了测试站点
Private Sub List_Click(Index As Integer)
If SnailErr Then Exit Sub
Dim tmp As String, i As Integer
PcNum = 0
    tmp = GetString(snLinks(vbPageNum * 30 + Index).href, "=", "=")
    tmp = Replace(tmp, "u", "")
    lblNowPC.Caption = "状态:正在测试站点==>>" & Hex2Chr(Mid(tmp, 1, Len(tmp) - 2))
    NowWebTitle = List(Index).Caption & " ==>> " & Hex2Chr(Mid(tmp, 1, Len(tmp) - 2))
    snTest.Navigate snLinks(vbPageNum * 30 + Index).href
    For i = 0 To 5
        listMsg(i).ForeColor = &H404040
        listMsg(i).Caption = "正在获取数据"
    Next i
    Debug.Print snLinks(vbPageNum * 30 + Index).href
End Sub
'测试站点列表特效
Private Sub List_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Dim i As Integer
    For i = 0 To 29
        If Index = i Then
            List(i).ForeColor = &HFF&
        Else
            List(i).ForeColor = &H80000002
        End If
    Next i
End Sub

'一种无标题栏窗口移动的方法
Private Sub MoveFrm_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
  ReleaseCapture    '释放窗口中的鼠标输入
  '发送模拟鼠标拖曳窗口标题栏的消息
  SendMessage Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&
End Sub

Private Sub MoveFrm_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    cmdExit.Visible = False
    cmdMin.Visible = False
    cmdMax.Visible = False
End Sub
'翻页 下一页
Private Sub MoveN_Click()
If SnailErr Then Exit Sub
Dim i As Integer, pNum As Integer
'装载网页数据
    vbPageNum = IIf(vbPageNum >= Int(UBound(snLinks) / 30), Int(UBound(snLinks) / 30), vbPageNum + 1)
For i = 0 To 29
    If UBound(snLinks) < i Then
        List(i).Visible = False
    Else
        If i + vbPageNum * 30 > UBound(snLinks) Then
            List(i).Visible = False
        Else
            List(i).Visible = True
            List(i).Caption = snLinks(i + vbPageNum * 30).txt
        End If
    End If
Next i
    lblPageNum.Caption = Format(vbPageNum + 1, "00") & Space(12) & Format(UBound(snLinks), "000") & Space(8) & "30"
End Sub
'翻页 上一页
Private Sub MoveP_Click()
If SnailErr Then Exit Sub
Dim i As Integer
'装载网页数据
    vbPageNum = IIf(vbPageNum <= 0, 0, vbPageNum - 1)
For i = 0 To 29
    If UBound(snLinks) < i Then
        List(i).Visible = False
    Else
        List(i).Visible = True
        List(i).Caption = snLinks(i + vbPageNum * 30).txt
    End If
Next i
    lblPageNum.Caption = Format(vbPageNum + 1, "00") & Space(12) & Format(UBound(snLinks), "000") & Space(8) & "30"
End Sub

'测试站点下载完成时 处理数据
Private Sub snTest_DocumentComplete(ByVal pDisp As Object, URL As Variant)
If SnailErr Then Exit Sub
    'snTest.Document.documentelement.outerhtml
Dim tmp As String, i As Integer
    PcNum = PcNum + 1
    If PcNum > 2 Then
        tmp = snTest.Document.body.innerHTML
        For i = 0 To 4
            listMsg(i).ForeColor = &H404040
        Next i
        listMsg(5).ForeColor = &H8000&
        listMsg(0).Caption = GetString(tmp, "IP：", "来自：")
        listMsg(1).Caption = GetString(tmp, "来自：", "操作系统：")
        listMsg(2).Caption = GetString(tmp, "操作系统：", "浏 览 器：")
        listMsg(3).Caption = GetString(tmp, "浏 览 器：", "测试时间：")
        listMsg(4).Caption = GetString(tmp, "测试时间：", "<BR>&nbsp;</TD>")
        listMsg(5).Caption = Trim(GetString(tmp, "<B>", "</B>")) & "kbps"
        snPCNum = Val(Split(listMsg(5).Caption, " ")(0))
        Call CheckKbps
        imNumKbps(0).Visible = True
        imNumKbps(1).Visible = True
        lbOK.Visible = True
        lbOK.ForeColor = &HC0&
        lbOK.Caption = "测试完毕"
        Open IIf(Right(App.Path, 1) <> "\", App.Path & "\测试记录.ini", App.Path & "测试记录.ini") For Append As #1
            Print #1, NowWebTitle & " 速度:" & listMsg(5).Caption
        Close #1
        NowWebTitle = ""
        DoEvents
    Else
        If InStrRev(TitleText, "无法找到该页") > 0 Then
            For i = 0 To 5
                listMsg(i).ForeColor = &HFF&
                listMsg(i).Caption = "无法获取数据"
            Next i
            lbOK.Visible = True
            lbOK.ForeColor = &HFF&
            lbOK.Caption = "测试失败"
        ElseIf tmp = Empty And PcNum <= 1 Then
            For i = 0 To 5
                listMsg(i).Caption = "加载数据中."
            Next i
            lbOK.Visible = True
            lbOK.ForeColor = &HC0&
            lbOK.Caption = "测试完成"
        End If
    End If
End Sub

'测试站点正在下载时 触发进度条
Private Sub snTest_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
Dim tmpNum As Integer
    If (Progress <> -1 And Progress <> 0) And Progress <= ProgressMax Then
        tmpNum = Progress / ProgressMax * 900
        lblPC.Width = IIf(tmpNum > 136, 136, tmpNum)
        'Debug.Print Progress / ProgressMax * 1000 & "%"
        If PcNum <= 2 Then
            snPCNum = Rnd() * 2100
            Call CheckKbps
            imNumKbps(0).Visible = True
            imNumKbps(1).Visible = True
            lbOK.Visible = True
            lbOK.ForeColor = &H80000002
            lbOK.Caption = "正在测试"
        End If
        DoEvents
    End If
End Sub
'获取网页标题
Private Sub snTest_TitleChange(ByVal Text As String)
    TitleText = Text
End Sub
'测试主站点下载完成时 处理数据
Private Sub snTestWeb_DocumentComplete(ByVal pDisp As Object, URL As Variant)
Dim i As Integer
    Call GetWebLink(snTestWeb, "SpeedTest.asp")
If SnailErr Then GoTo ErrMsg:
    lblMsgLink.Visible = False
'装载网页数据
For i = 0 To 29
    If UBound(snLinks) < i Then
        List(i).Visible = False
    Else
        List(i).Visible = True
        List(i).Caption = snLinks(i).txt
    End If
    DoEvents
Next i
    For i = 0 To 5
        listMsg(i).Caption = "Null"
    Next i
    lblPageNum.Caption = Format(vbPageNum + 1, "00") & Space(12) & Format(UBound(snLinks), "000") & Space(8) & "30"
    tmLinks.Enabled = False
ErrMsg:
    MoveP.Visible = True
    MoveN.Visible = True
    lblNowPC.Caption = "状态：数据连接完成，请选择要测试的站点！"
End Sub

Private Sub tmLinks_Timer()
    lblMsgLink.Caption = lblMsgLink.Caption & "."
    lblNowPC.Caption = lblNowPC.Caption & "."
    If Len(lblMsgLink.Caption) >= 11 Then lblMsgLink.Caption = "数据连接中."
    If Len(lblNowPC.Caption) >= 21 Then lblNowPC.Caption = "状态：初始化完成，正在数据连接."
End Sub

'函数名称  : CheckKbps()
'举    例  : CheckKbps(1200.12)
'作    用  : 获取Kbps值的高度
Public Function CheckKbps()
If SnailErr Then Exit Function
Dim Min As Integer, Max As Integer
    Min = 70: Max = 310
    Select Case snPCNum
     Case Is <= 20
        DoEvents
     Case Is <= 60
        imNumKbps(1).Top = Max - snPCNum / 20 * 15
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
     Case Is <= 100
        imNumKbps(1).Top = Max - snPCNum / 40 * 15 - 22
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
     Case Is <= 200
        imNumKbps(1).Top = Max - snPCNum / 50 * 15 - 27
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
     Case Is <= 500
        imNumKbps(1).Top = Max - snPCNum / 150 * 15 - 65
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
     Case Is <= 2000
        imNumKbps(1).Top = Max - snPCNum / 250 * 15 - 80
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
     Case Is <= 3000
        imNumKbps(1).Top = Max - snPCNum / 500 * 15 - 137
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
     Case Is > 3000
        imNumKbps(1).Top = 70
        imNumKbps(0).Top = imNumKbps(1).Top + imNumKbps(1).Height
        imNumKbps(0).Height = Max - imNumKbps(1).Height - imNumKbps(0).Top
        DoEvents
    End Select
End Function