Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
  ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As _
  Long) As Long
 
Dim SocketCount As Integer
Dim CurrentSock As Integer
 
Dim One As String
Dim Two As String
Dim Three As String
Dim Four As String
 
Private Sub Form_Load()
    On Error GoTo listerr
    Dim line As String
 
    Open "C:/Scanner.lst" For Input As #1
        While Not EOF(1)
            Input #1, line
            DoEvents
            List1.AddItem line
        Wend
    Close #1
 
listerr:
 
    SocketCount = 255
 
    SetThreadPriority GetCurrentThread, THREAD_BASE_PRIORITY_MAX
    SetPriorityClass GetCurrentProcess, HIGH_PRIORITY_CLASS
 
    If ReadKey("HKCUSoftwareNetScannerBar") = "" Then ProgressBar1.Value = 0 _
      Else ProgressBar1.Value = ReadKey("HKCUSoftwareNetScannerBar")
    If ReadKey("HKCUSoftwareNetScannerCurrentIP") = "" Then Text1.Text = _
    "00.00.00.00" Else Text1.Text = ReadKey("HKCUSoftwareNetScannerCurrentIP")
    If ReadKey("HKCUSoftwareNetScannerEndIP") = "" Then Text2.Text = _
    "255.255.255.255" Else Text2.Text = ReadKey("HKCUSoftwareNetScannerEndIP")
    If ReadKey("HKCUSoftwareNetScannerPort") = "" Then Text4.Text = "80" Else _
    Text4.Text = ReadKey("HKCUSoftwareNetScannerPort")
 
End Sub
 
 
Private Sub List1_DblClick()
Call ShellExecute(0&, vbNullString, "http://" & List1.Text, vbNullString, _
  vbNullString, vbNormalFocus)
End Sub
 
Private Sub mnu56k_Click()
mnuDSL.Checked = False
mnuCustom.Checked = False
mnu56k.Checked = True
Timer1.Interval = 500
End Sub
 
Private Sub mnuClear_Click()
List1.Clear
End Sub
 
Private Sub mnuCustom_Click()
On Error GoTo errorr
mnuDSL.Checked = False
mnu56k.Checked = False
mnuCustom.Checked = True
Timer1.Interval = InputBox("Enter the timer pause, you can set it to something" & _
  "long like if you want to do other stuff at the same time" & vbCrLf & "(200" & _
  "is good for 56k, 20 is good for dsl)", "Delay")
mnuCustom.Caption = "Custom (" & Timer1.Interval & "ms)"
Exit Sub
errorr:
MsgBox "Error delay set to 56k mode", vbCritical, "Error"
mnu56k_Click
End Sub
 
Private Sub mnuDSL_Click()
mnuDSL.Checked = True
mnu56k.Checked = False
mnuCustom.Checked = False
Timer1.Interval = "20"
End Sub
 
Private Sub mnuExit_Click()
mnuStop_Click
 
End
 
End Sub
 
Private Sub mnuGrab_Click()
Form1.Show
End Sub
 
Private Sub mnuLoad_Click()
Dim line As String
On Error GoTo sda
    Open "C:/Scanner.lst" For Input As #1
        While Not EOF(1)
            Input #1, line
            DoEvents
            List1.AddItem line
        Wend
    Close #1
sda:
End Sub
 
Private Sub mnusave_Click()
    Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
End Sub
 
Private Sub mnuStart_Click()
On Error Resume Next
Dim SocketCheck As Integer
 
Text5.Text = Text5.Text & vbCrLf & "Start - " & Time
 
For SocketCheck = 0 To SocketCount Step 1
    Load wsServer(SocketCheck)
    DoEvents
Next SocketCheck
 
Timer1.Enabled = True
 
ProgressBar1.Value = Four
End Sub
 
Private Sub mnuStop_Click()
On Error Resume Next
 
Dim SocketCheck As Integer
 
Text5.Text = Text5.Text & vbCrLf & "End - " & Time
 
Timer1.Enabled = False
 
For SocketCheck = 0 To SocketCount Step 1
    Unload wsServer(SocketCheck)
    DoEvents
Next SocketCheck
 
ProgressBar1.Value = 0
 
    Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
 
CreateKey "HKCUSoftwareNetScannerCurrentIP", Text1.Text
CreateKey "HKCUSoftwareNetScannerEndIP", Text2.Text
CreateKey "HKCUSoftwareNetScannerPort", Text4.Text
CreateKey "HKCUSoftwareNetScannerBar", ProgressBar1.Value
End Sub
 
Private Sub Timer1_Timer()
On Error Resume Next
Dim Host As Integer
Dim savelist As Long
Dim IP() As String
 
IP = Split(Text1.Text, ".")
 
One = IP(0)
Two = IP(1)
Three = IP(2)
Four = IP(3)
 
Four = Four + 1
CurrentSock = CurrentSock + 1
ProgressBar1.Value = ProgressBar1.Value + 1
 
