Skip to content

Instantly share code, notes, and snippets.

@lantrix
Last active March 1, 2022 18:37
Show Gist options
  • Save lantrix/4d0ad8248bb21f21c64d5a446884bb6c to your computer and use it in GitHub Desktop.
Save lantrix/4d0ad8248bb21f21c64d5a446884bb6c to your computer and use it in GitHub Desktop.
IP calculator for Excel, LibreOffice and OpenOffice.org - subnet calculator and IP address functions for your spreadsheet - http://trk.free.fr/ipcalc/
' Copyright 2010-2016 Thomas Rohmer-Kretz
' This program is free software: you can redistribute it and/or modify
' it under the terms of the GNU General Public License as published by
' the Free Software Foundation, either version 3 of the License, or
' (at your option) any later version.
' This program is distributed in the hope that it will be useful,
' but WITHOUT ANY WARRANTY; without even the implied warranty of
' MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
' GNU General Public License for more details.
' You should have received a copy of the GNU General Public License
' along with this program. If not, see <http://www.gnu.org/licenses/>.
' http://trk.free.fr/ipcalc/
' Visual Basic for Excel
'==============================================
' IP v4
'==============================================
'----------------------------------------------
' IpIsValid
'----------------------------------------------
' Returns true if an ip address is formated exactly as it should be:
' no space, no extra zero, no incorrect value
Function IpIsValid(ByVal ip As String) As Boolean
IpIsValid = (IpBinToStr(IpStrToBin(ip)) = ip)
End Function
'----------------------------------------------
' IpStrToBin
'----------------------------------------------
' Converts a text IP address to binary
' example:
' IpStrToBin("1.2.3.4") returns 16909060
Function IpStrToBin(ByVal ip As String) As Double
Dim pos As Integer
ip = ip + "."
IpStrToBin = 0
While ip <> ""
pos = InStr(ip, ".")
IpStrToBin = IpStrToBin * 256 + Val(Left(ip, pos - 1))
ip = Mid(ip, pos + 1)
Wend
End Function
'----------------------------------------------
' IpBinToStr
'----------------------------------------------
' Converts a binary IP address to text
' example:
' IpBinToStr(16909060) returns "1.2.3.4"
Function IpBinToStr(ByVal ip As Double) As String
Dim divEnt As Double
Dim i As Integer
i = 0
IpBinToStr = ""
While i < 4
If IpBinToStr <> "" Then IpBinToStr = "." + IpBinToStr
divEnt = Int(ip / 256)
IpBinToStr = Format(ip - (divEnt * 256)) + IpBinToStr
ip = divEnt
i = i + 1
Wend
End Function
'----------------------------------------------
' IpAdd
'----------------------------------------------
' example:
' IpAdd("192.168.1.1"; 4) returns "192.168.1.5"
' IpAdd("192.168.1.1"; 256) returns "192.168.2.1"
Function IpAdd(ByVal ip As String, offset As Double) As String
IpAdd = IpBinToStr(IpStrToBin(ip) + offset)
End Function
'----------------------------------------------
' IpAnd
'----------------------------------------------
' logical AND
' example:
' IpAnd("192.168.1.1"; "255.255.255.0") returns "192.168.1.0"
Function IpAnd(ByVal ip1 As String, ByVal ip2 As String) As String
' compute logical AND from right to left
Dim result As String
While ((ip1 <> "") And (ip2 <> ""))
Call IpBuild(IpParse(ip1) And IpParse(ip2), result)
Wend
IpAnd = result
End Function
'----------------------------------------------
' IpAdd2
'----------------------------------------------
' another implementation of IpAdd which not use the binary representation
Function IpAdd2(ByVal ip As String, offset As Double) As String
Dim result As String
While (ip <> "")
offset = IpBuild(IpParse(ip) + offset, result)
Wend
IpAdd2 = result
End Function
'----------------------------------------------
' IpGetByte
'----------------------------------------------
' get one byte from an ip address given its position
' example:
' IpGetByte("192.168.1.1"; 1) returns 192
Function IpGetByte(ByVal ip As String, pos As Integer) As Integer
pos = 4 - pos
For i = 0 To pos
IpGetByte = IpParse(ip)
Next
End Function
'----------------------------------------------
' IpSetByte
'----------------------------------------------
' set one byte in an ip address given its position and value
' example:
' IpSetByte("192.168.1.1"; 4; 20) returns "192.168.1.20"
Function IpSetByte(ByVal ip As String, pos As Integer, newvalue As Integer) As String
Dim result As String
Dim byteval As Double
i = 4
While (ip <> "")
byteval = IpParse(ip)
If (i = pos) Then byteval = newvalue
Call IpBuild(byteval, result)
i = i - 1
Wend
IpSetByte = result
End Function
'----------------------------------------------
' IpMask
'----------------------------------------------
' returns an IP netmask from a subnet
' both notations are accepted
' example:
' IpMask("192.168.1.1/24") returns "255.255.255.0"
' IpMask("192.168.1.1 255.255.255.0") returns "255.255.255.0"
Function IpMask(ByVal ip As String) As String
IpMask = IpBinToStr(IpMaskBin(ip))
End Function
'----------------------------------------------
' IpWildMask
'----------------------------------------------
' returns an IP Wildcard (inverse) mask from a subnet
' both notations are accepted
' example:
' IpWildMask("192.168.1.1/24") returns "0.0.0.255"
' IpWildMask("192.168.1.1 255.255.255.0") returns "0.0.0.255"
Function IpWildMask(ByVal ip As String) As String
IpWildMask = IpBinToStr(((2 ^ 32) - 1) - IpMaskBin(ip))
End Function
'----------------------------------------------
' IpInvertMask
'----------------------------------------------
' returns an IP Wildcard (inverse) mask from a subnet mask
' or a subnet mask from a wildcard mask
' example:
' IpWildMask("255.255.255.0") returns "0.0.0.255"
' IpWildMask("0.0.0.255") returns "255.255.255.0"
Function IpInvertMask(ByVal mask As String) As String
IpInvertMask = IpBinToStr(((2 ^ 32) - 1) - IpStrToBin(mask))
End Function
'----------------------------------------------
' IpMaskLen
'----------------------------------------------
' returns prefix length from a mask given by a string notation (xx.xx.xx.xx)
' example:
' IpMaskLen("255.255.255.0") returns 24 which is the number of bits of the subnetwork prefix
Function IpMaskLen(ByVal ipmaskstr As String) As Integer
Dim notMask As Double
notMask = 2 ^ 32 - 1 - IpStrToBin(ipmaskstr)
zeroBits = 0
Do While notMask <> 0
notMask = Int(notMask / 2)
zeroBits = zeroBits + 1
Loop
IpMaskLen = 32 - zeroBits
End Function
'----------------------------------------------
' IpWithoutMask
'----------------------------------------------
' removes the netmask notation at the end of the IP
' example:
' IpWithoutMask("192.168.1.1/24") returns "192.168.1.1"
' IpWithoutMask("192.168.1.1 255.255.255.0") returns "192.168.1.1"
Function IpWithoutMask(ByVal ip As String) As String
Dim p As Integer
p = InStr(ip, "/")
If (p = 0) Then
p = InStr(ip, " ")
End If
If (p = 0) Then
IpWithoutMask = ip
Else
IpWithoutMask = Left(ip, p - 1)
End If
End Function
'----------------------------------------------
' IpSubnetLen
'----------------------------------------------
' get the mask len from a subnet
' example:
' IpSubnetLen("192.168.1.1/24") returns 24
' IpSubnetLen("192.168.1.1 255.255.255.0") returns 24
Function IpSubnetLen(ByVal ip As String) As Integer
Dim p As Integer
p = InStr(ip, "/")
If (p = 0) Then
p = InStr(ip, " ")
If (p = 0) Then
IpSubnetLen = 32
Else
IpSubnetLen = IpMaskLen(Mid(ip, p + 1))
End If
Else
IpSubnetLen = Val(Mid(ip, p + 1))
End If
End Function
'----------------------------------------------
' IpIsInSubnet
'----------------------------------------------
' returns TRUE if "ip" is in "subnet"
' subnet must have the / mask notation (xx.xx.xx.xx/yy)
' example:
' IpIsInSubnet("192.168.1.35"; "192.168.1.32/29") returns TRUE
' IpIsInSubnet("192.168.1.35"; "192.168.1.32 255.255.255.248") returns TRUE
' IpIsInSubnet("192.168.1.41"; "192.168.1.32/29") returns FALSE
Function IpIsInSubnet(ByVal ip As String, ByVal subnet As String) As Boolean
'IpIsInSubnet = (IpAnd(ip, IpMask(subnet)) = IpWithoutMask(subnet))
' the following line also works with non standard subnet notation:
IpIsInSubnet = (IpAnd(ip, IpMask(subnet)) = (IpAnd(IpWithoutMask(subnet), IpMask(subnet))))
End Function
'----------------------------------------------
' IpSubnetVLookup
'----------------------------------------------
' tries to match an IP address against a list of subnets in the left-most
' column of table_array and returns the value in the same row based on the
' index_number
' this function selects the smallest matching subnet
' 'ip' is the value to search for in the subnets in the first column of
' the table_array
' 'table_array' is one or more columns of data
' 'index_number' is the column number in table_array from which the matching
' value must be returned. The first column which contains subnets is 1.
' note: add the subnet 0.0.0.0/0 at the end of the array if you want the
' function to return a default value
Function IpSubnetVLookup(ByVal ip As String, table_array As Range, index_number As Integer) As String
Dim previousMatch As String
previousMatch = "0.0.0.0/0"
IpSubnetVLookup = "Not Found"
For i = 1 To table_array.Rows.Count
Dim subnet As String
subnet = table_array.Cells(i, 1)
If IpIsInSubnet(ip, subnet) And (IpSubnetLen(subnet) > IpSubnetLen(previousMatch)) Then
previousMatch = subnet
IpSubnetVLookup = table_array.Cells(i, index_number)
End If
Next i
End Function
'----------------------------------------------
' IpSubnetMatch
'----------------------------------------------
' tries to match an IP address against a list of subnets in the left-most
' column of table_array and returns the row number
' this function selects the smallest matching subnet
' 'ip' is the value to search for in the subnets in the first column of
' the table_array
' 'table_array' is one or more columns of data
' returns 0 if the IP address is not matched.
Function IpSubnetMatch(ByVal ip As String, table_array As Range) As Integer
Dim previousMatch As String
previousMatch = "0.0.0.0/0"
IpSubnetMatch = 0
For i = 1 To table_array.Rows.Count
Dim subnet As String
subnet = table_array.Cells(i, 1)
If IpIsInSubnet(ip, subnet) And (IpSubnetLen(subnet) > IpSubnetLen(previousMatch)) Then
previousMatch = subnet
IpSubnetMatch = i
End If
Next i
End Function
'----------------------------------------------
' IpSubnetIsInSubnet
'----------------------------------------------
' returns TRUE if "subnet1" is in "subnet2"
' subnets must have the / mask notation (xx.xx.xx.xx/yy)
' example:
' IpSubnetIsInSubnet("192.168.1.35/30"; "192.168.1.32/29") returns TRUE
' IpSubnetIsInSubnet("192.168.1.41/30"; "192.168.1.32/29") returns FALSE
' IpSubnetIsInSubnet("192.168.1.35/28"; "192.168.1.32/29") returns FALSE
Function IpSubnetIsInSubnet(ByVal subnet1 As String, ByVal subnet2 As String) As Boolean
Dim Mask1 As Double
Dim Mask2 As Double
Mask1 = IpMaskBin(subnet1)
Mask2 = IpMaskBin(subnet2)
If (Mask1 < Mask2) Then
IpSubnetIsInSubnet = False
ElseIf IpIsInSubnet(IpWithoutMask(subnet1), subnet2) Then
IpSubnetIsInSubnet = True
Else
IpSubnetIsInSubnet = False
End If
End Function
'----------------------------------------------
' IpSubnetSize
'----------------------------------------------
' returns the number of addresses in a subnet
' example:
' IpSubnetSize("192.168.1.32/29") returns 8
' IpSubnetSize("192.168.1.0 255.255.255.0") returns 256
Function IpSubnetSize(ByVal subnet As String) As Double
IpSubnetSize = 2 ^ (32 - IpSubnetLen(subnet))
End Function
'----------------------------------------------
' IpSubnetInSubnetVLookup
'----------------------------------------------
' tries to match a subnet against a list of subnets in the left-most
' column of table_array and returns the value in the same row based on the
' index_number
' the value matches if 'subnet' is equal or included in one of the subnets
' in the array
' 'subnet' is the value to search for in the subnets in the first column of
' the table_array
' 'table_array' is one or more columns of data
' 'index_number' is the column number in table_array from which the matching
' value must be returned. The first column which contains subnets is 1.
' note: add the subnet 0.0.0.0/0 at the end of the array if you want the
' function to return a default value
Function IpSubnetInSubnetVLookup(ByVal subnet As String, table_array As Range, index_number As Integer) As String
IpSubnetInSubnetVLookup = "Not Found"
For i = 1 To table_array.Rows.Count
If IpSubnetIsInSubnet(subnet, table_array.Cells(i, 1)) Then
IpSubnetInSubnetVLookup = table_array.Cells(i, index_number)
Exit For
End If
Next i
End Function
'----------------------------------------------
' IpSubnetInSubnetMatch
'----------------------------------------------
' tries to match a subnet against a list of subnets in the left-most
' column of table_array and returns the row number
' the value matches if 'subnet' is equal or included in one of the subnets
' in the array
' 'subnet' is the value to search for in the subnets in the first column of
' the table_array
' 'table_array' is one or more columns of data
' returns 0 if the subnet is not included in any of the subnets from the list
Function IpSubnetInSubnetMatch(ByVal subnet As String, table_array As Range) As Integer
IpSubnetInSubnetMatch = 0
For i = 1 To table_array.Rows.Count
If IpSubnetIsInSubnet(subnet, table_array.Cells(i, 1)) Then
IpSubnetInSubnetMatch = i
Exit For
End If
Next i
End Function
'----------------------------------------------
' IpFindOverlappingSubnets
'----------------------------------------------
' this function must be used in an array formula
' it will find in the list of subnets which subnets overlap
' 'SubnetsArray' is single column array containing a list of subnets, the
' list may be sorted or not
' the return value is also a array of the same size
' if the subnet on line x is included in a larger subnet from another line,
' this function returns an array in which line x contains the value of the
' larger subnet
' if the subnet on line x is distinct from any other subnet in the array,
' then this function returns on line x an empty cell
' if there are no overlapping subnets in the input array, the returned array
' is empty
Function IpFindOverlappingSubnets(subnets_array As Range) As Variant
Dim result_array() As Variant
ReDim result_array(1 To subnets_array.Rows.Count, 1 To 1)
For i = 1 To subnets_array.Rows.Count
result_array(i, 1) = ""
For j = 1 To subnets_array.Rows.Count
If (i <> j) And IpSubnetIsInSubnet(subnets_array.Cells(i, 1), subnets_array.Cells(j, 1)) Then
result_array(i, 1) = subnets_array.Cells(j, 1)
Exit For
End If
Next j
Next i
IpFindOverlappingSubnets = result_array
End Function
'----------------------------------------------
' IpSortArray
'----------------------------------------------
' this function must be used in an array formula
' 'ip_array' is a single column array containing ip addresses
' the return value is also a array of the same size containing the same
' addresses sorted in ascending or descending order
' 'descending' is an optional parameter, if set to True the adresses are
' sorted in descending order
Function IpSortArray(ip_array As Range, Optional descending As Boolean = False) As Variant
Dim s As Integer
Dim t As Integer
t = 0
s = ip_array.Rows.Count
Dim list() As Double
ReDim list(1 To s)
' copy the IP list as binary values
For i = 1 To s
If (ip_array.Cells(i, 1) <> 0) Then
t = t + 1
list(t) = IpStrToBin(ip_array.Cells(i, 1))
End If
Next i
' sort the list with bubble sort
For i = t - 1 To 1 Step -1
For j = 1 To i
If ((list(j) > list(j + 1)) Xor descending) Then
Dim swap As Double
swap = list(j)
list(j) = list(j + 1)
list(j + 1) = swap
End If
Next j
Next i
' copy the sorted list as strings
Dim resultArray() As Variant
ReDim resultArray(1 To s, 1 To 1)
For i = 1 To t
resultArray(i, 1) = IpBinToStr(list(i))
Next i
IpSortArray = resultArray
End Function
'----------------------------------------------
' IpSubnetSortArray
'----------------------------------------------
' this function must be used in an array formula
' 'ip_array' is a single column array containing ip subnets in prefix/len
' notation
' the return value is also an array of the same size containing the same
' subnets sorted in ascending or descending order
' 'descending' is an optional parameter, if set to True the subnets are
' sorted in descending order
Function IpSubnetSortArray(ip_array As Range, Optional descending As Boolean = False) As Variant
Dim s As Integer
Dim t As Integer
t = 0
s = ip_array.Rows.Count
Dim list() As String
ReDim list(1 To s)
' copy the IP list as binary values
For i = 1 To s
If (ip_array.Cells(i, 1) <> 0) Then
t = t + 1
list(t) = ip_array.Cells(i, 1)
End If
Next i
' sort the list with bubble sort
For i = t - 1 To 1 Step -1
For j = 1 To i
Dim m, n As Double
m = IpStrToBin(list(j))
n = IpStrToBin(list(j + 1))
If (((m > n) Or ((m = n) And (IpMaskBin(list(j)) < IpMaskBin(list(j + 1))))) Xor descending) Then
Dim swap As String
swap = list(j)
list(j) = list(j + 1)
list(j + 1) = swap
End If
Next j
Next i
' copy the sorted list as strings
Dim resultArray() As Variant
ReDim resultArray(1 To s, 1 To 1)
For i = 1 To t
resultArray(i, 1) = list(i)
Next i
IpSubnetSortArray = resultArray
End Function
'----------------------------------------------
' IpParseRoute
'----------------------------------------------
' this function is used by IpSubnetSortJoinArray to extract the subnet
' and next hop in route
' the supported formats are
' 10.0.0.0 255.255.255.0 1.2.3.4
' 10.0.0.0/24 1.2.3.4
' the next hop can be any character sequence, and not only an IP
Function IpParseRoute(ByVal route As String, ByRef nexthop As String)
slash = InStr(route, "/")
sp = InStr(route, " ")
If ((slash = 0) And (sp > 0)) Then
temp = Mid(route, sp + 1)
sp = InStr(sp + 1, route, " ")
End If
If (sp = 0) Then
IpParseRoute = route
nexthop = ""
Else
IpParseRoute = Left(route, sp - 1)
nexthop = Mid(route, sp + 1)
End If
End Function
'----------------------------------------------
' IpSubnetSortJoinArray
'----------------------------------------------
' this fuction car sort and summarize subnets or ip routes
' it must be used in an array formula
' 'ip_array' is a single column array containing ip subnets in prefix/len
' notation
' the return value is also an array of the same size containing the same
' subnets sorted in ascending order
' any consecutive subnets of the same size will be summarized when it is
' possible
' each line may contain any character sequence after the subnet, such as
' a next hop or any parameter of an ip route
' in this case, only subnets with the same parameters will be summarized
Function IpSubnetSortJoinArray(ip_array As Range) As Variant
Dim s As Integer
Dim t As Integer
Dim a As String
Dim b As String
Dim nexthop1 As String
Dim nexthop2 As String
t = 0
s = ip_array.Rows.Count
Dim list() As String
ReDim list(1 To s)
' copy the IP list as binary values
For i = 1 To s
If (ip_array.Cells(i, 1) <> 0) Then
t = t + 1
list(t) = ip_array.Cells(i, 1)
End If
Next i
' sort the list with bubble sort
For i = t - 1 To 1 Step -1
For j = 1 To i
Dim m, n As Double
a = IpParseRoute(list(j), nexthop1)
b = IpParseRoute(list(j + 1), nexthop2)
m = IpStrToBin(IpWithoutMask(a))
n = IpStrToBin(IpWithoutMask(b))
If ((m > n) Or ((m = n) And (IpMaskBin(a) < IpMaskBin(b)))) Then
Dim swap As String
swap = list(j)
list(j) = list(j + 1)
list(j + 1) = swap
End If
Next j
Next i
' try to join subnets
i = 1
While (i < t)
remove_next = False
a = IpParseRoute(list(i), nexthop1)
b = IpParseRoute(list(i + 1), nexthop2)
If (IpSubnetIsInSubnet(a, b) And (nexthop1 = nexthop2)) Then
list(i) = list(i + 1)
remove_next = True
ElseIf (IpSubnetIsInSubnet(b, a) And (nexthop1 = nexthop2)) Then
remove_next = True
ElseIf ((IpSubnetLen(a) = IpSubnetLen(b)) And (nexthop1 = nexthop2)) Then
' create a subnet with the same notation
bigsubnet = Replace(IpWithoutMask(a) + "/" + Str(IpSubnetLen(a) - 1), " ", "")
If (InStr(a, "/") = 0) Then
bigsubnet = IpWithoutMask(a) & " " & IpMask(bigsubnet)
Else
End If
If (IpSubnetIsInSubnet(b, bigsubnet)) Then
' OK these subnets can be joined
list(i) = bigsubnet & " " & nexthop1
remove_next = True
End If
End If
If (remove_next) Then
' remove list(i+1) and make the list one element shorter
For j = i + 1 To t - 1
list(j) = list(j + 1)
Next j
t = t - 1
' step back and try again because list(i) may be joined with list(i-1)
If (i > 1) Then i = i - 1
Else
i = i + 1
End If
Wend
' copy the sorted list as strings
Dim resultArray() As Variant
ReDim resultArray(1 To s, 1 To 1)
For i = 1 To t
resultArray(i, 1) = list(i)
Next i
IpSubnetSortJoinArray = resultArray
End Function
'----------------------------------------------
' IpIsPrivate
'----------------------------------------------
' returns TRUE if "ip" is in one of the private IP address ranges
' example:
' IpIsPrivate("192.168.1.35") returns TRUE
' IpIsPrivate("209.85.148.104") returns FALSE
Function IpIsPrivate(ByVal ip As String) As Boolean
IpIsPrivate = (IpIsInSubnet(ip, "10.0.0.0/8") Or IpIsInSubnet(ip, "172.16.0.0/12") Or IpIsInSubnet(ip, "192.168.0.0/16"))
End Function
'----------------------------------------------
' IpDiff
'----------------------------------------------
' difference between 2 IP addresses
' example:
' IpDiff("192.168.1.7"; "192.168.1.1") returns 6
Function IpDiff(ByVal ip1 As String, ByVal ip2 As String) As Double
Dim mult As Double
mult = 1
IpDiff = 0
While ((ip1 <> "") Or (ip2 <> ""))
IpDiff = IpDiff + mult * (IpParse(ip1) - IpParse(ip2))
mult = mult * 256
Wend
End Function
'----------------------------------------------
' IpParse
'----------------------------------------------
' Parses an IP address by iteration from right to left
' Removes one byte from the right of "ip" and returns it as an integer
' example:
' if ip="192.168.1.32"
' IpParse(ip) returns 32 and ip="192.168.1" when the function returns
Function IpParse(ByRef ip As String) As Integer
Dim pos As Integer
pos = InStrRev(ip, ".")
If pos = 0 Then
IpParse = Val(ip)
ip = ""
Else
IpParse = Val(Mid(ip, pos + 1))
ip = Left(ip, pos - 1)
End If
End Function
'----------------------------------------------
' IpBuild
'----------------------------------------------
' Builds an IP address by iteration from right to left
' Adds "ip_byte" to the left the "ip"
' If "ip_byte" is greater than 255, only the lower 8 bits are added to "ip"
' and the remaining bits are returned to be used on the next IpBuild call
' example 1:
' if ip="168.1.1"
' IpBuild(192, ip) returns 0 and ip="192.168.1.1"
' example 2:
' if ip="1"
' IpBuild(258, ip) returns 1 and ip="2.1"
Function IpBuild(ip_byte As Double, ByRef ip As String) As Double
If ip <> "" Then ip = "." + ip
ip = Format(ip_byte And 255) + ip
IpBuild = ip_byte \ 256
End Function
'----------------------------------------------
' IpMaskBin
'----------------------------------------------
' returns binary IP mask from an address with / notation (xx.xx.xx.xx/yy)
' example:
' IpMask("192.168.1.1/24") returns 4294967040 which is the binary
' representation of "255.255.255.0"
Function IpMaskBin(ByVal ip As String) As Double
Dim bits As Integer
bits = IpSubnetLen(ip)
IpMaskBin = (2 ^ bits - 1) * 2 ^ (32 - bits)
End Function
'==============================================
' IP v6
'==============================================
'----------------------------------------------
' Ipv6MaskLen
'----------------------------------------------
' returns prefix length from an IPv6 net
' example:
' Ipv6MaskLen("2001:db8:1f89::/48") returns 48
Function Ipv6MaskLen(ByVal CIDRNet As String) As Integer
slash = InStr(CIDRNet, "/")
If (slash = 0) Then
Ipv6MaskLen = 128
Else
Ipv6MaskLen = Val(Mid(CIDRNet, slash + 1))
End If
End Function
'----------------------------------------------
' Ipv6WithoutMask
'----------------------------------------------
' removes the /xx netmask notation at the end of the IP
' example:
' Ipv6WithoutMask("2001:db8:1f89::/48") returns "2001:db8:1f89::"
Function Ipv6WithoutMask(ByVal CIDRNet As String) As String
slash = InStr(CIDRNet, "/")
If (slash = 0) Then
Ipv6WithoutMask = CIDRNet
Else
Ipv6WithoutMask = Left(CIDRNet, slash - 1)
End If
End Function
'----------------------------------------------
' Ipv6IsInSubnet
'----------------------------------------------
' returns TRUE if "ip" is in "subnet"
' example:
' Ipv6IsInSubnet("2001:db8:1:::ac1f:1"; "2001:db8:1::/48") returns TRUE
' Ipv6IsInSubnet("2001:db8:2:::ac1f:1"; "2001:db8:1::/48") returns FALSE
Function Ipv6IsInSubnet(ByVal ip As String, ByVal subnet As String) As Variant
prefixlen = Ipv6MaskLen(subnet)
subnet = Ipv6ToBin(subnet)
ip = Ipv6ToBin(ip)
If (Left(subnet, prefixlen) = Left(ip, prefixlen)) Then
Ipv6IsInSubnet = True
Else
Ipv6IsInSubnet = False
End If
End Function
'----------------------------------------------
' Ipv6AddMissingColumns
'----------------------------------------------
' this function is called from Ipv6Expand and replaces the :: by the
' right amount of :
' examples:
' Ipv6AddMissingColumns(1:2:3::8) returns "1:2:3:::::8"
' Ipv6AddMissingColumns(1:2:3:4:5::8) returns "1:2:3:4:5:::8"
' Ipv6AddMissingColumns(1:2:3::) returns "1:2:3:::::"
Function Ipv6AddMissingColumns(ByVal ip As String) As Variant
d = 0 ' number of double columns
c = 0 ' number of columns
For i = 1 To Len(ip)
If (Mid(ip, i, 2) = "::") Then d = d + 1
If (Mid(ip, i, 1) = ":") Then c = c + 1
Next
If ((d = 0) And (c = 7)) Then
' 7 single columns, nothing to do
ip2 = ip
ElseIf (d = 1) Then
' one double columns, replace with the right number of columns
ip2 = Replace(ip, "::", Left("::::::::", 9 - c))
Else
' any other cas is an error
Ipv6AddMissingColumns = CVErr(xlErrValue)
Exit Function
End If
Ipv6AddMissingColumns = ip2
End Function
'----------------------------------------------
' Ipv6Expand
'----------------------------------------------
' returns a representation of an IPv6 address with all the missing zeros
' the result has a fixed lenght of 39 caracters
' example :
' Ipv6Expand("1:2:3::8") returns "0001:0002:0003:0000:0000:0000:0000:0008"
Function Ipv6Expand(ByVal ip As String) As Variant
ip = "0" & Ipv6AddMissingColumns(Ipv6WithoutMask(ip))
While (ip <> "")
ip2 = Ipv6Parse(ip) & ip2
If (ip <> "") Then
ip2 = ":" & ip2
End If
Wend
Ipv6Expand = ip2
End Function
'----------------------------------------------
' Ipv6Compress
'----------------------------------------------
' returns the shortest representation of an IPv6 address
' examples:
' Ipv6Compress("0001:0002:0003:0000:0000:0000:0000:0008") returns "1:2:3::8"
' Ipv6Compress("01:0:0::") returns "1::"
Function Ipv6Compress(ByVal ip As String) As String
Dim ip2 As String, ip3 As String, ip4 As String
' start with the expanded representation of ip
ip2 = Ipv6Expand(ip)
' rebuild ip, this will remove zeros at the begining of each hex block
' if a block is null, this will keep one zero
While (ip2 <> "")
offset = Ipv6Build(Ipv6ParseInt(ip2), ip3)
Wend
' try to replace the longuest sequence of zero blocks by ::
s = ":0:0:0:0:0:0:"
For i = Len(s) To 3 Step -2
ip4 = Replace(ip3, Left(s, i), "::", 1, 1)
If (ip3 <> ip4) Then Exit For
Next
' remove first 0 if ip starts with 0::
If (Left(ip4, 3) = "0::") Then ip4 = Mid(ip4, 2)
' remove last 0 if ip ends with ::0
If (Right(ip4, 3) = "::0") Then ip4 = Left(ip4, Len(ip4) - 1)
Ipv6Compress = ip4
End Function
'----------------------------------------------
' Ipv6ToBin
'----------------------------------------------
' returns a string representing the binary value of IPv6 address
' the result has a fixed lenght of 128 characters
Function Ipv6ToBin(ByVal ip As String) As Variant
Dim result As String
ip2 = Replace(Ipv6Expand(ip), ":", "")
For i = 1 To Len(ip2)
b = "0000"
j = 0
v = Val("&H" & Mid$(ip2, i, 1))
While v > 0
Mid$(b, 4 - j, 1) = v Mod 2
v = v \ 2
j = j + 1
Wend
result = result & b
Next
Ipv6ToBin = result
End Function
'----------------------------------------------
' Ipv6FromBin
'----------------------------------------------
' returns an IPv6 from a string representing the binary value of IPv6 address
' the parameter must be a 128 character string
Function Ipv6FromBin(ByVal ipbin As String) As Variant
Dim result As String
Dim pos As Integer
pos = 1
If Len(ipbin) <> 128 Then
Ipv6FromBin = ""
Exit Function
End If
For bloc = 1 To 8
Dim v As Double
v = 0
For bit = 1 To 16
v = v * 2 + Val(Mid(ipbin, pos, 1))
pos = pos + 1
Next
result = result + LCase(Hex(v))
If (bloc < 8) Then result = result + ":"
Next
Ipv6FromBin = Ipv6Compress(result)
End Function
'----------------------------------------------
' Ipv6Parse
'----------------------------------------------
' Parses an IPv6 address by iteration from right to left
' Removes a 16-bit value from the right of "ip" and returns it as 4 character
' long hex value
' Important: This function does not expand the :: if there is any
' example:
' if ip="1:2:3:4:5:6:7:8"
' IpParse(ip) returns "0008" and ip="1:2:3:4:5:6:7" when the function returns
Function Ipv6Parse(ByRef ip As String) As String
Dim pos As Integer
pos = InStrRev(ip, ":")
If pos = 0 Then
v = ip
ip = ""
Else
v = Mid(ip, pos + 1)
ip = Left(ip, pos - 1)
End If
Ipv6Parse = Right("0000" & v, 4)
End Function
'----------------------------------------------
' Ipv6ParseInt
'----------------------------------------------
' Same as Ipv6Parse but returns a Double instead of String
Function Ipv6ParseInt(ByRef ip As String) As Double
Dim v As Double
strHex = Ipv6Parse(ip)
For i = 1 To Len(strHex)
v = 16 * v + Val("&H" & Mid$(strHex, i, 1))
Next
Ipv6ParseInt = v
End Function
'----------------------------------------------
' Ipv6Build
'----------------------------------------------
' Builds an IP address by iteration from right to left
' Adds "v16bits" to the left the "ip"
' If "v16bits" is greater than 65535 (= FFFF), only the lower 16 bits are
' added to "ip" and the remaining bits are returned to be used on the next
' IpBuild call
Function Ipv6Build(v16bits As Double, ByRef ip As String) As Double
If ip <> "" Then ip = ":" + ip
ip = LCase(Hex(v16bits And 65535)) + ip
Ipv6Build = v16bits \ 65536
End Function
'----------------------------------------------
' Ipv6AddInt
'----------------------------------------------
' Add a value to an IPv6 address
' example:
' Ipv6AddInt("1::2"; 16) returns "1:12"
Function Ipv6AddInt(ByVal ip As String, offset As Double) As String
Dim result As String
ip = Ipv6Expand(ip)
While (ip <> "")
offset = Ipv6Build(Ipv6ParseInt(ip) + offset, result)
Wend
Ipv6AddInt = Ipv6Compress(result)
End Function
'----------------------------------------------
' Ipv6Add
'----------------------------------------------
' Add two IPv6 addresses
' example:
' Ipv6Add("1:2::"; "::3") returns "1:2::3"
' Ipv6Add("1:2::2"; "::3") returns "1:2::5"
Function Ipv6Add(ByVal ip1 As String, ByVal ip2 As String) As String
Dim result As String
Dim offset As Double
ip1 = Ipv6Expand(ip1)
ip2 = Ipv6Expand(ip2)
While ((ip1 <> "") And (ip2 <> ""))
offset = Ipv6Build(Ipv6ParseInt(ip1) + Ipv6ParseInt(ip2) + offset, result)
Wend
Ipv6Add = Ipv6Compress(result)
End Function
'----------------------------------------------
' Ipv6GetBlock
'----------------------------------------------
' Returns the 4-digit hexa block at position blockNbr
' The value of blockNbr can be 1 to 8, block 1 is the block on the left.
' example:
' Ipv6GetBlock("2001:db8:1f89:c5a3::ac1f:8001"; 2) returns "0db8"
Function Ipv6GetBlock(ByVal ip As String, blockNbr As Integer) As String
Ipv6GetBlock = Mid(Ipv6Expand(ip), blockNbr * 5 - 4, 4)
End Function
'----------------------------------------------
' Ipv6GetBlockInt
'----------------------------------------------
' Same as above except that the returned value is an integer between
' 0 and 65535
Function Ipv6GetBlockInt(ByVal ip As String, blockNbr As Integer) As Double
Ipv6GetBlockInt = Hex2Bin(Ipv6GetBlock(ip, blockNbr))
End Function
'----------------------------------------------
' Ipv6SetBlock
'----------------------------------------------
' Sets the value of the 4-digit hexa block at position blockNbr
' The value of blockNbr can be 1 to 8, block 1 is the block on the left.
' example:
' Ipv6SetBlock("2001::"; 2; "db8") returns "2001:0db8::"
Function Ipv6SetBlock(ByVal ip As String, blockNbr As Integer, ByVal valHex As String) As String
' make valHex exactly 4 characters long
valHex = Right("0000" & valHex, 4)
ip = Ipv6Expand(ip)
Mid(ip, blockNbr * 5 - 4, 4) = valHex
Ipv6SetBlock = Ipv6Compress(ip)
End Function
'----------------------------------------------
' Ipv6SetBlockInt
'----------------------------------------------
' Same as above except that the block value is passed as an integer between
' 0 and 65535
Function Ipv6SetBlockInt(ByVal ip As String, blockNbr As Integer, valInt As Double) As String
Dim valHex As String
valHex = LCase(Hex(valInt And 65535))
Ipv6SetBlockInt = Ipv6SetBlock(ip, blockNbr, valHex)
End Function
'----------------------------------------------
' Ipv6SetBits
'----------------------------------------------
' Sets on or more bits in a ip v6 addresse
' bits is a string with on or more "0" and "1"
' offset is the position of the first bit to set between 1 to 128 from left to right
Function Ipv6SetBits(ByVal ip As String, bits As String, offset As Integer) As String
Dim ipbin As String
ipbin = Ipv6ToBin(ip) ' convert to binary
Mid(ipbin, offset) = bits ' set the bits
ipbin = Left(ipbin, 128) ' make sure we do not exceed 128 bits
Ipv6SetBits = Ipv6FromBin(ipbin)
End Function
'----------------------------------------------
' Ipv6GetIpv4
'----------------------------------------------
' Get the value of an IPv4 in an IPv6 at a given position
' exemple:
' Ipv6GetIpv4("2001:c0a8:102::"; 2) returns "192.168.1.2"
Function Ipv6GetIpv4(ByVal ipv6 As String, blockNbr As Integer) As String
Ipv6GetIpv4 = IpBinToStr(Ipv6GetBlockInt(ipv6, blockNbr) * 65536 + Ipv6GetBlockInt(ipv6, blockNbr + 1))
End Function
'----------------------------------------------
' Ipv6SetIpv4
'----------------------------------------------
' Put the value of an IPv4 in an IPv6 at a given position
' exemple:
' Ipv6SetIpv4("2001::"; 2; "192.168.1.2") returns "2001:c0a8:102::"
Function Ipv6SetIpv4(ByVal ipv6 As String, blockNbr As Integer, ByVal ipv4 As String) As String
Dim result As String
byte1 = IpParse(ipv4)
byte2 = IpParse(ipv4)
byte3 = IpParse(ipv4)
byte4 = IpParse(ipv4)
result = Ipv6SetBlockInt(ipv6, blockNbr + 1, byte1 + 256 * byte2)
Ipv6SetIpv4 = Ipv6SetBlockInt(result, blockNbr, byte3 + 256 * byte4)
End Function
'----------------------------------------------
' Ipv6SubnetFirstAddress
'----------------------------------------------
' example:
' Ipv6SubnetFirstAddress("2001:db8:1:1a0::/59") returns "2001:db8:1:1a0::"
Function Ipv6SubnetFirstAddress(ByVal subnet As String) As Variant
prefixlen = Ipv6MaskLen(subnet)
Ipv6SubnetFirstAddress = Ipv6SetBits(subnet, String(128 - prefixlen, "0"), prefixlen + 1)
End Function
'----------------------------------------------
' Ipv6SubnetLastAddress
'----------------------------------------------
' example:
' Ipv6SubnetLastAddress("2001:db8:1:1a0::/59") returns "2001:db8:1:1bf:ffff:ffff:ffff:ffff"
Function Ipv6SubnetLastAddress(ByVal subnet As String) As Variant
prefixlen = Ipv6MaskLen(subnet)
Ipv6SubnetLastAddress = Ipv6SetBits(subnet, String(128 - prefixlen, "1"), prefixlen + 1)
End Function
Function Hex2Bin(ByVal strHex As String) As Double
Dim v As Double
For i = 1 To Len(strHex)
v = 16 * v + Val("&H" & Mid$(strHex, i, 1))
Next
Hex2Bin = v
End Function
@asdmin
Copy link

asdmin commented Apr 25, 2017

Thanks, this one helps me tremendously.

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment