form1.frm

本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP、Modem串口通信编程、拨号网络编程等内容进行详细的讲解

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "PING程序"
   ClientHeight    =   3765
   ClientLeft      =   3840
   ClientTop       =   4035
   ClientWidth     =   6300
   BeginProperty Font 
      Name            =   "Arial"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "Form1.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   3765
   ScaleWidth      =   6300
   Begin VB.TextBox Text3 
      BeginProperty Font 
         Name            =   "Terminal"
         Size            =   9
         Charset         =   255
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   2490
      Left            =   75
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   5
      Top             =   1200
      Width           =   6045
   End
   Begin VB.TextBox Text1 
      Alignment       =   2  'Center
      Height          =   315
      Left            =   1890
      TabIndex        =   0
      Text            =   "www.sohu.com"
      Top             =   195
      Width           =   1965
   End
   Begin VB.CommandButton Command1 
      Caption         =   "&Ping"
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   390
      Left            =   4440
      TabIndex        =   1
      Top             =   360
      Width           =   765
   End
   Begin VB.Label Label3 
      Alignment       =   2  'Center
      BackColor       =   &H00FFFFFF&
      BorderStyle     =   1  'Fixed Single
      Height          =   315
      Left            =   1890
      TabIndex        =   4
      Top             =   570
      Width           =   1965
   End
   Begin VB.Label Label2 
      Alignment       =   1  'Right Justify
      Caption         =   "IP地址："
      Height          =   255
      Left            =   990
      TabIndex        =   3
      Top             =   645
      Width           =   870
   End
   Begin VB.Label Label1 
      Alignment       =   1  'Right Justify
      Caption         =   "主机名："
      Height          =   255
      Left            =   915
      TabIndex        =   2
      Top             =   270
      Width           =   975
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
' WSock32 变量

Dim iReturn As Long, sLowByte As String, sHighByte As String
Dim sMsg As String, HostLen As Long, Host As String
Dim Hostent As Hostent, PointerToPointer As Long, ListAddress As Long
Dim WSAdata As WSAdata, DotA As Long, DotAddr As String, ListAddr As Long
Dim MaxUDP As Long, MaxSockets As Long, i As Integer
Dim Description As String, Status As String

' ICMP 变量
Dim bReturn As Boolean, hIP As Long
Dim szBuffer As String
Dim Addr As Long
Dim RCode As String
Dim RespondingHost As String

' TRACERT 变量

Dim TraceRT As Boolean
Dim TTL As Integer


' WSock32 常数

Const WS_VERSION_MAJOR = &H101 \ &H100 And &HFF&
Const WS_VERSION_MINOR = &H101 And &HFF&
Const MIN_SOCKETS_REQD = 0

