Attribute VB_Name = "Network"
'
' Für einen automatischen Start dieser Excel-Vorlage wird diese nach
' C:\Users\%UserName%\AppData\Roaming\Microsoft\Excel\XLSTART\book.xltm kopiert
'

Public Function NetworkCalculate(strFirstIP As String, strCalcIP As String, booFormat As Boolean) As String
    Dim arrFirstIP() As String
    Dim arrCalcIP() As String
    Dim intIP1 As Integer, intIP2 As Integer, intIP3 As Integer, intIP4 As Integer
    Dim strRet As String
    
    arrFirstIP = Split(strFirstIP, ".")
    arrCalcIP = Split(strCalcIP, ".")
    intIP1 = Int(arrFirstIP(0)) + Int(arrCalcIP(0))
    If Left(strCalcIP, 1) <> "-" Then
        intIP2 = Int(arrFirstIP(1)) + Int(arrCalcIP(1))
        intIP3 = Int(arrFirstIP(2)) + Int(arrCalcIP(2))
        intIP4 = Int(arrFirstIP(3)) + Int(arrCalcIP(3))
        
        Do While intIP4 > 255
            intIP4 = intIP4 - 256
            intIP3 = intIP3 + 1
        Loop
        Do While intIP3 > 255
            intIP3 = intIP3 - 256
            intIP2 = intIP2 + 1
        Loop
        Do While intIP2 > 255
            intIP2 = intIP2 - 256
            intIP1 = intIP1 + 1
        Loop
    Else
        intIP2 = Int(arrFirstIP(1)) - Int(arrCalcIP(1))
        intIP3 = Int(arrFirstIP(2)) - Int(arrCalcIP(2))
        intIP4 = Int(arrFirstIP(3)) - Int(arrCalcIP(3))
        
        Do While intIP4 < 0
            intIP4 = intIP4 + 256
            intIP3 = intIP3 - 1
        Loop
        Do While intIP3 < 0
            intIP3 = intIP3 + 256
            intIP2 = intIP2 - 1
        Loop
        Do While intIP2 < 0
            intIP2 = intIP2 + 256
            intIP1 = intIP1 - 1
        Loop
    End If
    
    If intIP1 > 255 Or intIP1 < 0 Then
        strRet = "Error in Calculation"
    Else
        If booFormat = False Then
            strRet = intIP1 & "." & intIP2 & "." & intIP3 & "." & intIP4
        Else
            strRet = ""
            For i = 1 To (3 - Len(Format(intIP1)))
                strRet = strRet & "0"
            Next
            strRet = strRet & intIP1 & "."
            For i = 1 To (3 - Len(Format(intIP2)))
                strRet = strRet & "0"
            Next
            strRet = strRet & intIP2 & "."
            For i = 1 To (3 - Len(Format(intIP3)))
                strRet = strRet & "0"
            Next
            strRet = strRet & intIP3 & "."
            For i = 1 To (3 - Len(Format(intIP4)))
                strRet = strRet & "0"
            Next
            strRet = strRet & intIP4
        End If
    End If
    NetworkCalculate = strRet
End Function

Public Function NetworkSubnetMaskToBits(Mask As String) As Integer
    Dim MaskParts() As String
    Dim Bits As Integer
    Bits = 0
    
    MaskParts = Split(Mask, ".", , vbBinaryCompare)
    If UBound(MaskParts) <> 3 Then
        SubnetMaskToBits = "SubnetMask Error xxx.xxx.xxx.xxx"
        Exit Function
    End If
    
    For i = 0 To 3
        MaskParts(i) = Application.WorksheetFunction.Dec2Bin(MaskParts(i))
        MaskParts(i) = Replace(MaskParts(i), "0", "")
        Bits = Bits + Len(MaskParts(i))
    Next
    
    NetworkSubnetMaskToBits = Bits
End Function

Public Function NetworkSubnetAddress(IPAddress As String, Bits As Integer) As String
    Dim IPOctet1BIN As String
    Dim IPOctet2BIN As String
    Dim IPOctet3BIN As String
    Dim IPOctet4BIN As String
        
    IPAddressParts = Split(IPAddress, ".", , vbBinaryCompare)
    
    If UBound(IPAddressParts) <> 3 Then
        SubnetAddress = "IPAddress Error xxx.xxx.xxx.xxx"
        Exit Function
    End If
    
     
    BuildBIN = ""
    For iCounter = 1 To 32
        If iCounter <= Bits Then
            BuildBIN = BuildBIN & "1"
        Else
            BuildBIN = BuildBIN & "0"
        End If
    Next
    MaskOctet1BIN = Mid(BuildBIN, 1, 8)
    MaskOctet2BIN = Mid(BuildBIN, 9, 8)
    MaskOctet3BIN = Mid(BuildBIN, 17, 8)
    MaskOctet4BIN = Mid(BuildBIN, 25, 8)

    On Error Resume Next
    IPOctet1BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(0), 8)
    If Bits <= 8 Then
        IPOctet2BIN = "00000000"
    End If
    IPOctet2BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(1), 8)
    If Bits <= 16 Then
        IPOctet3BIN = "00000000"
    End If
    IPOctet3BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(2), 8)
    IPOctet4BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(3), 8)
    On Error GoTo 0

    IPNetwork1BIN = ""
    IPNetwork2BIN = ""
    IPNetwork3BIN = ""
    IPNetwork4BIN = ""

    
    For iCounter = 1 To 8
        If IPOctet1BIN <> "" Then
            If Mid(MaskOctet1BIN, iCounter, 1) And Mid(IPOctet1BIN, iCounter, 1) Then
                IPNetwork1BIN = IPNetwork1BIN & "1"
            Else
                IPNetwork1BIN = IPNetwork1BIN & "0"
            End If
        End If
        
        If IPOctet2BIN <> "" Then
            If Mid(MaskOctet2BIN, iCounter, 1) And Mid(IPOctet2BIN, iCounter, 1) Then
                IPNetwork2BIN = IPNetwork2BIN & "1"
            Else
                IPNetwork2BIN = IPNetwork2BIN & "0"
            End If
        End If
        
        If IPOctet3BIN <> "" Then
            If Mid(MaskOctet3BIN, iCounter, 1) And Mid(IPOctet3BIN, iCounter, 1) Then
                IPNetwork3BIN = IPNetwork3BIN & "1"
            Else
                IPNetwork3BIN = IPNetwork3BIN & "0"
            End If
        End If
        
        If Mid(MaskOctet4BIN, iCounter, 1) And Mid(IPOctet4BIN, iCounter, 1) Then
            IPNetwork4BIN = IPNetwork4BIN & "1"
        Else
            IPNetwork4BIN = IPNetwork4BIN & "0"
        End If

    Next
    
    If IPNetwork1BIN <> "" Then
        MaskOctet1 = Application.WorksheetFunction.Bin2Dec(IPNetwork1BIN)
    Else
        MaskOctet1 = IPAddressParts(0)
    End If
    If IPNetwork2BIN <> "" Then
        MaskOctet2 = Application.WorksheetFunction.Bin2Dec(IPNetwork2BIN)
    Else
        MaskOctet2 = IPAddressParts(1)
    End If
    If IPNetwork3BIN <> "" Then
        MaskOctet3 = Application.WorksheetFunction.Bin2Dec(IPNetwork3BIN)
    Else
        MaskOctet3 = IPAddressParts(2)
    End If
    MaskOctet4 = Application.WorksheetFunction.Bin2Dec(IPNetwork4BIN)

    NetworkSubnetAddress = MaskOctet1 & "." & MaskOctet2 & "." & MaskOctet3 & "." & MaskOctet4
End Function

Public Function NetworkBroadCastAddress(IPAddress As String, Bits As Integer) As String
    Dim IPOctet1BIN As String
    Dim IPOctet2BIN As String
    Dim IPOctet3BIN As String
    Dim IPOctet4BIN As String
    
    IPAddressParts = Split(IPAddress, ".", , vbBinaryCompare)
    If UBound(IPAddressParts) <> 3 Then
        BroadCastAddress = "IPAddress Error xxx.xxx.xxx.xxx"
        Exit Function
    End If
    
    BuildBIN = ""
    For iCounter = 1 To 32
        If iCounter <= Bits Then
            BuildBIN = BuildBIN & "1"
        Else
            BuildBIN = BuildBIN & "0"
        End If
    Next
    MaskOctet1BIN = Mid(BuildBIN, 1, 8)
    MaskOctet2BIN = Mid(BuildBIN, 9, 8)
    MaskOctet3BIN = Mid(BuildBIN, 17, 8)
    MaskOctet4BIN = Mid(BuildBIN, 25, 8)
    
    On Error Resume Next
    IPOctet1BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(0), 8)
    If Bits <= 8 Then
        IPOctet2BIN = "00000000"
    End If
    IPOctet2BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(1), 8)
    If Bits <= 16 Then
        IPOctet3BIN = "00000000"
    End If
    IPOctet3BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(2), 8)
    IPOctet4BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(3), 8)
    On Error GoTo 0

'Create Full IP as Binary

    IPFullBIN = IPOctet1BIN & IPOctet2BIN & IPOctet3BIN & IPOctet4BIN

    BuildBIN1 = ""
    BuildBIN2 = ""
    BuildBIN3 = ""
    BuildBIN4 = ""
    If IPOctet1BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits Then
                BuildBIN1 = BuildBIN1 & Mid(IPOctet1BIN, iCounter, 1)
            Else
                BuildBIN1 = BuildBIN1 & "1"
            End If
        Next
    End If
    If IPOctet2BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits - 8 Then
                BuildBIN2 = BuildBIN2 & Mid(IPOctet2BIN, iCounter, 1)
            Else
                BuildBIN2 = BuildBIN2 & "1"
            End If
        Next
    End If
    If IPOctet3BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits - 16 Then
                BuildBIN3 = BuildBIN3 & Mid(IPOctet3BIN, iCounter, 1)
            Else
                BuildBIN3 = BuildBIN3 & "1"
            End If
        Next
    End If
    If IPOctet4BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits - 24 Then
                BuildBIN4 = BuildBIN4 & Mid(IPOctet4BIN, iCounter, 1)
            Else
                BuildBIN4 = BuildBIN4 & "1"
            End If
        Next
    End If
    
    If BuildBIN1 <> "" Then
        MaskOctet1 = Application.WorksheetFunction.Bin2Dec(BuildBIN1)
    Else
        MaskOctet1 = IPAddressParts(0)
    End If
    If BuildBIN2 <> "" Then
        MaskOctet2 = Application.WorksheetFunction.Bin2Dec(BuildBIN2)
    Else
        MaskOctet2 = IPAddressParts(1)
    End If
    If BuildBIN3 <> "" Then
        MaskOctet3 = Application.WorksheetFunction.Bin2Dec(BuildBIN3)
    Else
        MaskOctet3 = IPAddressParts(2)
    End If
    If BuildBIN4 <> "" Then
        MaskOctet4 = Application.WorksheetFunction.Bin2Dec(BuildBIN4)
    Else
        MaskOctet4 = IPAddressParts(3)
    End If

    NetworkBroadCastAddress = MaskOctet1 & "." & MaskOctet2 & "." & MaskOctet3 & "." & MaskOctet4
End Function

Public Function NetworkClientLowestAddress(IPAddress As String, Bits As Integer) As String
    Dim IPOctet1BIN As String
    Dim IPOctet2BIN As String
    Dim IPOctet3BIN As String
    Dim IPOctet4BIN As String
    
    IPAddressParts = Split(IPAddress, ".", , vbBinaryCompare)
    If UBound(IPAddressParts) <> 3 Then
        BroadCastAddress = "IPAddress Error xxx.xxx.xxx.xxx"
        Exit Function
    End If
    
    BuildBIN = ""
    For iCounter = 1 To 32
        If iCounter <= Bits Then
            BuildBIN = BuildBIN & "1"
        Else
            BuildBIN = BuildBIN & "0"
        End If
    Next
    MaskOctet1BIN = Mid(BuildBIN, 1, 8)
    MaskOctet2BIN = Mid(BuildBIN, 9, 8)
    MaskOctet3BIN = Mid(BuildBIN, 17, 8)
    MaskOctet4BIN = Mid(BuildBIN, 25, 8)

    On Error Resume Next
    IPOctet1BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(0), 8)
    If Bits <= 8 Then
        IPOctet2BIN = "00000000"
    End If
    IPOctet2BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(1), 8)
    If Bits <= 16 Then
        IPOctet3BIN = "00000000"
    End If
    IPOctet3BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(2), 8)
    IPOctet4BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(3), 8)
    On Error GoTo 0

    IPNetwork1BIN = ""
    IPNetwork2BIN = ""
    IPNetwork3BIN = ""
    IPNetwork4BIN = ""

    For iCounter = 1 To 8
        If IPOctet1BIN <> "" Then
            If Mid(MaskOctet1BIN, iCounter, 1) And Mid(IPOctet1BIN, iCounter, 1) Then
                IPNetwork1BIN = IPNetwork1BIN & "1"
            Else
                IPNetwork1BIN = IPNetwork1BIN & "0"
            End If
        End If
        If IPOctet2BIN <> "" Then
            If Mid(MaskOctet2BIN, iCounter, 1) And Mid(IPOctet2BIN, iCounter, 1) Then
                IPNetwork2BIN = IPNetwork2BIN & "1"
            Else
                IPNetwork2BIN = IPNetwork2BIN & "0"
            End If
        End If
        If IPOctet3BIN <> "" Then
            If Mid(MaskOctet3BIN, iCounter, 1) And Mid(IPOctet3BIN, iCounter, 1) Then
                IPNetwork3BIN = IPNetwork3BIN & "1"
            Else
                IPNetwork3BIN = IPNetwork3BIN & "0"
            End If
        End If

        If Mid(MaskOctet4BIN, iCounter, 1) And Mid(IPOctet4BIN, iCounter, 1) Then
            IPNetwork4BIN = IPNetwork4BIN & "1"
        Else
            If iCounter = 8 Then
                IPNetwork4BIN = IPNetwork4BIN & "1"
            Else
                IPNetwork4BIN = IPNetwork4BIN & "0"
            End If
        End If
    Next

    If IPNetwork1BIN <> "" Then
        MaskOctet1 = Application.WorksheetFunction.Bin2Dec(IPNetwork1BIN)
    Else
        MaskOctet1 = IPAddressParts(0)
    End If
    If IPNetwork2BIN <> "" Then
        MaskOctet2 = Application.WorksheetFunction.Bin2Dec(IPNetwork2BIN)
    Else
        MaskOctet2 = IPAddressParts(1)
    End If
    If IPNetwork3BIN <> "" Then
        MaskOctet3 = Application.WorksheetFunction.Bin2Dec(IPNetwork3BIN)
    Else
        MaskOctet3 = IPAddressParts(2)
    End If
    MaskOctet4 = Application.WorksheetFunction.Bin2Dec(IPNetwork4BIN)

    NetworkClientLowestAddress = MaskOctet1 & "." & MaskOctet2 & "." & MaskOctet3 & "." & MaskOctet4
