netapi.bas

此文档为VB公共模块

    ErrInfo = WNetAddConnection2(NetR, "", "", CONNECT_UPDATE_PROFILE)
    
    MapDrive = (ErrInfo = NO_ERROR)
End Function

'******************
'断开网络驱动器
'******************
Public Function DisMapDrive(ByVal DrvName As String) As Boolean
  
  Dim ErrInfo As Long
  Dim strLocalName As String
  
  strLocalName = DrvName
  ErrInfo = WNetCancelConnection2(strLocalName, CONNECT_UPDATE_PROFILE, False)
    
  DisMapDrive = (ErrInfo = NO_ERROR)
End Function

'******************
'得到本机的IP地址
'******************
Public Function GetCptIP(ByVal cHostName$) As String
   If Not SocketsInitialize Then
     GetCptIP = ""
     Exit Function
   End If
   Dim hostent_addr As Long
   Dim host As HOSTENT
   Dim hostip_addr As Long
   Dim temp_ip_address() As Byte
   Dim i As Integer
   Dim ip_address As String
   
   hostent_addr = gethostbyname(cHostName)
   
   If hostent_addr = 0 Then
      Debug.Print "can not get current computer's name"
      GetCptIP = ""
      Exit Function
   End If
   
   RtlMoveMemory host, hostent_addr, LenB(host)
   RtlMoveMemory hostip_addr, host.hAddrList, 4
   
   ReDim temp_ip_address(1 To host.hLength)
   RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
   
   For i = 1 To host.hLength
      ip_address = ip_address & temp_ip_address(i) & "."
   Next
   ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
   GetCptIP = Trim$(ip_address)
   SocketsCleanup
End Function

Private Function HiByte(ByVal wParam As Integer)
   HiByte = wParam \ &H100 And &HFF&
End Function

Private Function lobyte(ByVal wParam As Integer)
   lobyte = wParam And &HFF&
End Function

Private Function SocketsInitialize() As Boolean
   Dim WSAD As WSADATA
   Dim iReturn As Integer
   Dim sLowByte As String, sHighByte As String, sMsg As String
   
   iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
   
   If iReturn <> 0 Then
      Debug.Print "Winsock.dll is not responding."
      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
      sHighByte = Trim$(Str$(HiByte(WSAD.wversion)))
      sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
      Debug.Print "Windows Sockets version " & sLowByte & "." & sHighByte
      sMsg = sMsg & " is not supported by winsock.dll "
      Debug.Print sMsg
      SocketsInitialize = False
      Exit Function
   End If
   
   If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
      sMsg = "This application requires a minimum of "
      sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
      Debug.Print sMsg
      SocketsInitialize = False
      Exit Function
   End If
  SocketsInitialize = True
End Function

Private Function SocketsCleanup() As Boolean
   Dim lReturn As Long
   
   lReturn = WSACleanup()
   
   If lReturn <> 0 Then
      Debug.Print "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
      SocketsCleanup = False
      Exit Function
   End If
   SocketsCleanup = True
End Function

Public Function GetEtherNetInfo(ByVal nitp_InfoType As NetInfoTypeX, Optional ByVal str_IPAddress As String) As String
    'Emnu ethernet Adapters
    Dim str_Adapters() As String, int_I As Integer
    str_Adapters = EnumKey(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002BE10318}")
    For int_I = 0 To UBound(str_Adapters)
        If ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002BE10318}\" & str_Adapters(int_I) & "\Ndi\Interfaces", "LowerRange") <> "ethernet" Then
            str_Adapters(int_I) = ""
        End If
    Next
    'Emnu each ethernet adapter's IP , DefaultGateway ,SubNetMask ,DhcpServer and NameServer
    Dim str_IP() As String, str_NetCfgInstanceID As String, int_SelIndex As Integer
    ReDim str_IP(UBound(str_Adapters), 5) As String
    For int_I = 0 To UBound(str_Adapters)
        If str_Adapters(int_I) <> "" Then
            str_NetCfgInstanceID = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002BE10318}\" & str_Adapters(int_I), "NetCfgInstanceId")
            str_IP(int_I, 0) = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "IPAddress")
            str_IP(int_I, 1) = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "DefaultGateway")
            str_IP(int_I, 2) = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "SubnetMask")
            str_IP(int_I, 3) = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "DhcpServer")
            str_IP(int_I, 4) = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "NameServer")
            str_IP(int_I, 5) = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "EnableDHCP")
        End If
    Next
    
    'Choose the adapter's information it have the same ip address with parameter str_ipaddress.
    int_SelIndex = -1
    If str_IPAddress = "" Then
        For int_I = 0 To UBound(str_Adapters)
            If str_Adapters(int_I) <> "" Then
                int_SelIndex = int_I
                Exit For
            End If
        Next
    Else
        For int_I = 0 To UBound(str_Adapters)
            If str_Adapters(int_I) <> "" Then
                If str_IP(int_I, 0) = str_IPAddress Then
                    int_SelIndex = int_I
                    Exit For
                End If
            End If
        Next
        
        If int_SelIndex = -1 Then
            For int_I = 0 To UBound(str_Adapters)
                If str_Adapters(int_I) <> "" Then
                    int_SelIndex = int_I
                    Exit For
                End If
            Next
        End If
    End If
    
    'return the appointed ethernet information
    If int_SelIndex = -1 Then
        GetEtherNetInfo = ""
        Exit Function
    Else
        GetEtherNetInfo = str_IP(int_SelIndex, nitp_InfoType)
    End If
