module1.bas

电子书“Visual Basic 6 网络编程实例教程.rar”

Attribute VB_Name = "Module1"
Option Explicit

Public Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Public Const MAX_ADAPTER_NAME As Long = 128
Public Const MAX_ADAPTER_NAME_LENGTH As Long = 256
Public Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Public Const MAX_HOSTNAME_LEN As Long = 128
Public Const MAX_DOMAIN_NAME_LEN As Long = 128
Public Const MAX_SCOPE_ID_LEN As Long = 256

Public Const ERROR_BUFFER_OVERFLOW As Long = 111
Public Const ERROR_INSUFFICIENT_BUFFER As Long = 122
Public Const GMEM_FIXED As Long = &H0

Public Const LB_SETTABSTOPS As Long = &H192

Public Const IP_SUCCESS As Long = 0
Public Const ERROR_SUCCESS As Long = 0

Private Const MAX_WSADescription As Long = 256
Private Const MAX_WSASYSStatus As Long = 128
Private Const WS_VERSION_REQD As Long = &H101

Private 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

Private Type IP_ADDRESS_STRING
    IpAddr(0 To 15)  As Byte
End Type

Private Type IP_MASK_STRING
    IpMask(0 To 15)  As Byte
End Type

Private Type IP_ADDR_STRING
    dwNext     As Long
    IpAddress  As IP_ADDRESS_STRING
    IpMask     As IP_MASK_STRING
    dwContext  As Long
End Type

Public Type IP_ADAPTER_INFO
  dwNext                As Long
  ComboIndex            As Long  '保留
  sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3))        As Byte
  sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
  dwAddressLength       As Long
  sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1))       As Byte
  dwIndex               As Long
  uType                 As Long
  uDhcpEnabled          As Long
  CurrentIpAddress      As Long
  IpAddressList         As IP_ADDR_STRING
  GatewayList           As IP_ADDR_STRING
  DhcpServer            As IP_ADDR_STRING
  bHaveWins             As Long
  PrimaryWinsServer     As IP_ADDR_STRING
  SecondaryWinsServer   As IP_ADDR_STRING
  LeaseObtained         As Long
  LeaseExpires          As Long
End Type

Private Type IP_ADAPTER_INDEX_MAP
   Index As Long
   AdapterName(0 To MAX_ADAPTER_NAME - 1) As Integer
End Type

Private Type IP_INTERFACE_INFO
   NumAdapters As Long
   Adapter As IP_ADAPTER_INDEX_MAP
End Type

Public Declare Function GetAdaptersInfo Lib "IPHlpApi" _
   (IpAdapterInfo As Any, _
   pOutBufLen As Long) As Long
   
Private Declare Function GetInterfaceInfo Lib "IPHlpApi" _
  (ByVal pIfTable As Long, _
   dwOutBufLen As Long) As Long

Private Declare Function IPReleaseAddress Lib "IPHlpApi" _
   Alias "IpReleaseAddress" _
  (AdapterInfo As IP_ADAPTER_INDEX_MAP) As Long

Private Declare Function IPRenewAddress Lib "IPHlpApi" _
   Alias "IpRenewAddress" _
  (AdapterInfo As IP_ADAPTER_INDEX_MAP) As Long

Private Declare Function GlobalAlloc Lib "kernel32" _
  (ByVal wFlags As Long, _
   ByVal dwBytes As Long) As Long

