[RESOLVED] Block IP

Well what about just 10 ip ranges?

Also what is in a ip range? How many IPs could be in a single range?

10 is fine.

From 000.000.000.000 to 255.255.255.255. You do the math.

But it doesn't matter how many IP's there are in the range... it's the amount of ranges itself.

Quote:

---

Originally Posted by Doogle

Well, using Chris's code as a sort of template, I knocked up this. It will read a series of IP Addresses from a text file (c:\Blacklist.txt - One IP Address per line) and populate a ListBox (lstBlacklist). It then grabs the TCP Table and extracts all the Remote Host IP Addresses, which are refreshed every second, and puts them into lstRemote. The two lists are compared, and if anything in lstBlacklist connects, or is connected, it is disconnected and a line is written to txtAction (a multiline TextBox)

Code:

---

Option Explicit

Private Declare Function GetTcpTable Lib "iphlpapi.dll" _
                (ByRef pTcpTable As Any, _
                ByRef pdwSize As Long, _
                ByVal bOrder As Long) As Long
               
Private Declare Function SetTcpEntry Lib "iphlpapi.dll" _
                (pTcpTableEx As MIB_TCPROW) As Long
               
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                (ByRef pDest As Any, _
                ByRef pSource As Any, _
                ByVal Length As Long)

Private Declare Function RtlIpv4AddressToString Lib "ntdll.dll" Alias "RtlIpv4AddressToStringA" _
                (ByRef lngAddr As Long, ByVal strAddr As String) As Long
               
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_INSUFFICIENT_BUFFER = 122

Private Type MIB_TCPROW
    dwState As Long
    dwLocalAddr As Long
    dwLocalPort As Long
    dwRemoteAddr As Long
    dwRemotePort As Long
End Type

Private udtTCP() As MIB_TCPROW

Private Function GetIPInfo() As Boolean
Dim bytBuffer() As Byte
Dim lngSize As Long
Dim lngEntries As Long
Dim lngReturn As Long
Dim lngState As Long
Dim intI As Integer
Dim intOffSet As Integer
Dim strRemote As String
Dim strState As String
'
' Obtain the length of the TCP Table
'
lngReturn = GetTcpTable(lngSize, lngSize, 0)
If lngReturn = ERROR_INSUFFICIENT_BUFFER Then
    ReDim bytBuffer(lngSize - 1)
    '
    ' Get the TCP Table
    ' and populate the MIB_TCPROWs
    '
    lngReturn = GetTcpTable(bytBuffer(0), lngSize, 0)
    If lngReturn = 0 Then
        CopyMemory lngEntries, bytBuffer(0), 4
        ReDim udtTCP(lngEntries - 1)
        For intI = 0 To lngEntries - 1
            strRemote = Space(16)
            intOffSet = (intI * Len(udtTCP(intI))) + 4
            CopyMemory udtTCP(intI), bytBuffer(intOffSet), Len(udtTCP(intI))
            '
            ' Remote Addresses of zero are of no interest
            ' otherwise convert the address to dotted form
            ' and add it to the ListBox
            '
            If udtTCP(intI).dwRemoteAddr <> 0 Then
                lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
                lstRemote.AddItem Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
            End If
        Next intI
    Else
        MsgBox "Unable to Access TCP Table Entries"
    End If
Else
    MsgBox "Unable to Access TCP Table"
End If
End Function

Private Sub CheckIP()
Dim intI As Integer
Dim intJ As Integer
Dim lngReturn As Long
Dim strRemote As String
For intI = LBound(udtTCP) To UBound(udtTCP)
    strRemote = Space(15)
    lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
    strRemote = Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
    For intJ = 0 To lstBlacklist.ListCount - 1
        If strRemote = Trim(lstBlacklist.List(intJ)) Then
            udtTCP(intI).dwState = 12
            lngReturn = SetTcpEntry(udtTCP(intI))
            txtAction.Text = txtAction.Text & lstBlacklist.List(intJ) & _
                    " has been Disconnected at " & Format(Now, "dd/mm/yyyy hh:mm:ss") & vbCrLf
        End If
    Next intJ
