module1.bas

Visual Basic 6 网络编程实例教程ch01～ch02分别包含了书中各章的主要程序文件

Attribute VB_Name = "Module1"
Option Explicit

Public Const MAX_WSADescription As Long = 256
Public Const MAX_WSASYSStatus As Long = 128
Public Const ERROR_SUCCESS       As Long = 0
Public Const WS_VERSION_REQD     As Long = &H101
Public Const WS_VERSION_MAJOR    As Long = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR    As Long = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD    As Long = 1
Public Const SOCKET_ERROR        As Long = -1

Public Type HOSTENT
   hName      As Long
   hAliases   As Long
   hAddrType  As Integer
   hLen       As Integer
   hAddrList  As Long
End Type

Public Type WSADATA
   wVersion      As Integer
   wHighVersion  As Integer
   szDescription(0 To MAX_WSADescription)   As Byte
   szSystemStatus(0 To MAX_WSASYSStatus)    As Byte
   wMaxSockets   As Integer
   wMaxUDPDG     As Integer
   dwVendorInfo  As Long
End Type

Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long

Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
   (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
   
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long

Public Declare Function gethostname Lib "WSOCK32.DLL" _
   (ByVal szHost As String, ByVal dwHostLen As Long) As Long
   
Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
   (ByVal szHost As String) As Long
   
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
   (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)


Public Function GetIPAddress() As String

   Dim sHostName    As String * 256
   Dim lpHost    As Long
   Dim HOST      As HOSTENT
   Dim dwIPAddr  As Long
   Dim tmpIPAddr() As Byte
   Dim i         As Integer
   Dim sIPAddr  As String
   
   If Not SocketsInitialize() Then
      GetIPAddress = ""
      Exit Function
   End If
    
  '函数gethostname返回本地机器的名称，并将该返回值存放在name指定的缓存中，
  '返回的主机名是一个以空字符结尾的字符串。主机名的格式则完全取决于Windows
  '套接字的提供者。它可以是仅仅是一个主机名，或是一个完全合格的域名。
  '但它们都能由函数gethostbyname和WSAAsyncGetHostByName正确解析。
  
  '如果实际的应用程序没有配置本地机器名，gethostname也能正确执行，
  '并返回一个gethostbyname或WSAAsyncGetHostByName能解析的令牌主机名
   
   If gethostname(sHostName, 256) = SOCKET_ERROR Then
      GetIPAddress = ""
      MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _
              " has occurred. Unable to successfully get Host Name."
      SocketsCleanup
      Exit Function
   End If
   
  'gethostbyname返回一个指向HOSTENT结构的指针，该结构由Windows套接字分配。
  '该结构中包含了成功查找到的由name指定的主机信息

  'gethostbyname不能解析传递给它的IP地址。对于传递给它的IP地址，
  '本函数将其视会一个未知的主机名。如果只知道机器的IP地址，则可以
  '使用inet_addr先将IP地址字符串转换为实际的IP地址，然后，
  '使用其它的函数，如gethostbyaddr来获取主机名
   sHostName = Trim$(sHostName)
   lpHost = gethostbyname(sHostName)
    
   If lpHost = 0 Then
      GetIPAddress = ""
      MsgBox "Windows套接字不响应，获取主机名失败！"
      SocketsCleanup
      Exit Function
   End If
    
  '为展开返回的IP地址，此处，将HOST结构及其数据复制到变量中
  
   CopyMemory HOST, lpHost, Len(HOST)
   CopyMemory dwIPAddr, HOST.hAddrList, 4
   
  '重定义保存结果数据的数组
   ReDim tmpIPAddr(1 To HOST.hLen)
   CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
   
  '由结果数组建立实际的IP地址
   For i = 1 To HOST.hLen
      sIPAddr = sIPAddr & tmpIPAddr(i) & "."
   Next
  
  '删除字符串最后的点字符
   GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
   
   SocketsCleanup
    
End Function


Public Function GetIPHostName() As String

    Dim sHostName As String * 256
    
    If Not SocketsInitialize() Then
        GetIPHostName = ""
        Exit Function
    End If
    
    If gethostname(sHostName, 256) = SOCKET_ERROR Then
        GetIPHostName = ""
        MsgBox "发生了Windows套接字错误：" & Str$(WSAGetLastError()) & _
                "，不能成功获取主机名。"
        SocketsCleanup
        Exit Function
    End If
    
    GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
    SocketsCleanup

End Function


Public Function HiByte(ByVal wParam As Integer) As Byte
  
  '注意：VB4-32的用户应声明这个函数为Integer
   HiByte = (wParam And &HFF00&) \ (&H100)
 
End Function


Public Function LoByte(ByVal wParam As Integer) As Byte

  '注意：VB4-32的用户应声明这个函数为Integer
   LoByte = wParam And &HFF&

End Function


Public Sub SocketsCleanup()

    If WSACleanup() <> ERROR_SUCCESS Then
        MsgBox "终止套接字时发生错误"
    End If
    
End Sub

Public Function SocketsInitialize() As Boolean

   Dim WSAD As WSADATA
   Dim sLoByte As String
   Dim sHiByte As String
   
   If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
      MsgBox "32-bit Windows套接字无响应"
      SocketsInitialize = False
      Exit Function
   End If
   
   
   If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        MsgBox "程序要求最少要有" & CStr(MIN_SOCKETS_REQD) & "个套接字"
        
        SocketsInitialize = False
        Exit Function
    End If
   
   
   If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
     (LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
      HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
      
      sHiByte = CStr(HiByte(WSAD.wVersion))
      sLoByte = CStr(LoByte(WSAD.wVersion))
      
      MsgBox "32-bit Windows Sockets不支持" & sLoByte & "." & sHiByte & "版本的套接字"
      
      SocketsInitialize = False
      Exit Function
      
   End If
    
    
   SocketsInitialize = True
        
End Function