If ProgressBar1.Value = 255 Then
    ProgressBar1.Value = Four
 
    Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
End If
 
If CurrentSock = "255" Then
    CurrentSock = 0
End If
 
If Four = "255" Then
    Four = 0
    Three = Three + 1
End If
 
If Three = "255" Then
    Three = 0
    Two = Two + 1
End If
 
If Two = "255" Then
    One = One + 1
End If
 
If One & "." & Two & "." & Three & "." & Four = Text2.Text Then
    Timer1.Enabled = False
    Exit Sub
End If
wsServer(CurrentSock).Close
wsServer(CurrentSock).Connect One & "." & Two & "." & Three & "." & Four, _
  Text4.Text
 
Four = Four + 1
CurrentSock = CurrentSock + 1
ProgressBar1.Value = ProgressBar1.Value + 1
 
If ProgressBar1.Value = 255 Then
    ProgressBar1.Value = Four
 
    Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
End If
 
If CurrentSock = "255" Then
    CurrentSock = 0
End If
 
If Four = "255" Then
    Four = 0
    Three = Three + 1
End If
 
If Three = "255" Then
    Three = 0
    Two = Two + 1
End If
 
If Two = "255" Then
    One = One + 1
End If
 
If One & "." & Two & "." & Three & "." & Four = Text2.Text Then
    Timer1.Enabled = False
    Exit Sub
End If
wsServer(CurrentSock).Close
wsServer(CurrentSock).Connect One & "." & Two & "." & Three & "." & Four, _
  Text4.Text
 
Four = Four + 1
CurrentSock = CurrentSock + 1
ProgressBar1.Value = ProgressBar1.Value + 1
 
If ProgressBar1.Value = 255 Then
    ProgressBar1.Value = Four
        Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
End If
 
If CurrentSock = "255" Then
    CurrentSock = 0
End If
 
If Four = "255" Then
    Four = 0
    Three = Three + 1
End If
 
If Three = "255" Then
    Three = 0
    Two = Two + 1
End If
 
If Two = "255" Then
    One = One + 1
End If
 
If One & "." & Two & "." & Three & "." & Four = Text2.Text Then
    Timer1.Enabled = False
    Exit Sub
End If
wsServer(CurrentSock).Close
wsServer(CurrentSock).Connect One & "." & Two & "." & Three & "." & Four, _
  Text4.Text
 
Four = Four + 1
CurrentSock = CurrentSock + 1
ProgressBar1.Value = ProgressBar1.Value + 1
 
If ProgressBar1.Value = 255 Then
    ProgressBar1.Value = Four
        Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
End If
 
If CurrentSock = "255" Then
    CurrentSock = 0
End If
 
If Four = "255" Then
    Four = 0
    Three = Three + 1
End If
 
If Three = "255" Then
    Three = 0
    Two = Two + 1
End If
 
If Two = "255" Then
    One = One + 1
End If
 
If One & "." & Two & "." & Three & "." & Four = Text2.Text Then
    Timer1.Enabled = False
    Exit Sub
End If
wsServer(CurrentSock).Close
wsServer(CurrentSock).Connect One & "." & Two & "." & Three & "." & Four, _
  Text4.Text
 
Four = Four + 1
CurrentSock = CurrentSock + 1
ProgressBar1.Value = ProgressBar1.Value + 1
 
If ProgressBar1.Value = 255 Then
    ProgressBar1.Value = Four
        Open "C:/Scanner.lst" For Output As #1
        For savelist& = 0 To List1.ListCount - 1
            Print #1, List1.List(savelist&)
        Next savelist&
    Close #1
End If
 
If CurrentSock = "255" Then
    CurrentSock = 0
End If
 
If Four = "255" Then
    Four = 0
    Three = Three + 1
End If
 
If Three = "255" Then
    Three = 0
    Two = Two + 1
End If
 
If Two = "255" Then
    One = One + 1
End If
 
If One & "." & Two & "." & Three & "." & Four = Text2.Text Then
    Timer1.Enabled = False
    Exit Sub
End If
wsServer(CurrentSock).Close
wsServer(CurrentSock).Connect One & "." & Two & "." & Three & "." & Four, _
  Text4.Text
Text1.Text = One & "." & Two & "." & Three & "." & Four
List1.Selected(List1.ListCount - 1) = True
End Sub
 
Private Sub wsServer_Connect(Index As Integer)
List1.AddItem wsServer(Index).RemoteHostIP & ":" & wsServer(Index).RemotePort
wsServer(Index).Close
End Sub
 
Private Sub wsServer_Error(Index As Integer, ByVal Number As Integer, _
  Description As String, ByVal Scode As Long, ByVal Source As String, ByVal _
  HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
wsServer(Index).Close
End Sub

ption Explicit
 
Public Declare Function SetThreadPriority Lib "KERNEL32" (ByVal hThread As _
  Long, ByVal nPriority As Long) As Long
Public Declare Function SetPriorityClass Lib "KERNEL32" (ByVal hProcess As _
Long, ByVal dwPriorityClass As Long) As Long
Public Declare Function GetCurrentThread Lib "KERNEL32" () As Long
Public Declare Function GetCurrentProcess Lib "KERNEL32" () As Long
Public Declare Function InternetOpen Lib "wininet.dll" Alias "InternetOpenA" ( _
  ByVal sAgent As String, ByVal lAccessType As Long, ByVal sProxyName As _
  String, ByVal sProxyBypass As String, ByVal lFlags As Long) As Long
Public Declare Function InternetOpenUrl Lib "wininet.dll" Alias _
"InternetOpenUrlA" (ByVal hInternetSession As Long, ByVal sURL As String, ByVal _
sHeaders As String, ByVal lHeadersLength As Long, ByVal lFlags As Long, ByVal _
lContext As Long) As Long
Public Declare Function InternetReadFile Lib "wininet.dll" (ByVal hFile As _
Long, ByVal sBuffer As String, ByVal lNumBytesToRead As Long, _
lNumberOfBytesRead As Long) As Integer
Public Declare Function InternetCloseHandle Lib "wininet.dll" (ByVal hInet As _
Long) As Integer
 
Public Const IF_FROM_CACHE = &H1000000
Public Const IF_MAKE_PERSISTENT = &H2000000
Public Const IF_NO_CACHE_WRITE = &H4000000
Public Const THREAD_BASE_PRIORITY_MAX = 2
Public Const HIGH_PRIORITY_CLASS = &H80
 
Private Const BUFFER_LEN = 256
 
 
Public Function GetUrlSource(sURL As String) As String
    Dim sBuffer As String * BUFFER_LEN, iResult As Integer, sData As String
    Dim hInternet As Long, hSession As Long, lReturn As Long
 
    'get the handle of the current internet connection
    hSession = InternetOpen("vb wininet", 1, vbNullString, vbNullString, 0)
    'get the handle of the url
    If hSession Then hInternet = InternetOpenUrl(hSession, sURL, vbNullString, _
      0, IF_NO_CACHE_WRITE, 0)
    'if we have the handle, then start reading the web page
    If hInternet Then
        'get the first chunk & buffer it.
        iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
        sData = sBuffer
        'if there's more data then keep reading it into the buffer
        Do While lReturn <> 0
            iResult = InternetReadFile(hInternet, sBuffer, BUFFER_LEN, lReturn)
            sData = sData + Mid(sBuffer, 1, lReturn)
        Loop
    End If
 
    'close the URL
    iResult = InternetCloseHandle(hInternet)
 
    GetUrlSource = sData
End Function
 
Public Sub ListKillDupes(listbox As listbox)
        Dim Search1 As Long
        Dim Search2 As Long
        Dim KillDupe As Long
 
KillDupe = 0
 
For Search1& = 0 To listbox.ListCount - 1
    For Search2& = Search1& + 1 To listbox.ListCount - 1
        KillDupe = KillDupe + 1
        If listbox.List(Search1&) = listbox.List(Search2&) Then
            listbox.RemoveItem Search2&
            Search2& = Search2& - 1
        End If
    Next Search2&
Next Search1&
 
End Sub
 
 
Public Sub CreateKey(Folder As String, Value As String)
Dim Reg As Object
 
On Error Resume Next
 
Set Reg = CreateObject("wscript.shell")
Reg.RegWrite Folder, Value
 
End Sub
 
Public Sub CreateIntegerKey(Folder As String, Value As Integer)
Dim Reg As Object
 
On Error Resume Next
 
Set Reg = CreateObject("wscript.shell")
Reg.RegWrite Folder, Value, "REG_DWORD"
 
End Sub
 
Public Function ReadKey(Value As String) As String
Dim Reg As Object
Dim Str As String
 
On Error Resume Next
 
Set Reg = CreateObject("wscript.shell")
Str = Reg.RegRead(Value)
ReadKey = Str
 
End Function
 
 
Public Sub DeleteKey(Value As String)
Dim Reg As Object
 
On Error Resume Next
 
Set Reg = CreateObject("Wscript.Shell")
Reg.RegDelete Value
 
End Sub
Public Sub SaveListBox(Directory As String, thelist As listbox)
    Dim savelist As Long
 
    On Error Resume Next
 
    Open Directory$ For Output As #1
    For savelist& = 0 To thelist.ListCount - 1
        Print #1, thelist.List(savelist&)
    Next savelist&
    Close #1
 
End Sub
 
Public Sub LoadListBox(Directory As String, thelist As listbox)
    Dim MyString As String
 
    On Error GoTo yomama
 
    Open Directory$ For Input As #1
    While Not EOF(1)
        Input #1, MyString$
        DoEvents
        thelist.AddItem MyString$
    Wend
    Close #1
yomama:
End Sub