End Function

Public Function NetworkClientHighestAddress(IPAddress As String, Bits As Integer) As String
    Dim IPOctet1BIN As String
    Dim IPOctet2BIN As String
    Dim IPOctet3BIN As String
    Dim IPOctet4BIN As String
    
    IPAddressParts = Split(IPAddress, ".", , vbBinaryCompare)
    If UBound(IPAddressParts) <> 3 Then
        BroadCastAddress = "IPAddress Error xxx.xxx.xxx.xxx"
        Exit Function
    End If
    
    BuildBIN = ""
    For iCounter = 1 To 32
        If iCounter <= Bits Then
            BuildBIN = BuildBIN & "1"
        Else
            BuildBIN = BuildBIN & "0"
        End If
    Next
    MaskOctet1BIN = Mid(BuildBIN, 1, 8)
    MaskOctet2BIN = Mid(BuildBIN, 9, 8)
    MaskOctet3BIN = Mid(BuildBIN, 17, 8)
    MaskOctet4BIN = Mid(BuildBIN, 25, 8)

    On Error Resume Next
    IPOctet1BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(0), 8)
    If Bits <= 8 Then
        IPOctet2BIN = "00000000"
    End If
    IPOctet2BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(1), 8)
    If Bits <= 16 Then
        IPOctet3BIN = "00000000"
    End If
    IPOctet3BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(2), 8)
    IPOctet4BIN = Application.WorksheetFunction.Dec2Bin(IPAddressParts(3), 8)
    On Error GoTo 0

    IPFullBIN = IPOctet1BIN & IPOctet2BIN & IPOctet3BIN & IPOctet4BIN

    BuildBIN1 = ""
    BuildBIN2 = ""
    BuildBIN3 = ""
    BuildBIN4 = ""

    If IPOctet1BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits Then
                BuildBIN1 = BuildBIN1 & Mid(IPOctet1BIN, iCounter, 1)
            Else
                BuildBIN1 = BuildBIN1 & "1"
            End If
        Next
    End If
    If IPOctet2BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits - 8 Then
                BuildBIN2 = BuildBIN2 & Mid(IPOctet2BIN, iCounter, 1)
            Else
                BuildBIN2 = BuildBIN2 & "1"
            End If
        Next
    End If
    If IPOctet3BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits - 16 Then
                BuildBIN3 = BuildBIN3 & Mid(IPOctet3BIN, iCounter, 1)
            Else
                BuildBIN3 = BuildBIN3 & "1"
            End If
        Next
    End If
    If IPOctet4BIN <> "" Then
        For iCounter = 1 To 8
            If iCounter <= Bits - 24 Then
                BuildBIN4 = BuildBIN4 & Mid(IPOctet4BIN, iCounter, 1)
            Else
                If iCounter = 8 Then
                    BuildBIN4 = BuildBIN4 & "0"
                Else
                    BuildBIN4 = BuildBIN4 & "1"
                End If
            End If
        Next
    End If
    
    If IPOctet1BIN <> "" Then
        MaskOctet1 = Application.WorksheetFunction.Bin2Dec(BuildBIN1)
    Else
        If Bits < 8 Then
            MaskOctet1 = "?"
        Else
            MaskOctet1 = IPAddressParts(0)
        End If
    End If
    If IPOctet2BIN <> "" Then
        MaskOctet2 = Application.WorksheetFunction.Bin2Dec(BuildBIN2)
    Else
        If Bits < 16 Then
            MaskOctet2 = "?"
        Else
            MaskOctet2 = IPAddressParts(1)
        End If
    End If
    If IPOctet3BIN <> "" Then
        MaskOctet3 = Application.WorksheetFunction.Bin2Dec(BuildBIN3)
    Else
        If Bits < 24 Then
            MaskOctet3 = "?"
        Else
            MaskOctet3 = IPAddressParts(2)
        End If
    End If
    MaskOctet4 = Application.WorksheetFunction.Bin2Dec(BuildBIN4)

    NetworkClientHighestAddress = MaskOctet1 & "." & MaskOctet2 & "." & MaskOctet3 & "." & MaskOctet4