'将状态码翻译成相关的说明
Sub GetRCode()

    If pIPe.Status = 0 Then RCode = "Success"
    If pIPe.Status = 11001 Then RCode = "Buffer too Small"
    If pIPe.Status = 11002 Then RCode = "Dest Network Not Reachable"
    If pIPe.Status = 11003 Then RCode = "Dest Host Not Reachable"
    If pIPe.Status = 11004 Then RCode = "Dest Protocol Not Reachable"
    If pIPe.Status = 11005 Then RCode = "Dest Port Not Reachable"
    If pIPe.Status = 11006 Then RCode = "No Resources Available"
    If pIPe.Status = 11007 Then RCode = "Bad Option"
    If pIPe.Status = 11008 Then RCode = "Hardware Error"
    If pIPe.Status = 11009 Then RCode = "Packet too Big"
    If pIPe.Status = 11010 Then RCode = "Rqst Timed Out"
    If pIPe.Status = 11011 Then RCode = "Bad Request"
    If pIPe.Status = 11012 Then RCode = "Bad Route"
    If pIPe.Status = 11013 Then RCode = "TTL Exprd in Transit"
    If pIPe.Status = 11014 Then RCode = "TTL Exprd Reassemb"
    If pIPe.Status = 11015 Then RCode = "Parameter Problem"
    If pIPe.Status = 11016 Then RCode = "Source Quench"
    If pIPe.Status = 11017 Then RCode = "Option too Big"
    If pIPe.Status = 11018 Then RCode = " Bad Destination"
    If pIPe.Status = 11019 Then RCode = "Address Deleted"
    If pIPe.Status = 11020 Then RCode = "Spec MTU Change"
    If pIPe.Status = 11021 Then RCode = "MTU Change"
    If pIPe.Status = 11022 Then RCode = "Unload"
    If pIPe.Status = 11050 Then RCode = "General Failure"
    RCode = RCode + " (" + CStr(pIPe.Status) + ")"

    DoEvents
    If TraceRT = False Then
    
        If pIPe.Status = 0 Then
            Text3.Text = Text3.Text + "  Reply from " + RespondingHost + ": Bytes = " + Trim$(CStr(pIPe.DataSize)) + " RTT = " + Trim$(CStr(pIPe.RoundTripTime)) + "ms TTL = " + Trim$(CStr(pIPe.Options.TTL)) + Chr$(13) + Chr$(10)
        Else
            Text3.Text = Text3.Text + "  Reply from " + RespondingHost + ": " + RCode + Chr$(13) + Chr$(10)
        End If

    Else
        If TTL - 1 < 10 Then Text3.Text = Text3.Text + "  Hop # 0" + CStr(TTL - 1) Else Text3.Text = Text3.Text + "  Hop # " + CStr(TTL - 1)
        Text3.Text = Text3.Text + "  " + RespondingHost + Chr$(13) + Chr$(10)
    End If

End Sub

Sub vbGetHostByName()

    Dim szString As String

    Host = Trim$(Text1.Text)               ' 获得主机地址

    szString = String(64, &H0)
    Host = Host + Right$(szString, 64 - Len(Host))

    If gethostbyname(Host) = SOCKET_ERROR Then              ' WSock32错误
        sMsg = "Winsock Error" & Str$(WSAGetLastError())
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
    Else
        PointerToPointer = gethostbyname(Host)              ' 获得winsock结构地址指针Get the pointer to the address of the winsock hostent structure
        CopyMemory Hostent.h_name, ByVal _
        PointerToPointer, Len(Hostent)                      ' 将Winsock结构复制成VB结构

        ListAddress = Hostent.h_addr_list                   ' 获得地址列表
        CopyMemory ListAddr, ByVal ListAddress, 4           ' 复制内存
        CopyMemory IPLong, ByVal ListAddr, 4                ' 获得Address List的第一个入口
        CopyMemory Addr, ByVal ListAddr, 4

        Label3.Caption = Trim$(CStr(Asc(IPLong.Byte4)) + "." + CStr(Asc(IPLong.Byte3)) _
            + "." + CStr(Asc(IPLong.Byte2)) + "." + CStr(Asc(IPLong.Byte1)))
    End If

End Sub

Sub vbGetHostName()
    
    Host = String(64, &H0)          ' 获得一个空字符串
    If gethostname(Host, HostLen) = SOCKET_ERROR Then     '
        sMsg = "WSock32 Error" & Str$(WSAGetLastError())  ' 如果有WSOCK32错误
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
    Else
        Host = Left$(Trim$(Host), Len(Trim$(Host)) - 1)   ' 去掉结果种的空格
        Text1.Text = Host                                 ' 显示主机名
    End If

End Sub

Sub vbIcmpSendEcho()

    Dim NbrOfPkts As Integer

    szBuffer = "abcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklmnopqrstuvwabcdefghijklm"


    '数据包大小
    szBuffer = Left$(szBuffer, 32)


    
    '包发送次数
    For NbrOfPkts = 1 To 5

        DoEvents
        bReturn = IcmpSendEcho(hIP, Addr, szBuffer, Len(szBuffer), pIPo, pIPe, Len(pIPe) + 8, 2700)

        If bReturn Then

            RespondingHost = CStr(pIPe.Address(0)) + "." + CStr(pIPe.Address(1)) + "." + CStr(pIPe.Address(2)) + "." + CStr(pIPe.Address(3))

            GetRCode

        Else        ' ICMP超时
                    '

            If TraceRT Then
                TTL = TTL - 1
            Else
                Text3.Text = Text3.Text + "ICMP Request Timeout" + Chr$(13) + Chr$(10)
            End If

        End If

    Next NbrOfPkts

End Sub

Sub vbWSAStartup()
    
    ' 初始化Winsock
    iReturn = WSAStartup(&H101, WSAdata)

    If iReturn <> 0 Then
        MsgBox "WSock32.dll is not responding!", vbOKOnly, "VB4032-ICMPEcho"
    End If

    If LoByte(WSAdata.wVersion) < WS_VERSION_MAJOR Or (LoByte(WSAdata.wVersion) = WS_VERSION_MAJOR And HiByte(WSAdata.wVersion) < WS_VERSION_MINOR) Then
        sHighByte = Trim$(Str$(HiByte(WSAdata.wVersion)))
        sLowByte = Trim$(Str$(LoByte(WSAdata.wVersion)))
        
        sMsg = "WinSock Version " & sLowByte & "." & sHighByte
        sMsg = sMsg & " is not supported "
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If

    If WSAdata.iMaxSockets < MIN_SOCKETS_REQD Then
        sMsg = "This application requires a minimum of "
        sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If
    
    MaxSockets = WSAdata.iMaxSockets

    'WSAdata.iMaxSockets是一个无符号Short类型，必须转化成为无符号Long型

    If MaxSockets < 0 Then
        MaxSockets = 65536 + MaxSockets
    End If

    MaxUDP = WSAdata.iMaxUdpDg
    If MaxUDP < 0 Then
        MaxUDP = 65536 + MaxUDP
    End If

    '  处理Winsock描述信息
 
    Description = ""

    For i = 0 To WSADESCRIPTION_LEN
        If WSAdata.szDescription(i) = 0 Then Exit For
        Description = Description + Chr$(WSAdata.szDescription(i))
    Next i

    '  处理winsock状态信息

    Status = ""

    For i = 0 To WSASYS_STATUS_LEN
        If WSAdata.szSystemStatus(i) = 0 Then Exit For
        Status = Status + Chr$(WSAdata.szSystemStatus(i))
    Next i

End Sub
Function HiByte(ByVal wParam As Integer)

    HiByte = wParam \ &H100 And &HFF&

End Function
Function LoByte(ByVal wParam As Integer)

    LoByte = wParam And &HFF&

End Function
Sub vbWSACleanup()

    ' 终止winsock
    iReturn = WSACleanup()

    If iReturn <> 0 Then
        sMsg = "WSock32 Error - " & Trim$(Str$(iReturn)) & " occurred in Cleanup"
        MsgBox sMsg, vbOKOnly, "VB4032-ICMPEcho"
        End
    End If

End Sub

Sub vbIcmpCloseHandle()
  
    bReturn = IcmpCloseHandle(hIP)
    
    If bReturn = False Then
        MsgBox "ICMP Closed with Error", vbOKOnly, "VB4032-ICMPEcho"
    End If

End Sub

Sub vbIcmpCreateFile()

    hIP = IcmpCreateFile()

    If hIP = 0 Then
        MsgBox "Unable to Create File Handle", vbOKOnly, "VBPing32"
    End If

End Sub
Private Sub Command1_Click()

    vbWSAStartup               ' 初始化winsock

    If Len(Text1.Text) = 0 Then
        vbGetHostName
    End If

    If Text1.Text = "" Then
        MsgBox "No Hostname Specified!", vbOKOnly, "VB4032-ICMPEcho"
        vbWSACleanup
        Exit Sub
    End If

    vbGetHostByName            ' 获得IP地址

    vbIcmpCreateFile           ' 获得ICMP 句柄


    '设置TTL为255
    pIPo.TTL = 255

    vbIcmpSendEcho             ' 发送ICMP回显请求

    vbIcmpCloseHandle          ' 关闭ICMP 句柄

    vbWSACleanup               ' 关闭winsock

End Sub