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 ;)
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.