Private Declare Function GlobalFree Lib "kernel32" _
  (ByVal hMem As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" _
   Alias "RtlMoveMemory" _
  (Destination As Any, _
   Source As Any, _
   ByVal Length As Long)

Public Declare Function WSAStartup Lib "ws2_32.DLL" _
  (ByVal wVR As Long, _
   lpWSAD As WSADATA) As Long

Public Declare Function WSACleanup Lib "ws2_32.DLL" () As Long

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

Public Function SocketsInitialize() As Boolean
   Dim WSAD As WSADATA
   SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = IP_SUCCESS
End Function

Public Sub SocketsCleanup()
   If WSACleanup() <> 0 Then
       MsgBox "终止Windows套接字时出错！", vbExclamation
   End If
End Sub

Public Function IPRelease(ByVal dwAdapterIndex As Long) As Boolean
   Dim bufptr        As Long
   Dim dwOutBufLen   As Long
   Dim ip_map        As IP_ADAPTER_INDEX_MAP
   Dim success       As Long
   Dim nStructSize   As Long
   Dim NumAdapters   As Long
   Dim cnt           As Long
  '用0长度的缓存来调用函数GetInterfaceInfo，以获取实际需要的缓存大小
   success = GetInterfaceInfo(0, dwOutBufLen)
   If success <> 0 And _
      success = ERROR_INSUFFICIENT_BUFFER Then
     '分配缓存空间，重新调用函数。
      bufptr = GlobalAlloc(GMEM_FIXED, dwOutBufLen)
      success = GetInterfaceInfo(bufptr, dwOutBufLen)
      If success = ERROR_SUCCESS Then
        '返回的数据的前4个字节给出了网卡的信息
         CopyMemory NumAdapters, ByVal bufptr, 4
        'ip_map结构的大小
         nStructSize = LenB(ip_map)
        '如果系统中安装了网卡
         If NumAdapters > 0 Then
           '循环，处理所有安装了的网卡
            For cnt = 0 To NumAdapters - 1
              '将缓存中的数据复制到ip_map结构中，在子调用中，
              '返回的缓存数据的偏移量＝网卡的read *ip_map的大小。
              '再在该偏移量的基础上，取出表示网卡信息的前4个字节。
               CopyMemory ip_map, _
                          ByVal bufptr + (nStructSize * cnt) + 4, _
                          nStructSize
              '将网卡索引号与传递过来的参数值进行比较
               If ip_map.Index = dwAdapterIndex Then
                 '如果API函数返回ERROR_SUCCESS (0)，则发布IP地址，并设置函数的返回值为True
                  IPRelease = IPReleaseAddress(ip_map) = ERROR_SUCCESS
                  If success <> ERROR_SUCCESS Then
                      MsgBox "ReleaseIP error " & success & _
                             ", Err# is " & Err.LastDllError
                  End If
               End If  'If ip_map.Index
            Next  'For cnt
         End If  'If NumAdapters
      End If  'If success = ERROR_SUCCESS
   End If  'If success <> 0
   GlobalFree bufptr
End Function

Public Function IPRenew(ByVal dwAdapterIndex As Long) As Boolean
   Dim bufptr        As Long
   Dim dwOutBufLen   As Long
   Dim ip_map        As IP_ADAPTER_INDEX_MAP
   Dim success       As Long
   Dim nStructSize   As Long
   Dim NumAdapters   As Long
   Dim cnt           As Long
  '用0长度的缓存来调用函数GetInterfaceInfo，以获取实际需要的缓存大小
   success = GetInterfaceInfo(0, dwOutBufLen)
   If success <> 0 And _
      success = ERROR_INSUFFICIENT_BUFFER Then
     '分配缓存空间，重新调用函数。
      bufptr = GlobalAlloc(GMEM_FIXED, dwOutBufLen)
      success = GetInterfaceInfo(bufptr, dwOutBufLen)
      If success = ERROR_SUCCESS Then
        '返回的数据的前4个字节给出了网卡的信息
         CopyMemory NumAdapters, ByVal bufptr, 4
        'ip_map结构的大小
         nStructSize = LenB(ip_map)
        '如果系统中安装了网卡
         If NumAdapters > 0 Then
           '循环，处理所有安装了的网卡
            For cnt = 0 To NumAdapters - 1
              '将缓存中的数据复制到ip_map结构中，在子调用中，
              '返回的缓存数据的偏移量＝网卡的read *ip_map的大小。
              '再在该偏移量的基础上，取出表示网卡信息的前4个字节。
               CopyMemory ip_map, _
                          ByVal bufptr + (nStructSize * cnt) + 4, _
                          nStructSize
              '将网卡索引号与传递过来的参数值进行比较
               If ip_map.Index = dwAdapterIndex Then
                 '如果API函数返回ERROR_SUCCESS (0)，则更新IP地址，并设置函数的返回值为True
                  IPRenew = IPRenewAddress(ip_map) = ERROR_SUCCESS
                  If success <> ERROR_SUCCESS Then
                      MsgBox "IpRenewAddress error " & success & _
                             ", Err# is " & Err.LastDllError
                  End If
               End If  'If ip_map.Index
            Next  'For cnt
         End If  'If NumAdapters
      End If  'If success = ERROR_SUCCESS
   End If  'If success <> 0
   GlobalFree bufptr
End Function