Hola, hize algunos cambios en el programa ya que habian algunos foros que impedian el ingreso y solo dejaban ver los temas a los usuarios registrados asi que....



  Ahora le di la opción de ingresar sesión a los fantasmas jajaja.
Las instrucciones siguen en el primer post al igual que la descarga.

Cualquer duda, consulta, reclamo no duden en decirlo.

PD: dejé un video también en el primer post.

muy buen aporte tio, gracias, de verdad.
¿Banear? ¿por qué? yo lo estoy haciendo en un foro, porque lo iban a tener que acer?
Un saludo

Yo ya hice una vez uno de estos en PHP.. te ha quedado bien 


Por cierto WHK, podrías añadirle un timer entre visitante y visitante?
Ponerlo de forma manual o con random (cada vez con X segundos de diferencia).


Un saludo

Es divertido jugar con foros que ponen "últimos usuarios conectados en los últimos 600 segundos" xD imagínense sí con los usuarios conectados en los últimos 15 segundos se pasan los 1000 en línea xD... Pobres estadísticas

Esto lel login lo hize en un proyecto aparte, cuando lo terminé solo copié las funciones al proyecto del ghost.

Private Sub Command1_Click()
 Winsock.RemoteHost = separar_host(Text3.Text, "host")
 Winsock.RemotePort = "80"
 Winsock.Connect
 Estado.Caption = "Conectando ..."
End Sub
 
Private Sub Command2_Click()
End
End Sub
 
Public Function separar_host(Ruta As String, Tipo As String) As String
Dim Datos() As String
If Not Left$(Ruta, 7) = "http://" Then
 Ruta = "http://" & Ruta
End If
If Tipo = "host" Then
 Datos = Split(Ruta, "/")
 separar_host = Datos(2)
ElseIf Tipo = "ruta" Then
 Datos = Split(Ruta, separar_host(Ruta, "host"))
 separar_host = Datos(1)
End If
End Function
 
Private Sub Winsock_Connect()
 Dim Post_Data As String
 Estado.Caption = "Enviando datos ..."
 Post_Data = "user=" & URLEncode(Text1.Text) & "&passwrd=" & URLEncode(Text2.Text)
 
 Winsock.SendData _
 "POST " & separar_host(Text3.Text, "ruta") & "?action=login2 HTTP/1.1" & vbCrLf & _
 "Host: " & separar_host(Text3.Text, "host") & vbCrLf & _
 "User-Agent: Mozilla/5.0 (Windows; U; Windows NT 5.1; es-ES; rv:1.9.0.8) Gecko/2009032609 Firefox/3.0.8 (.NET CLR 3.5.30729)" & vbCrLf & _
 "Connection: Close" & vbCrLf & _
 "Content-Type: application/x-www-form-urlencoded" & vbCrLf & _
 "Content-Length: " & Len(Post_Data) & vbCrLf & vbCrLf & _
 Post_Data & vbCrLf
End Sub
 
Private Sub Winsock_DataArrival(ByVal bytesTotal As Long)
 Dim Paquetes As String
 Estado.Caption = "Obteniendo paquetes ..."
 Winsock.GetData Paquetes
 If Not Eregi("302 Found", Paquetes) Then Estado.Caption = "Error de datos"
 
 Text4.Text = Obtener_Cookies(Paquetes)
 DoEvents
 Winsock.Close
 Estado.Caption = "Finalizado"
End Sub
 
Private Function Obtener_Cookies(Buffer As String) As String
Rebuscar:
Cookie = InStr(1, Buffer, "Set-Cookie: ")
If Cookie = 0 Then
 Exit Function
Else
 Buffer = Mid$(Buffer, Cookie, Len(Buffer))
 Cookie = InStr(1, Buffer, ";")
 Temporal = Mid$(Buffer, 1, Cookie)
 Buffer = Mid$(Buffer, Cookie, Len(Buffer))
 Temporal = Replace(Temporal, "Set-Cookie: ", "")
 Obtener_Cookies = Obtener_Cookies & " " & Temporal
 Pause "0.01"
 GoTo Rebuscar
End If
End Function
 
Public Function Eregi(Condicion As String, Buffer As String) As Boolean
If InStr(1, Buffer, Condicion) > 0 Then Eregi = True Else Eregi = False
End Function
 
 
Public Function URLEncode(sRawURL As String) As String
 
    On Error GoTo Catch
    Dim iLoop As Integer
    Dim sRtn As String
    Dim sTmp As String
    Const sValidChars = "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz:/.?=_-$(){}~&"
 
 
    If Len(sRawURL) > 0 Then
        ' Loop through each char
 
 
        For iLoop = 1 To Len(sRawURL)
            sTmp = Mid(sRawURL, iLoop, 1)
 
 
            If InStr(1, sValidChars, sTmp, vbBinaryCompare) = 0 Then
                ' If not ValidChar, convert to HEX and p
                '     refix with %
                sTmp = Hex(Asc(sTmp))
 
                If sTmp = "20" Then
                    sTmp = "+"
                ElseIf Len(sTmp) = 1 Then
                    sTmp = "%0" & sTmp
                Else
                    sTmp = "%" & sTmp
                End If
 
            End If
 
            sRtn = sRtn & sTmp
        Next iLoop
 
        URLEncode = sRtn
    End If
 
Finally:
    Exit Function
Catch:
    URLEncode = ""
    Resume Finally
End Function
 
Public Sub Pause(interval)
 On Error Resume Next
 Dim atime
 atime = Timer
 Do While Timer - atime < Val(interval)
  DoEvents
 Loop
End Sub

Les dejo el ejemplo ejecutable y su fuente acá.



Si tienen alguna duda pueden preguntar en el subforo de visual basic.