module1.bas

VB毕业设计源码 适合VB爱好者 及关大做毕业设计的学生朋友 使用与参考

Attribute VB_Name = "Module1"
Option Explicit

Private Const WSADescription_Len As Long = 255  '256, 基索引为0
Private Const WSASYS_Status_Len As Long = 127   '128, 基索引为0
Private Const WS_VERSION_REQD As Long = &H101
Private Const SOCKET_ERROR As Long = -1
Private Const AF_INET As Long = 2
Private Const IP_SUCCESS As Long = 0
Private Const MIN_SOCKETS_REQD As Long = 1
Public Const EM_SETTABSTOPS As Long = &HCB

Private Type WSADATA
   wVersion As Integer
   wHighVersion As Integer
   szDescription(0 To WSADescription_Len) As Byte
   szSystemStatus(0 To WSASYS_Status_Len) As Byte
   imaxsockets As Integer
   imaxudp As Integer
   lpszvenderinfo As Long
End Type

Public Type ICMP_OPTIONS
   ttl             As Byte         '存活时间
   Tos             As Byte         '超时
   Flags           As Byte         '标志选项
   OptionsSize     As Long         '
   OptionsData     As Long         '
End Type

Public Type ICMP_ECHO_REPLY
   Address         As Long         '应答主机的地址
   Status          As Long         '应答的状态码
   RoundTripTime   As Long         'round-trip时间，单位毫秒。
   datasize        As Integer      '应答数据的大小， 总为一个Int型。
   Reserved        As Integer      '保留
   DataPointer     As Long         '指向数据的指针
   Options         As ICMP_OPTIONS '应答选项，用于tracert中
   ReturnedData    As String * 256 '在应答消息后返回的数据，该字符串一定要有足够的空间。
End Type

Public Declare Function SendMessage Lib "user32" _
   Alias "SendMessageA" _
  (ByVal hwnd As Long, _
   ByVal wMsg As Long, _
   ByVal wParam As Long, _
   lParam As Any) As Long
   
Private Declare Function WSAStartup Lib "wsock32.dll" _
  (ByVal VersionReq As Long, _
   WSADataReturn As WSADATA) As Long
  
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long

Public Declare Function inet_addr Lib "wsock32.dll" _
  (ByVal s As String) As Long

Private Declare Function gethostbyaddr Lib "wsock32.dll" _
  (haddr As Long, _
   ByVal hnlen As Long, _
   ByVal addrtype As Long) As Long
  
Private Declare Function gethostname Lib "wsock32.dll" _
   (ByVal szHost As String, _
    ByVal dwHostLen As Long) As Long
    
Private Declare Function gethostbyname Lib "wsock32.dll" _
   (ByVal szHost As String) As Long

Private Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Dest As Any, _
   Source As Any, _
   ByVal nbytes As Long)

Private Declare Function inet_ntoa Lib "wsock32.dll" _
   (ByVal addr As Long) As Long

Private Declare Function lstrcpyA Lib "kernel32" _
  (ByVal RetVal As String, _
   ByVal Ptr As Long) As Long
                        
Private Declare Function lstrlenA Lib "kernel32" _
  (ByVal Ptr As Any) As Long
  
Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long

Public Declare Function IcmpCloseHandle Lib "icmp.dll" _
   (ByVal IcmpHandle As Long) As Long
    
Public Declare Function IcmpSendEcho Lib "icmp.dll" _
   (ByVal IcmpHandle As Long, _
    ByVal DestinationAddress As Long, _
    ByVal RequestData As String, _
    ByVal RequestSize As Long, _
    RequestOptions As ICMP_OPTIONS, _
    ReplyBuffer As ICMP_ECHO_REPLY, _
    ByVal ReplySize As Long, _
    ByVal Timeout As Long) As Long

Public Function GetIPFromHostName(ByVal sHostName As String) As String

  '将主机名转换为IP地址
   Dim ptrHosent As Long      'hostent结构的地址
   Dim ptrName As Long        'name指针的地址
   Dim ptrAddress As Long     'address指针的地址
   Dim ptrIPAddress As Long   '存放最终的IP地址的字符串的地址
   Dim dwAddress As Long      '最终的IP地址
   
   ptrHosent = gethostbyname(sHostName & vbNullChar)
   If ptrHosent <> 0 Then
     '设定指针地址与偏移量
     'ptrName给出了官方主机名，如果使用DNS或类似的解析系统，
     '则它是能让服务器返回应答信息的完全合格域名（FQDN）。
     '如果使用本地机器文件，则它是IP地址后的第一个入口。
      ptrName = ptrHosent
     '以空字符结尾的主机地址列表。该地址自HOSENT结构的开始地址处偏移12个字节。
      ptrAddress = ptrHosent + 12
     '获取实际的IP地址
      CopyMemory ptrAddress, ByVal ptrAddress, 4
      CopyMemory ptrIPAddress, ByVal ptrAddress, 4
      CopyMemory dwAddress, ByVal ptrIPAddress, 4
      GetIPFromHostName = GetIPFromAddress(dwAddress)
   End If
End Function

Public Sub SocketsCleanup()
  '如果终止套接字失败，则显示错误信息
   If WSACleanup() <> 0 Then
       MsgBox "Windows Sockets error occurred during Cleanup.", vbExclamation
   End If
End Sub

Public Function SocketsInitialize() As Boolean
   Dim WSAD As WSADATA
  '当版本信息符合，则返回True
  SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function

Public Function GetIPFromAddress(Address As Long) As String
   Dim ptrString As Long
   ptrString = inet_ntoa(Address)
   GetIPFromAddress = GetStrFromPtrA(ptrString)
End Function

Public Function GetStrFromPtrA(ByVal lpszA As Long) As String
   GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
   Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function