Next intI
End Sub

Private Sub LoadBlacklist()
Dim intFile As Integer
Dim strLine As String
intFile = FreeFile
Open "C:\Blacklist.txt" For Input As intFile
Do Until EOF(intFile)
    Line Input #intFile, strLine
    lstBlacklist.AddItem strLine
Loop
Close intFile
End Sub

Private Sub Form_Load()
lstBlacklist.Clear
Call LoadBlacklist
Call GetIPInfo
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
lstRemote.Clear
Call GetIPInfo
Call CheckIP
End Sub

---

That might get you sarted.

---

Ok so this code has a black list of single IP's but how would it be able to block a range if it was for ex: 000.000.000 to 255.255.255.255 and lstblacklist said 000.000.000 to 255.255.255.255

Also I have this code that opens the database to load it to lslblack list

VB Code:

Private Sub Form_Load()
 
 
txtAction.Text = txtAction.Text & vbNewLine & "++----STATUS BOX----++"
'''''Main Search Result+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
 
lstBlacklist.Clear
Dim con As ADODB.Connection
Dim strSQL As String
Dim strCol As String
Set con = New ADODB.Connection
con.CursorLocation = adUseClient
con.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.path & "\DatabaseIPBlacklist.mdb;" _
    & "Jet OLEDB:Database Password=omegacron;"
strSQL = "SELECT * FROM table1"
strCol = "Field1"
Call FillCombo(lstBlacklist, con, strSQL, strCol)
con.Close
Set con = Nothing
 
 
lstBlacklist.Clear
'Call LoadBlacklist
Call GetIPInfo
Timer1.Interval = 1000
Timer1.Enabled = True
End Sub

But the prob is when the prog runs there is nothing in the lstblacklist

EDIT: I got the ranges so they go in the lstblacklist, so for ex they are like 4.42.190.0-4.42.190.7. The problem is the code looks for single IPS, how can I get it to use a net range like 4.42.190.0-4.42.190.7?

LOL I just got it to block 1000 IPs by loading them into the listbox, but I am afriad it now usess alot of CPU power all the time. Since it is suggested the blacklist file should be loaded into memory instead of a listbox, what changes would I have to make to doogles code?

Thanks!

Umm I just realized this, but when I run the program, it does not disconnect the blacklisted Ip addresses??


They remain connected, but the blacklisted Ips are loaded to lstBlacklist

Did I make a mistake?

Well, if you're using the example code I posted, this is the part which disconnects:

Code:

---

For intI = LBound(udtTCP) To UBound(udtTCP)
    strRemote = Space(15)
    lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
    strRemote = Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
    For intJ = 0 To lstBlacklist.ListCount - 1
        If strRemote = Trim(lstBlacklist.List(intJ)) Then
            udtTCP(intI).dwState = 12
            lngReturn = SetTcpEntry(udtTCP(intI))
            txtAction.Text = txtAction.Text & lstBlacklist.List(intJ) & _
                    " has been Disconnected at " & Format(Now, "dd/mm/yyyy hh:mm:ss") & vbCrLf
        End If
    Next intJ
Next intI

---

Well to test it out, I look at the IPs already connected to my Pc and put them in the black list, but none gets disconnected, as it doesn't say anything in txtaction.

VB Code:

Option Explicit
 
Private Declare Function GetTcpTable Lib "iphlpapi.dll" _
                (ByRef pTcpTable As Any, _
                 ByRef pdwSize As Long, _
                 ByVal bOrder As Long) As Long
                 
Private Declare Function SetTcpEntry Lib "iphlpapi.dll" _
                (pTcpTableEx As MIB_TCPROW) As Long
                 
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
                (ByRef pDest As Any, _
                 ByRef pSource As Any, _
                 ByVal Length As Long)
 
Private Declare Function RtlIpv4AddressToString Lib "ntdll.dll" Alias "RtlIpv4AddressToStringA" _
                (ByRef lngAddr As Long, ByVal strAddr As String) As Long
                
Private Const ERROR_SUCCESS = 0&
Private Const ERROR_INSUFFICIENT_BUFFER = 122
 
Private Type MIB_TCPROW
    dwState As Long
    dwLocalAddr As Long
    dwLocalPort As Long
    dwRemoteAddr As Long
    dwRemotePort As Long
End Type
 
Private udtTCP() As MIB_TCPROW
 
Private Function GetIPInfo() As Boolean
Dim bytBuffer() As Byte
Dim lngSize As Long
Dim lngEntries As Long
Dim lngReturn As Long
Dim lngState As Long
Dim intI As Integer
Dim intOffSet As Integer
Dim strRemote As String
Dim strState As String
'
' Obtain the length of the TCP Table
'
lngReturn = GetTcpTable(lngSize, lngSize, 0)
If lngReturn = ERROR_INSUFFICIENT_BUFFER Then
    ReDim bytBuffer(lngSize - 1)
    '
    ' Get the TCP Table
    ' and populate the MIB_TCPROWs
    '
    lngReturn = GetTcpTable(bytBuffer(0), lngSize, 0)
    If lngReturn = 0 Then
        CopyMemory lngEntries, bytBuffer(0), 4
        ReDim udtTCP(lngEntries - 1)
        For intI = 0 To lngEntries - 1
            strRemote = Space(16)
            intOffSet = (intI * Len(udtTCP(intI))) + 4
            CopyMemory udtTCP(intI), bytBuffer(intOffSet), Len(udtTCP(intI))
            '
            ' Remote Addresses of zero are of no interest
            ' otherwise convert the address to dotted form
            ' and add it to the ListBox
            '
            If udtTCP(intI).dwRemoteAddr <> 0 Then
                lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
                lstRemote.AddItem Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
                Txtconnect.Text = Txtconnect.Text & vbNewLine & Time & " - " & lstRemote.List(lstRemote.NewIndex) & "  -------- TCP Protocol" & TextName.Text
            End If
        Next intI
    Else
        MsgBox "Unable to Access TCP Table Entries"
    End If
Else
    MsgBox "Unable to Access TCP Table"
End If
End Function
 
Private Sub CheckIP()
Dim intI As Integer
Dim intJ As Integer
Dim lngReturn As Long
Dim strRemote As String * 16
For intI = LBound(udtTCP) To UBound(udtTCP)
    If udtTCP(intI).dwRemoteAddr <> 0 Then
        strRemote = Space(16)
        lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
        strRemote = Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
        For intJ = 0 To lstBlacklist.ListCount - 1
            If strRemote = Trim(lstBlacklist.List(intJ)) Then
                udtTCP(intI).dwState = 12
                lngReturn = SetTcpEntry(udtTCP(intI))
                txtAction.Text = txtAction.Text & lstBlacklist.List(intJ) & _
                    " has been Disconnected at " & Format(Now, "dd/mm/yyyy hh:mm:ss") & vbCrLf
            End If
        Next intJ
    End If
Next intI
End Sub
 
Private Sub LoadBlacklist()
Dim intFile As Integer
Dim strLine As String
intFile = FreeFile
Open App.path & "\Blacklist.txt" For Input As intFile
 
Do Until EOF(intFile)
    Line Input #intFile, strLine
    lstBlacklist.AddItem strLine
Loop
Close intFile
End Sub
 
 
 
Private Sub Form_Load()
 
Text1.Text = (Environ("SystemDrive")) & "\"
txtAction.Text = "++----STATUS BOX----++"
txtAction.Text = txtAction.Text & vbNewLine & "-- Blacklisted IP Database Loaded..."
lstBlacklist.Clear
Call LoadBlacklist
Call GetIPInfo
Timer1.Interval = 5000
Timer1.Enabled = True
Label7.Caption = "Number of IP Addresses Blocked: " & lstBlacklist.ListCount
End Sub
 
 
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Unload IPBlock
End Sub
 
Private Sub mnuAbout_Click()
About.Show
End Sub
 
Private Sub mnuclose_Click()
Unload IPBlock
End Sub
 
Private Sub mnuUpdate_Click()
BlacklistUpdate.Show
End Sub
 
Private Sub Timer1_Timer()
 
lstRemote.Clear
Txtconnect.Text = ""
Call GetIPInfo
Call CheckIP
 
Label4.Caption = lstRemote.ListCount
End Sub
 
Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
    Case 1
        'code to run for button 1
        Dim FileNum As Integer
 
      Dim FileDate As String
   
      FileNum = FreeFile
   
     FileDate = Format(Date, "yyyy-mm-dd")
   
      'Open App.path & "\" & FileDate & "log.txt" For Output As #FileNum
      
    Open Text1.Text & "Documents and Settings\All Users\Desktop\" & FileDate & "log.txt" For Output As #FileNum
      Print #FileNum, txtAction.Text
   
      Close #FileNum
txtAction.Text = txtAction.Text & vbNewLine & "-- Status log saved to Documents and Settings\All Users\Desktop\" & FileDate & "IPDisconnectlog.txt"
 
    'Case 2
        ''code to run for button 2
        'IPBlockSettings.Show
Case 2
 
Unload IPBlock
End Select
End Sub

That my code.

Sorry to bump but this is a weird problem.

I got this code to check for ips connected against my black list, ( now there are 3 of them as shown here.

VB Code:

Private Sub CheckIP()
Dim intI As Integer
Dim intJ As Integer
Dim lngReturn As Long
Dim strRemote As String * 16
For intI = LBound(udtTCP) To UBound(udtTCP)
    If udtTCP(intI).dwRemoteAddr <> 0 Then
        strRemote = Space(16)
        lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
        strRemote = Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
        For intJ = 0 To lstBlacklist2.ListCount - 1
            If strRemote = Trim(lstBlacklist2.List(intJ)) Then
                udtTCP(intI).dwState = 12
                lngReturn = SetTcpEntry(udtTCP(intI))
                txtAction.Text = txtAction.Text & lstBlacklist2.List(intJ) & _
                    " has been Disconnected at " & Format(Now, "dd/mm/yyyy hh:mm:ss") & vbCrLf
            End If
        Next intJ
    End If
Next intI
 
 
'Next
For intI = LBound(udtTCP) To UBound(udtTCP)
    If udtTCP(intI).dwRemoteAddr <> 0 Then
        strRemote = Space(16)
        lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
        strRemote = Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
        For intJ = 0 To lstBlacklist1.ListCount - 1
            If strRemote = Trim(lstBlacklist1.List(intJ)) Then
                udtTCP(intI).dwState = 12
                lngReturn = SetTcpEntry(udtTCP(intI))
                txtAction.Text = txtAction.Text & lstBlacklist1.List(intJ) & _
                    " has been Disconnected at " & Format(Now, "dd/mm/yyyy hh:mm:ss") & vbCrLf
            End If
        Next intJ
    End If
Next intI
 
 
 
'NEXT
 
For intI = LBound(udtTCP) To UBound(udtTCP)
    If udtTCP(intI).dwRemoteAddr <> 0 Then
        strRemote = Space(16)
        lngReturn = RtlIpv4AddressToString(udtTCP(intI).dwRemoteAddr, strRemote)
        strRemote = Trim$(Left$(strRemote, InStr(strRemote, Chr(0)) - 1))
        For intJ = 0 To lstBlacklist3.ListCount - 1
            If strRemote = Trim(lstBlacklist3.List(intJ)) Then
                udtTCP(intI).dwState = 12
                lngReturn = SetTcpEntry(udtTCP(intI))
                txtAction.Text = txtAction.Text & lstBlacklist3.List(intJ) & _
                    " has been Disconnected at " & Format(Now, "dd/mm/yyyy hh:mm:ss") & vbCrLf
            End If
        Next intJ
    End If
Next intI
End Sub

but the problem is the program will not disconnect them.

instead of blocking why shouldnt use giving access to certain ip address only, perhaps known list should be smaller than unknown

How would you do that?