End Function

Public Function NetworkClientRange(IPAddress As String, Bits As Integer, Shorten As Boolean) As String
    Dim LowestAddress As String
    Dim HighestAddress As String
    
    LowestAddress = NetworkClientLowestAddress(IPAddress, Bits)
    LowestAddressParts = Split(LowestAddress, ".", , vbBinaryCompare)
    HighestAddress = NetworkClientHighestAddress(IPAddress, Bits)
    HighestAddressParts = Split(HighestAddress, ".", , vbBinaryCompare)
    If LowestAddress = "" Then
        NetworkClientRange = ""
    Else
        If Shorten = False Then
            HighestAddress = HighestAddressParts(0) & "." & HighestAddressParts(1) & "." & HighestAddressParts(2) & "." & HighestAddressParts(3)
        Else
            HighestAddress = ""
            If LowestAddressParts(0) <> HighestAddressParts(0) Then
                HighestAddress = HighestAddressParts(0)
            End If
            If LowestAddressParts(1) <> HighestAddressParts(1) Then
                HighestAddress = HighestAddress & "." & HighestAddressParts(1)
            End If
            If LowestAddressParts(2) <> HighestAddressParts(2) Then
                HighestAddress = HighestAddress & "." & HighestAddressParts(2)
            End If
            If LowestAddressParts(3) <> HighestAddressParts(3) Then
                HighestAddress = HighestAddress & "." & HighestAddressParts(3)
            End If
        End If
    
        NetworkClientRange = LowestAddress & " - " & HighestAddress
    End If
End Function

Public Function NetworkTotalHosts(Bits As Integer) As Long
    iZeroCounter = 0
    For iCounter = 1 To 32
        If iCounter > Bits Then
            iZeroCounter = iZeroCounter + 1
        End If
    Next

    NetworkTotalHosts = (2 ^ iZeroCounter) - 2
End Function

Public Function NetworkBitsToSubnetMask(Bits As Integer) As String
    If Bits < 8 Or Bits > 32 Then
        BitsToSubnetMask = "Bitmask Error : Range 8 - 32"
        Exit Function
    End If
    
    BuildBIN = ""
    For iCounter = 1 To 32
        If iCounter <= Bits Then
            BuildBIN = BuildBIN & "1"
        Else
            BuildBIN = BuildBIN & "0"
        End If
    Next
    MaskOctet1 = Application.WorksheetFunction.Bin2Dec(Mid(BuildBIN, 1, 8))
    MaskOctet2 = Application.WorksheetFunction.Bin2Dec(Mid(BuildBIN, 9, 8))
    MaskOctet3 = Application.WorksheetFunction.Bin2Dec(Mid(BuildBIN, 17, 8))
    MaskOctet4 = Application.WorksheetFunction.Bin2Dec(Mid(BuildBIN, 25, 8))
    
    NetworkBitsToSubnetMask = MaskOctet1 & "." & MaskOctet2 & "." & MaskOctet3 & "." & MaskOctet4
End Function