End Function
'返回当前所在的工作组
Public Function GetWorkGroup() As String
    On Error Resume Next
    GetWorkGroup = Split(ReadValue(HKEY_CURRENT_USER, "Software\Microsoft\Windows\CurrentVersion\Explorer", "Last Domain"), ",", -1, vbTextCompare)(2)
End Function

Public Function ChangeNetInfo(ByRef NIF_Netinfo As NetInfo, Optional ByVal NetCardIndex As Integer) As Boolean
    '(1)修改注册表
    'Emnu ethernet Adapters
    Dim str_Adapters() As String, int_I As Integer
    str_Adapters = EnumKey(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002BE10318}")
    For int_I = 0 To UBound(str_Adapters)
        If ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002BE10318}\" & str_Adapters(int_I) & "\Ndi\Interfaces", "LowerRange") <> "ethernet" Then
            str_Adapters(int_I) = ""
        End If
    Next
    '选择指定编号的网卡,0表示为系统的第一个ethernet card
    Dim str_NetCfgInstanceID As String, int_SelIndex As Integer
    int_SelIndex = -1
    For int_I = 0 To UBound(str_Adapters)
        If str_Adapters(int_I) <> "" And Val(str_Adapters(int_I)) = NetCardIndex - 1 Then
            int_SelIndex = int_I
            Exit For
        End If
    Next
    
    If int_SelIndex = -1 And NetCardIndex = 0 Then
        For int_I = 0 To UBound(str_Adapters)
            If str_Adapters(int_I) <> "" Then
                int_SelIndex = int_I
                Exit For
            End If
        Next
    End If
    '更改选定的网卡注册表信息
    If int_SelIndex <> -1 Then
        str_NetCfgInstanceID = ReadValue(HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E972-E325-11CE-BFC1-08002BE10318}\" & str_Adapters(int_SelIndex), "NetCfgInstanceId")
        WriteReg HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "IPAddress", NIF_Netinfo.IP, REG_MULTI_SZ
        WriteReg HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "DefaultGateway", NIF_Netinfo.NetGate, REG_MULTI_SZ
        WriteReg HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "SubnetMask", NIF_Netinfo.SubMask, REG_MULTI_SZ
        WriteReg HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "DhcpServer", NIF_Netinfo.DHCPServer, REG_SZ
        WriteReg HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "NameServer", NIF_Netinfo.DNS, REG_SZ
        WriteReg HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\Interfaces\" & str_NetCfgInstanceID, "EnableDHCP", IIf(NIF_Netinfo.EnableDhcp, Chr(1) & String(3, Chr(0)), String(4, Chr(0))), REG_DWORD
        SetComputerName NIF_Netinfo.Name
    Else
        ChangeNetInfo = False
        Exit Function
    End If
    '(2)通知系统IP改变,调用函数
    ChangeNetInfo = DhcpNotifyConfigChange(vbNullString, StrPtr(str_NetCfgInstanceID), 1, 0, ConvertStrIPToLong(NIF_Netinfo.IP), ConvertStrIPToLong(NIF_Netinfo.SubMask), 0) = 0
End Function
'将IP字符串转换成对应的IP值
Public Function ConvertStrIPToLong(ByVal str_IP As String) As Long
    Dim str_arr_IP() As String, str_Result As String, str_tmp As Variant
    str_arr_IP = Split(str_IP, ".", -1, vbTextCompare)
    
    For Each str_tmp In str_arr_IP
        str_Result = IIf(Len(Hex(Val(str_tmp))) = 2, Hex(Val(str_tmp)), "0" & Hex(Val(str_tmp))) & str_Result
    Next
    ConvertStrIPToLong = Val("&H" & str_Result)
End Function