Winroute, l'équivalent de la commande route avec l'api iphlpapi, en vb6

Soyez le premier à donner votre avis sur cette source.

Vue 5 671 fois - Téléchargée 475 fois

Description

Comme dit dans le titre, un petit soft pour gérer les routes Windows par une interface graphique. Un programme qui ne sert pas a grand chose, mais que j'ai fait comme base pour servir dans un autre programme dans le lequel j'avais besoin de manipuler les routes, donc le voila. Si jamais ça peut aider quelqu'un, vu que moi j'ai pas mal galéré.

Edit: Une petite maj avec une gestion plus fine, et la gestion des routes persistantes plus robuste et un code plus propre.
Edit: Encore une petite maj du tabindex et des private declare à la place de public declare.

Source / Exemple :


Attribute VB_Name = "Module1"
'WinRoute par Maxime Pierron.
'Un equivalent de la commande route de windows en VB6 par l'api iphlpapi.
'Merci à tous ceux à qui j'aurais pu "pomper" du code sur le net.
'Si vous trouvez ce code utile, vous pouvez m'envoyer un petit mail à maxime.pierron79 at free.fr, ça me fera plaisir... ;)

Option Explicit

Public Const MAX_ADAPTER_NAME_LENGTH = 260
Public Const MAX_ADAPTER_ADDRESS_LENGTH = 8
Public Const MAX_ADAPTER_DESCRIPTION_LENGTH = 132
Public Const IP_ADAPTER_INFO_LENGTH = 640
Public Const persistent = "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Tcpip\Parameters\PersistentRoutes"

Private Type MIB_IPFORWARDROW
dwForwardDest As Long ' IP addr of destination
dwForwardMask As Long ' subnetwork mask of destination
dwForwardPolicy As Long ' conditions for multi-path route
dwForwardNextHop As Long ' IP address of next hop
dwForwardIfIndex As Long ' index of interface
dwForwardType As Long ' route type
dwForwardProto As Long ' protocol that generated route
dwForwardAge As Long ' age of route
dwForwardNextHopAS As Long ' autonomous system number
dwForwardMetric1 As Long ' protocol-specific metric
dwForwardMetric2 As Long ' protocol-specific metric
dwForwardMetric3 As Long ' protocol-specific metric
dwForwardMetric4 As Long ' protocol-specific metric
dwForwardMetric5 As Long ' protocol-specific metric
End Type

Public Type IP_ADDR_STRING
Next As Long
IpAddress As String * 16
IpMask As String * 16
Context As Long
End Type

Type IP_ADAPTER_INFO
Next As Long
ComboIndex As Long
AdapterName As String * MAX_ADAPTER_NAME_LENGTH
Description As String * MAX_ADAPTER_DESCRIPTION_LENGTH
AddressLength As Long
Address(MAX_ADAPTER_ADDRESS_LENGTH - 1) As Byte
Index As Long
Type As Long
DhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
HaveWins As Byte
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End Type

Public oldroute As String
Public oldsForwardDestination As String
Public oldsForwardMask As String
Public oldsForwardNextHop As String

Private Declare Function GetAdaptersInfo Lib "iphlpapi.dll" (IpAdapterInfo As Any, pOutBufLen As Long) As Long
Private Declare Function GetIpForwardTable Lib "iphlpapi" (ByRef pIpForwardTable As Any, ByRef pdwSize As Long, ByVal bOrder As Long) As Long
Private Declare Function CreateIpForwardEntry Lib "iphlpapi.dll" (pRoute As MIB_IPFORWARDROW) As Long
Private Declare Function SetIpForwardEntry Lib "iphlpapi.dll" (pRoute As MIB_IPFORWARDROW) As Long
Private Declare Function DeleteIpForwardEntry Lib "iphlpapi.dll" (pRoute As MIB_IPFORWARDROW) As Long
Private Declare Function inet_addr Lib "wsock32.dll" (ByVal Addr As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Function RoutePrint() As String

    RoutePrint = vbNullString
    Dim i As Long, nStructSize As Long
    Dim nRows As Long, bBytes() As Byte, bufLen As Long
    Dim Row As MIB_IPFORWARDROW
    Dim retStr As String
        
    On Error GoTo err
    nStructSize = LenB(Row)
    GetIpForwardTable ByVal 0&, bufLen, 0
    If bufLen <= 0 Then Exit Function
    ReDim bBytes(0 To bufLen - 1) As Byte
    GetIpForwardTable bBytes(0), bufLen, 0
    CopyMemory nRows, bBytes(0), 4
    Form1.List1.Clear
    For i = 0 To nRows - 1
        CopyMemory Row, bBytes(4 + (i * nStructSize)), nStructSize
        'retStr = retStr & LngToAddress(Row.dwForwardDest) & vbTab & LngToAddress(Row.dwForwardMask) & vbTab & LngToAddress(Row.dwForwardNextHop) & vbTab & Row.dwForwardMetric1 & vbCrLf
        Form1.List1.AddItem LngToAddress(Row.dwForwardDest) & vbTab & LngToAddress(Row.dwForwardMask) & vbTab & LngToAddress(Row.dwForwardNextHop) & vbTab & Row.dwForwardMetric1 & vbTab & Row.dwForwardIfIndex & vbTab & Row.dwForwardType & vbTab & Row.dwForwardProto & vbTab
    Next
    
    'RoutePrint = retStr
    
    Exit Function
err:
    RoutePrint = vbNullString

End Function

'http://msdn.microsoft.com/en-us/library/aa365860%28v=vs.85%29.aspx
'http://msdn.microsoft.com/en-us/library/aa366850%28v=vs.85%29.aspx

' .dwForwardProto:
' Other = 1 'Some other protocol not specified in RFC 1354.
' Local = 2 'A local interface or ppp.
' NetMGMT = 3 'A static route. This value is used to identify route information for IP routing set through network management such as the Dynamic Host Configuration Protocol (DCHP), the Simple Network Management Protocol (SNMP), or by calls to the CreateIpForwardEntry, DeleteIpForwardEntry, or SetIpForwardEntry functions.
' ICMP = 4 'The result of ICMP redirect.
' EGP = 5 'The Exterior Gateway Protocol (EGP), a dynamic routing protocol.
' GGP = 6 'The Gateway-to-Gateway Protocol (GGP), a dynamic routing protocol.
' Hello = 7 'The Hellospeak protocol, a dynamic routing protocol. This is a historical entry no longer in use and was an early routing protocol used by the original ARPANET routers that ran special software called the Fuzzball routing protocol, sometimes called Hellospeak, as described in RFC 891 and RFC 1305. For more information, see http://www.ietf.org/rfc/rfc891.txt and http://www.ietf.org/rfc/rfc1305.txt.
' RIP = 8 'The Berkeley Routing Information Protocol (RIP) or RIP-II, a dynamic routing protocol.
' IS_IS = 9 'The Intermediate System-to-Intermediate System (IS-IS) protocol, a dynamic routing protocol. The IS-IS protocol was developed for use in the Open Systems Interconnection (OSI) protocol suite.
' ES_IS = 10 'The End System-to-Intermediate System (ES-IS) protocol, a dynamic routing protocol. The ES-IS protocol was developed for use in the Open Systems Interconnection (OSI) protocol suite.
' CISCO = 11 'The Cisco Interior Gateway Routing Protocol (IGRP), a dynamic routing protocol.
' BBN = 12 'The Bolt, Beranek, and Newman (BBN) Interior Gateway Protocol (IGP) that used the Shortest Path First (SPF) algorithm. This was an early dynamic routing protocol.
' OSPF = 13 'The Open Shortest Path First (OSPF) protocol, a dynamic routing protocol.
' BGP = 14 'The Border Gateway Protocol (BGP), a dynamic routing protocol.
' NT_AUTOSTATIC = 10002 'A Windows specific entry added originally by a routing protocol, but which is now static.
' NT_STATIC = 10006 'A Windows specific entry added as a static route from the routing user interface or a routing command.
' NT_STATIC_NON_DOD = 10007 'A Windows specific entry added as a static route from the routing user interface or a routing command, except these routes do not cause Dial On Demand (DOD).

'.dwForwardType:
'MIB_IPROUTE_TYPE_OTHER 1 Some other type not specified in RFC 1354.
'MIB_IPROUTE_TYPE_INVALID 2 An invalid route. This value can result from a route added by an ICMP redirect.
'MIB_IPROUTE_TYPE_DIRECT 3 A local route where the next hop is the final destination (a local interface).
'MIB_IPROUTE_TYPE_INDIRECT 4 The remote route where the next hop is not the final destination (a remote destination).

Public Function RouteAdd(ByVal sForwardDestination As String, ByVal sForwardMask As String, ByVal sForwardNextHop As String, ByVal sForwardMetric1 As Long, ByVal sPersistent As Boolean, ByVal sForwardType As Long, ByVal sForwardProto As Long) As Boolean

Dim IPForwardTable As MIB_IPFORWARDROW
Dim gui
Dim a

On Error Resume Next

Set gui = CreateObject("WScript.Shell")
If oldsForwardDestination = sForwardDestination And oldsForwardMask = sForwardMask And oldsForwardNextHop = sForwardNextHop Then
    a = persistent & "\" & oldroute
    gui.RegDelete a
End If
If sPersistent = True Then
    If a = gui.RegWrite(persistent & "\" & sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1, " ", "REG_SZ") Then
        MsgBox "Failed to add persistent route from registry!"
    Else
        oldroute = sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1
        oldsForwardDestination = sForwardDestination
        oldsForwardMask = sForwardMask
        oldsForwardNextHop = sForwardNextHop
    End If
End If

With IPForwardTable
    .dwForwardIfIndex = GetIfIndex(sForwardNextHop)
    .dwForwardDest = inet_addr(sForwardDestination)
    .dwForwardMask = inet_addr(sForwardMask)
    .dwForwardNextHop = inet_addr(sForwardNextHop)
    .dwForwardType = sForwardType
    .dwForwardProto = sForwardProto
    .dwForwardMetric1 = sForwardMetric1
End With

If CreateIpForwardEntry(IPForwardTable) Then MsgBox "Failed to add route!"

End Function

Public Function RouteChange(ByVal sForwardDestination As String, ByVal sForwardMask As String, ByVal sForwardNextHop As String, ByVal sForwardMetric1 As Long, ByVal sPersistent As Boolean, ByVal sForwardType As Long, ByVal sForwardProto As Long) As Boolean

Dim IPForwardTable As MIB_IPFORWARDROW
Dim gui
Dim a

On Error Resume Next

Set gui = CreateObject("WScript.Shell")
If oldsForwardDestination = sForwardDestination And oldsForwardMask = sForwardMask And oldsForwardNextHop = sForwardNextHop Then
    a = persistent & "\" & oldroute
    gui.RegDelete a
End If
If sPersistent = True Then
    If a = gui.RegWrite(persistent & "\" & sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1, " ", "REG_SZ") Then
        MsgBox "Failed to change persistent route from registry!"
    Else
        oldroute = sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1
        oldsForwardDestination = sForwardDestination
        oldsForwardMask = sForwardMask
        oldsForwardNextHop = sForwardNextHop
    End If
End If

With IPForwardTable
    .dwForwardIfIndex = GetIfIndex(sForwardNextHop)
    .dwForwardDest = inet_addr(sForwardDestination)
    .dwForwardMask = inet_addr(sForwardMask)
    .dwForwardNextHop = inet_addr(sForwardNextHop)
    .dwForwardType = sForwardType
    .dwForwardProto = sForwardProto
    .dwForwardMetric1 = sForwardMetric1
End With

If SetIpForwardEntry(IPForwardTable) Then MsgBox "Failed to change route!"

End Function

Public Function RouteDelete(ByVal sForwardDestination As String, ByVal sForwardMask As String, ByVal sForwardNextHop As String, ByVal sForwardMetric1 As Long, ByVal sPersistent As Boolean, ByVal sForwardType As Long, ByVal sForwardProto As Long) As Boolean

Dim IPForwardTable As MIB_IPFORWARDROW

Dim gui
Dim a

On Error Resume Next

If sPersistent = True Then
    Set gui = CreateObject("WScript.Shell")
    a = persistent & "\" & sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1
    gui.RegDelete a
    If a = gui.RegRead(persistent & "\" & sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1) Then
        oldroute = sForwardDestination & "," & sForwardMask & "," & sForwardNextHop & "," & sForwardMetric1
        oldsForwardDestination = sForwardDestination
        oldsForwardMask = sForwardMask
        oldsForwardNextHop = sForwardNextHop
    Else
        MsgBox "Failed to delete persistent route from registry!"
    End If
End If

With IPForwardTable
    .dwForwardIfIndex = GetIfIndex(sForwardNextHop)
    .dwForwardDest = inet_addr(sForwardDestination)
    .dwForwardMask = inet_addr(sForwardMask)
    .dwForwardNextHop = inet_addr(sForwardNextHop)
    .dwForwardType = sForwardType
    .dwForwardProto = sForwardProto
    .dwForwardMetric1 = sForwardMetric1
End With

If DeleteIpForwardEntry(IPForwardTable) Then MsgBox "Failed to delete route!"

End Function

Public Function GetIfIndex(Gateway As String) As Long

    Dim AdapterInfoSize As Long
    Dim AdapterInfo As IP_ADAPTER_INFO
    Dim AdapterInfoBuffer() As Byte
    Dim ptr1 As Long, Addr As String
    
    GetIfIndex = 0
    AdapterInfoSize = 0
    On Error GoTo err
    Call GetAdaptersInfo(ByVal 0&, AdapterInfoSize)
    ReDim AdapterInfoBuffer(AdapterInfoSize - 1)
    If 0 = GetAdaptersInfo(AdapterInfoBuffer(0), AdapterInfoSize) Then
        ptr1 = VarPtr(AdapterInfoBuffer(0))
        Do While (ptr1 <> 0)
        CopyMemory AdapterInfo, ByVal ptr1, IP_ADAPTER_INFO_LENGTH
        If InStr(AdapterInfo.GatewayList.IpAddress, Chr(0)) > 6 Then
            Addr = Left(AdapterInfo.GatewayList.IpAddress, InStr(AdapterInfo.GatewayList.IpAddress, Chr(0)) - 1)
            'If AddressToLng(Addr) = AddressToLng(Gateway) Then 'AddressToLng remplacé par inet_addr
            If inet_addr(Addr) = inet_addr(Gateway) Then
                GetIfIndex = AdapterInfo.Index
            Exit Function
            End If
        End If
        ptr1 = AdapterInfo.Next
        Loop
    End If
         Exit Function
err:
    GetIfIndex = 0

End Function

Public Function LngToAddress(Lng As Long) As String

    Dim myByte(3) As Byte, s(3) As String
    Dim i As Long
    On Error GoTo err
    CopyMemory myByte(0), Lng, 4
    For i = 0 To 3
        s(i) = CStr(myByte(i))
    Next
    LngToAddress = Join(s, ".")
    Exit Function
err:
    LngToAddress = vbNullString

End Function

'AddressToLng remplacé par inet_addr

'Public Function AddressToLng(Addr As String) As Long
'
'    AddressToLng = 0
'    Dim myLong As Long, s() As String
'    Dim i As Long
'    On Error GoTo Err
'    s = Split(Addr, ".")
'    For i = 0 To 3
'       myLong = (CInt(s(i)) Mod 256) * (256 ^ i) + myLong
'    Next
'    AddressToLng = myLong
'    Exit Function
'Err:
'    AddressToLng = 0
'
'End Function

Conclusion :


Si jamais vous trouvez ce programme utile, envoyez moi un petit mail, ça fait toujours plaisir ;)

Codes Sources

A voir également

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.