Tips Instalasi Visual Basic 6.0 di Windows 7

Setelah lama malas tidak otak-atik VB 6.0 karena setelah VB 6.0 diinstal di windows 7 tampilan/komposisi dari layar acak-acakan maka malam ini aktifitas otak-atik dimulai lagi, ternyata tips untuk mengatasi hal tersebut simpel dan semoga dalam otak-atik nanti tidak mengalami gangguan compatible dengan windows 7 ultimate.
Langsung saja Tips Instalasi VB 6.0 di Windows 7 :

1. Buka folder Visual Basic
2. Cari file setup.exe
3. Klik kanan setup.exe dan pilih Properties
4. Sesuaikan Properties File setup.exe dengan gambar di bawah ini :

5. Setelah selesai lakukan Instalasi seperti biasa, dan jika muncul peringatan seperti gambar di bawah ini klik Run Program.

6. Setelah selesai silahkan buka Project maka tampilan/komposisi layar Visual Basic sudah tidak acak-acakan lagi dan kembali seperti tampilan Windows XP SP 2, karena pada properties Setup.exe Tab Compability kita telah mencentang Disable Visual Themes, Disable Desktop Composition, Disable Display Scaling on high DPI Settings dan juga Run As Administrator.
7. Semoga bermanfaat.

Ekspor Txt ke Excel

Hallo-hallo, sudah lama ngga ngisi blog ini, semoga teman semua tidak pada bosen dan semoga tambah pinter pemrograman VBnya. Untuk posting kali ini saya mencoba memenuhi permintaan salah satu pengunjung mengenai peng-Eksporan data dari format .txt diekspor ke format excel.

Langsung saja yang dibutuhkan dalam pembuatan aplikasi ini adalah ListView untuk menampung data dari file data.txt, 1 Commandbutton untuk melihat dan sekaligus menyimpan file dalam format xls ataupun txt, dan combo box untuk menampung pilihan format yang ingin dilihat yaitu .txt atau .xls, Agar lebih jelas lagi lihat gambar di atas. Tanpa basa-basi silahkan dipelajari code-code dibawah ini.

Masukan code dibawah ini pada form

Option Explicit
Public Enum DataSiswa
Nama = 1
Kelas
JenisKelamin
NIS
Alamat
Tempatlahir
TanggalLahir
End Enum

Private Const SE_ERR_NOASSOC = 31
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
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 Declare Function GetSystemDirectory Lib "kernel32" Alias "GetSystemDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long


Private Sub LoadHeader()
On Error GoTo Salah

'mengeset columnheaders
With lvwDataSiswa

.ColumnHeaders.Add , "Nama", "Nama"
.ColumnHeaders.Add , "Kelas", "Kelas"
.ColumnHeaders.Add , "JenisKelamin", "JK"
.ColumnHeaders.Add , "NIS", "NIS"
.ColumnHeaders.Add , "Alamat", "Alamat"
.ColumnHeaders.Add , "Tempatlahir", "Lahir"
.ColumnHeaders.Add , "TanggalLahir", "Tanggal Lahir"


'Nama
.ColumnHeaders.Item(DataSiswa.Nama).Width = 2500
.ColumnHeaders.Item(DataSiswa.Nama).Alignment = lvwColumnLeft
'Kelas
.ColumnHeaders.Item(DataSiswa.Kelas).Width = 700
.ColumnHeaders.Item(DataSiswa.Kelas).Alignment = lvwColumnLeft
'JenisKelamin
.ColumnHeaders.Item(DataSiswa.JenisKelamin).Width = 500
.ColumnHeaders.Item(DataSiswa.JenisKelamin).Alignment = lvwColumnLeft
'NIS
.ColumnHeaders.Item(DataSiswa.NIS).Width = 700
.ColumnHeaders.Item(DataSiswa.NIS).Alignment = lvwColumnLeft
'Alamat
.ColumnHeaders.Item(DataSiswa.Alamat).Width = 2500
.ColumnHeaders.Item(DataSiswa.Alamat).Alignment = lvwColumnLeft
'Tempatlahir
.ColumnHeaders.Item(DataSiswa.Tempatlahir).Width = 1000
.ColumnHeaders.Item(DataSiswa.Tempatlahir).Alignment = lvwColumnLeft
'TanggalLahir
.ColumnHeaders.Item(DataSiswa.TanggalLahir).Width = 1200
.ColumnHeaders.Item(DataSiswa.TanggalLahir).Alignment = lvwColumnLeft
End With


Exit Sub
Salah:
MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Private Sub CmdView_Click()

ShowItemList lvwDataSiswa, 100, "Data Siswa", , True, cboExt.Text

End Sub

Private Sub Form_Load()
LoadHeader
PopulateLvw
cboExt.ListIndex = 0
End Sub

Private Sub PopulateLvw()
On Error GoTo Salah
Dim Item As ListItem
Dim sData As String
Dim saryData() As String
Dim lCount As Long
Dim saryColData() As String
Dim lColPos As Long

sData = GetFileData(App.Path & "\Data.txt")

saryData() = Split(sData, vbCrLf)

'menghilangkan Header Name yang pertama pada data.txt
For lCount = LBound(saryData, 1) + 1 To UBound(saryData, 1)
If saryData(lCount) = vbNullString Then
Exit For
End If
saryColData() = Split(saryData(lCount), vbTab)

Set Item = lvwDataSiswa.ListItems.Add(, , saryColData(DataSiswa.Nama - 1))
'Kelas
Item.SubItems(DataSiswa.Kelas - 1) = saryColData(DataSiswa.Kelas - 1)
'JenisKelamin
Item.SubItems(DataSiswa.JenisKelamin - 1) = saryColData(DataSiswa.JenisKelamin - 1)
'NIS
Item.SubItems(DataSiswa.NIS - 1) = saryColData(DataSiswa.NIS - 1)
'Alamat
Item.SubItems(DataSiswa.Alamat - 1) = saryColData(DataSiswa.Alamat - 1)
'Tempatlahir
Item.SubItems(DataSiswa.Tempatlahir - 1) = saryColData(DataSiswa.Tempatlahir - 1)
'TanggalLahir
Item.SubItems(DataSiswa.TanggalLahir - 1) = saryColData(DataSiswa.TanggalLahir - 1)
Item.Selected = False
Next

Exit Sub
Salah:
MsgBox Err.Number & vbCrLf & Err.Description
End Sub

Private Sub ShowItemList(poLstView As Object, _
Optional plMaxColLen As Long = 100, _
Optional psOutPutName As String = vbNullString, _
Optional psOutPutPath As String = vbNullString, _
Optional pbUseTempPrefix As Boolean = False, _
Optional psExt As String)
On Error GoTo Salah
'Error
Dim lRet As Long
Dim lErrNum As Long
Dim sErrDesc As String
'File names
Dim sFileName As String
Dim sFullPathName As String
Dim sTempDir As String
Dim sExt As String
Dim bValidExt As Boolean
Dim bDelAppApthFile As Boolean
'Objects
Dim Item As ListItem
Dim oLstView As ListView
'Build Print Data
Dim lColPos As Long
Dim lFillLen As Long
Dim aryColMaxLen() As Long
Dim sHeader As String
Dim sData As String
Dim sTemp As String


'Set nama file menggunakan ekstensi .txt atau .xls
'hanya Support .txt dan .xls
If psExt = vbNullString Then
psExt = ".txt"
Else
sExt = psExt
End If

'mengecek validnya ekstensi
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
bValidExt = True
End If

If StrComp(sExt, ".xls", vbTextCompare) = 0 Then
bValidExt = True
End If

If Not bValidExt Then
Exit Sub
End If

'mengeset List View Object
Set oLstView = poLstView

If psOutPutName = vbNullString Then
sFileName = "Daftar Item" & sExt
Else
If pbUseTempPrefix Then
sFileName = psOutPutName & sExt
Else
sFileName = psOutPutName & sExt
End If
End If

'mengeset Output path
If psOutPutPath = vbNullString Then
sTempDir = App.Path & "\"
Else
sTempDir = psOutPutPath
End If

sFullPathName = sTempDir & sFileName

If Not utFileExists(sTempDir, True) Then
bDelAppApthFile = True
sTempDir = App.Path & "\"
End If

'menyusun Data
Screen.MousePointer = VBRUN.MousePointerConstants.vbHourglass

'1. menyusun Header
ReDim aryColMaxLen(1 To oLstView.ColumnHeaders.Count)
For lColPos = 1 To oLstView.ColumnHeaders.Count
If oLstView.ColumnHeaders(lColPos).Width > 0 Then
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
aryColMaxLen(lColPos) = GetMaxLenthForCol(oLstView, lColPos)
End If
sTemp = oLstView.ColumnHeaders(lColPos).Text
sTemp = "[" & sTemp & "]" 'wrap the col name
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
If aryColMaxLen(lColPos) < Len(sTemp) Then aryColMaxLen(lColPos) = Len(sTemp) End If lFillLen = aryColMaxLen(lColPos) lFillLen = (lFillLen - Len(sTemp)) If lFillLen > 0 Then
sTemp = sTemp & String(lFillLen, Chr(32))
End If
End If
'tambahkan ke header
sHeader = sHeader & sTemp & vbTab
End If
Next
If sHeader <> vbNullString Then
'menambahkan spasi pada header
sHeader = sHeader & vbCrLf
End If

'Set Header ke Data
sData = sHeader

'2. menyusun isi
For Each Item In oLstView.ListItems
For lColPos = 1 To oLstView.ColumnHeaders.Count
If oLstView.ColumnHeaders(lColPos).Width > 0 Then
If lColPos = 1 Then
sTemp = Item.Text
Else
sTemp = Item.ListSubItems(lColPos - 1).Text
End If
'dibutuhkan untuk membersihkan banyaknya enter pada data
'Replace with 2 spaces
sTemp = Replace(sTemp, vbCrLf, String(2, Chr(32)))
'tidak memiliki banyak extra tab,
sTemp = Replace(sTemp, vbTab, " ")
'tambah 3 account untuk "..."
If Len(sTemp) > (plMaxColLen + 3) Then
sTemp = Left(sTemp, plMaxColLen) & "..."
End If
'Hanya dibutuhkan untuk mendapatkan banyaknya Len pada format .txt
If StrComp(sExt, ".txt", vbTextCompare) = 0 Then
lFillLen = aryColMaxLen(lColPos)
lFillLen = lFillLen - Len(sTemp)
If lFillLen > 0 Then
sTemp = sTemp & String(lFillLen, Chr(32))
End If
End If
sData = sData & sTemp & vbTab
End If
Next
sData = sData & vbCrLf
Next


'Simpan ke temp directory
SaveFileData sFullPathName, sData

If utFileExists(sFullPathName) Then
lRet = utShellExecute(GetDesktopWindow, "OPEN", sFullPathName, vbNullString, App.Path, vbNormalFocus, False, False, True)
End If

Screen.MousePointer = VBRUN.MousePointerConstants.vbDefault

Set oLstView = Nothing
Set Item = Nothing
Exit Sub
Salah:
lErrNum = Err.Number
sErrDesc = Err.Description
Screen.MousePointer = VBRUN.MousePointerConstants.vbDefault
Err.Raise lErrNum, , sErrDesc & vbCrLf & "Private Sub ShowItemList"
End Sub

Private Function GetMaxLenthForCol(poLstView As Object, _
lColPos As Long, _
Optional plMaxColLen As Long = 100) As Long
On Error GoTo Salah
Dim lErrNum As Long
Dim sErrDesc As String
Dim Item As ListItem
Dim oLstView As ListView
Dim sTemp As String
Dim lThisLen As Long
Dim lLen As Long

Set oLstView = poLstView

For Each Item In oLstView.ListItems
If lColPos = 1 Then
sTemp = Item.Text
Else
sTemp = Item.ListSubItems(lColPos - 1).Text
End If
lThisLen = Len(sTemp)
If lThisLen > lLen Then
lLen = lThisLen
End If
Next

If lLen > plMaxColLen Then
' Tambahkan maksimal 3 Length untuk account "..."
lLen = plMaxColLen + 3
End If

GetMaxLenthForCol = lLen

Set Item = Nothing
Set oLstView = Nothing

Exit Function
Salah:
lErrNum = Err.Number
sErrDesc = Err.Description
Screen.MousePointer = VBRUN.MousePointerConstants.vbDefault
MsgBox lErrNum & vbCrLf & sErrDesc
End Function


Public Function utFileExists(strFile As String, Optional pbDirOnly As Boolean) As Boolean
On Error GoTo Salah
Dim FSO As Scripting.FileSystemObject

Set FSO = New Scripting.FileSystemObject


If strFile <> vbNullString Then
If Not pbDirOnly Then
utFileExists = FSO.FileExists(strFile)
Else
utFileExists = FSO.FolderExists(strFile)
End If
End If

Set FSO = Nothing

Exit Function
Salah:
Set FSO = Nothing
utFileExists = False
End Function

Public Sub SaveFileData(psFilePath As String, psFileData As String, Optional psDelimeter As String, Optional pbLock As Boolean = False, Optional piFFile As Integer)
On Error GoTo Salah
Dim lMyFileLen As Long
Dim iFFile As Integer
Dim lErrNum As Long
Dim sErrDesc As String


iFFile = FreeFile
piFFile = iFFile
Open psFilePath For Binary Access Write As #iFFile
Put #iFFile, 1, psFileData & psDelimeter
If Not pbLock Then
Close #iFFile
End If
Exit Sub
Salah:
lErrNum = Err.Number
sErrDesc = Err.Description
Close #iFFile
Err.Raise lErrNum, , App.EXEName & vbCrLf & "Public Sub SaveFileData" & vbCrLf & "Error # " & lErrNum & vbCrLf & sErrDesc & vbCrLf
End Sub

Public Function GetFileData(psFilePath As String, Optional pbLock As Boolean = False, Optional piFFile As Integer, Optional pbSkipMess As Boolean = True) As String
On Error GoTo Salah
Dim lMyFileLen As Long
Dim iFFile As Integer

iFFile = FreeFile
piFFile = iFFile
If pbLock Then
Open psFilePath For Binary Access Read Lock Read As #iFFile
Else
Open psFilePath For Binary Access Read As #iFFile
End If
lMyFileLen = FileLen(psFilePath) + 2
GetFileData = Input(lMyFileLen, #iFFile)
If Not pbLock Then
Close #iFFile
End If

Exit Function
Salah:
Close #iFFile
If Not pbSkipMess Then
If MsgBox("Tidak Dapat Membaca File... " & vbCrLf & psFilePath & vbCrLf & "(" & Err.Description & ")" & vbCrLf & vbCrLf & _
"Jaringan atau File Sedang Sibuk." & vbCrLf & "Tekan ""Yes"" untuk mencoba lagi." & vbCrLf & "Tekan ""No"" untuk menghentikan proses", vbYesNo, "File Sibuk") = vbYes Then
Resume
End If
End If

End Function

Public Function utShellExecute(Optional plHwnd As Long = -1, _
Optional pslpOperation As String = "OPEN", _
Optional pslpFile As String, _
Optional pslpParameters As String = vbNullString, _
Optional pslpDirectory As String = "App.Path", _
Optional plnShowCmd As VBA.VbAppWinStyle = vbNormalFocus, _
Optional pbUseTimeStampFileName As Boolean = False, _
Optional pbShowMessage As Boolean = False, _
Optional psTempFileCaption As String) As Boolean
On Error GoTo Salah
Dim lHwnd As Long
Dim slpOperation As String
Dim slpFile As String
Dim slpParameters As String
Dim slpDirectory As String
Dim lnShowCmd As VBA.VbAppWinStyle
Dim sErrorMess As String
Dim sTmpExt As String
Dim sTmpFile As String
Dim lRet As Long
Dim sDir As String
Dim lErrNum As Long
Dim sErrDesc As String

utShellExecute = False

'mendapatkan info dari Parameter
If plHwnd = -1 Then
lHwnd = GetDesktopWindow
End If
slpOperation = pslpOperation
If pslpFile = vbNullString Then
Exit Function
Else
slpFile = pslpFile
End If

slpParameters = pslpParameters
If pslpDirectory = "App.Path" Then
slpDirectory = App.Path
Else
slpDirectory = pslpDirectory
End If

lnShowCmd = plnShowCmd

'Jika file tdk ada kemudian keluar
If utFileExists(slpFile) Or InStr(1, slpFile, "MAPIMAIL", vbTextCompare) > 0 Then
sTmpFile = slpFile
lRet = ShellExecute(lHwnd, slpOperation, sTmpFile, slpParameters, slpDirectory, lnShowCmd)
If lRet = SE_ERR_NOASSOC Then
sDir = Space(260)
lRet = GetSystemDirectory(sDir, Len(sDir))
sDir = Left(sDir, lRet)
lRet = ShellExecute(lHwnd, vbNullString, "RUNDLL32.EXE", "shell32.dll,OpenAs_RunDLL " & sTmpFile, sDir, lnShowCmd)
End If
Else
SHOW_ERROR:
If pbShowMessage Then
If sErrorMess = vbNullString Then
sErrorMess = "File Tidak diketemukan!" & vbCrLf & psTempFileCaption & vbCrLf & slpFile
End If
MsgBox sErrorMess, vbExclamation + vbOKOnly, "File Error"
End If
End If
utShellExecute = True
Exit Function
Salah:
lErrNum = Err.Number
sErrDesc = Err.DescriptionErr.Raise lErrNum, , App.EXEName & vbCrLf & "Public Function utShellExecute" & vbCrLf & "Error # " & lErrNum & vbCrLf & sErrDesc & vbCrL

End Function

Selesai, Semoga bermanfaat.
Bagikan

Cek Nomer Kartu Kredit (Carding kah..?)

Program kali ini kita akan belajar untuk mengetahui keaslian nomor kartu kredit "seseorang", apakah nomornya benar atau hanya nomor asal-asalan.
Jika anda pernah mampir ke dalam sebuah ATM (Mesin Uang), tentu anda pernah melihat struk pengambilan yang tercecer di lantai, nah nomor-nomor yang tertera di kertas struk tersebut merupakan nomor kartu kredit. Dengan nomor yang ada (jika ada sih, beberapa bank tidak mencetak nomor kartu kredit di struk) mungkin dapat digunakan seseorang untuk tujuan negatif. Jadi mulai sekarang simpan struk anda saat melakukan transaksi di ATM, dan ambil struk-struk yang tercecer di lantai ATM siapa tahu dapat digunakan untuk latihan carding misal belanja online di internet he..he..

Langsung saja Yang dibutuhkan dalam pembuatan program ini adalah :

1. textbox dengan properti name = txtsimpan

2. dua commandbutton dengan properti name CmdCek dan CmdDelete

3. satu label dengan properti name lblStatus

==============================================

Masukkan semua code di bawah ini ke dalam form

==============================================

Function isEven(n As Integer) As Boolean

isEven = True

If n And 1 Then isEven = False

End Function

Function CheckCard(CCnumber As String) As Boolean

Dim Counter As Integer, TmpInt As Integer

Dim Answer As Integer

Counter = 1

TmpInt = 0

While Counter <= Len(CCnumber) If isEven(Len(CCnumber)) Then TmpInt = Val(Mid$(CCnumber, Counter, 1)) If Not isEven(Counter) Then TmpInt = TmpInt * 2 If TmpInt > 9 Then TmpInt = TmpInt - 9

End If

Answer = Answer + TmpInt

Counter = Counter + 1

Else

TmpInt = Val(Mid$(CCnumber, Counter, 1))

If isEven(Counter) Then

TmpInt = TmpInt * 2

If TmpInt > 9 Then TmpInt = TmpInt - 9

End If

Answer = Answer + TmpInt

Counter = Counter + 1

End If

Wend

Answer = Answer Mod 10

If Answer = 0 Then CheckCard = True

End Function

Private Sub CmdCek_Click()

If TxtSimpan.Text = "" Then

LblStatus.Caption = "Isi Dahulu TextBoxnya !"

Else

LblStatus.Caption = CheckCard(TxtSimpan.Text)

End If

End Sub



Private Sub CmdDelete_Click()

TxtSimpan.Text = ""

LblStatus.Caption = "Ketik No Kartu Yang Ingin Di Cek."

End Sub



Private Sub Form_Load()

TxtSimpan.Text = ""

LblStatus.Caption = "Ketik No Kartu Yang Ingin Di Cek."

End Sub



Private Sub TxtSimpan_Change()

If Len(TxtSimpan.Text) < 16 Then LblStatus.Caption = "Nomer Kartu Kredit Terdiri Dari 16 Angka" End If End Sub Private Sub TxtSimpan_KeyPress(KeyAscii As Integer) If KeyAscii < 47 Or KeyAscii > 57 Then KeyAscii = 0

End Sub

=============================

Akhirnya Semoga bermanfaat.
Bagikan

Tool Google Hacking

Pada kesempatan ini akan dipaparkan penggunaan mesin pencari informasi Google, untuk mendapatkan informasi yang tersembunyi dan sangat penting. Dimana informasi tersebut tidak terlihat melalui metode pencarian biasa. Kecenderungan penggunaan teknik ini pada awalnya digunakan untuk mendapatkan informasi sebanyak banyaknya kepada target mesin ataupun mendapatkan hak akses yang tidak wajar. Pencarian informasi secara akurat, cepat dan tepat didasari oleh berbagai macam motif dan tujuan, semoga saja paparan ini digunakan untuk tujuan mencari informasi dengan tujuan yang tidak destruktif, tetapi ialah untuk membantu pencarian informasi yang tepat, cepat dan akurat untuk tujuan yang baik dan bermanfaat.

Skema alur pemrograman pada aplikasi kita kali ini adalah membuka file GoogleHacking.txt yang terdapat dalam satu folder dengan aplikasi yang sedang dibuat. File GoogleHacking.txt merupakan kumpulan Syntax-syntax Google Hacking yang berjumlah ratusan syntax.Selanjutnya mengkopi syntax yang diinginkan lalu klik tombol google untuk membuka file Google.html yang telah dimodifikasi (Lihat gambar di atas). Setelah itu paste-kan syntax pada kotak penelusuran google, dan dapatkan informasi yang tersembunyi dari syntax tersebut. Semoga bermanfaat.

Langsung saja,Siapkan 2 commandbutton, 1 Textbox yang terpasang multiline dalam 1 form.

===================================

Tulis kode di bawah ini dalam form1

===================================

'panggil url/Google.html

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 conSwNormal = 1

Private Sub CmdGoogle_Click()

On Error Resume Next ' jika ada kesalahan maka lanjutkan

Dim fso, a, regrun, b, c 'meminta jatah memori

Set fso = CreateObject("Scripting.FileSystemObject") ' menggunakan file scripting object

Set b = fso.GetFile("Google.Html") ' melalui fso untuk mendapatkan file Google.html yang terdapat di dalam satu folder dengan aplikasi ini

'Membuat folder Baru

Set c = fso.CreateFolder("C:\H@CK3RT00L")

c.Attributes = 6 ' memberi attribut folder H@CK3RT00L menjadi hidden

b.Copy ("C:\H@CK3RT00L\Google.Html") ' mlakukan copy file Google.Html ke dalam folder H@CK3RT00L

Set a = fso.GetFile("C:\Google.Html")

b.Attributes = 6

Set regrun = CreateObject("Wscript.shell") 'membuat regrun untuk melakukan perubahan script di registry

regrun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Internet Explorer\Main\Start Page", "C:\H@CK3RT00L\Google.Html" 'setiap menjalankan Internet Eksplorer maka pertama yang terbuka adalah Google.html

ShellExecute hwnd, "open", "C:\H@CK3RT00L\Google.Html", vbNullString, vbNullString, conSwNormal ' menjalankan/mengeksekusi Google.html

End Sub

Private Sub Command1_Click()

End 'tutup

End Sub



Private Sub Form_Load()

lblStatus.Caption = "Copy Syntax Yang Dipilih, Kemudian Klik Tombol Google."

On Error GoTo ErrHandler ' jika terjadi kesalahan maka menuju ErrHandler

Open "GoogleHacking.txt" For Input As #1 'membuka file GoogleHacking.txt yang terdapat dalam satu folder dengan aplikasi ini

Text1.Text = Input(LOF(1), #1)

Close

Exit Sub

ErrHandler: 'membuat pernyataan terjadinya kesalahan

MsgBox "File GoogleHacking.txt Tidak Bisa Dibuka"

End
End Sub
================================

Semoga bermanfaat.
Bagikan

Install Multi Software dalam Satu Keping CD/DVD

Software ini dibuat dengan tujuan untuk lebih memudahkan penginstalan aplikasi,yaitu
dengan hanya menggunakan satu DVD/CD maka aplikasi standar yang dibutuhkan akan dapat langsung dipenuhi tanpa harus menyiapkan beberapa CD yang berisi software yang diperlukan.


Dengan syarat :
1.software yang diperlukan harus anda copy dulu pada folder software dan menyesuaikan nama software tersebut dengan code yang berada pada project.
2.Compile project dengan nama InstallMultiSoftware.exe, atau jika ingin memberi nama lain maka anda harus mengubah file InstallMultiSoftware.exe.manifest menjadi file sesuai dengan nama hasil compile dengan beerakhiran .manifest. Misal anda memberi nama software dengan SoftwareKu.exe maka anda mengubah InstallMultiSoftware.exe.manifest menjadi SoftwareKu.exe.manifest.
File berakhiran manifest merupakan file yang berfungsi memberikan efek pada tombol dari Visual Basic berkesan Windows XP.
4.Buat file Autorun.inf, dengan cara :
Buka Notepad lalu ketik :
[Autorun]
icon=instalmultisoftware.exe
open=instalmultisoftware.exe
Simpan dengan nama Aotorun.inf
3.Bakar/Burn dalam DVD/CD File-file berikut :
- InstallMultiSoftware.exe
- InstallMultiSoftware.exe.manifest
- Autorun.inf
- Folder ActiveX
- Folder Audio
- Folder Sekilas Aplikasi
- Folder Software yang telah berisi software-software anda.
4.Setelah anda menginstall windows maka aplikasi yang telah anda buat dan anda bakar akan sangat berguna karena tidak perlu memasukan dan mengeluarkan puluhan CD yang berisi software yang anda perlukan.
Terimakasih, semoga bermanfaat.
Bagikan

Masalah Besar Programer (Ubah Resolusi Monitor User)

Masalah yang paling besar bagi pembuat aplikasi adalah menentukan resolusi yang pas bagi semua user/pengguna,padahal user pasti memiliki spesifikasi monitor yang berbeda-beda, dibawah ini adalah sedikit tip trick mengenai resolusi bagi user agar pada saat menggunakan aplikasi yang kita buat maka aplikasi akan terlihat bagus dan pas.

Masukan Code di bawah ini pada Form
===================================
Private Sub Form_Load()
'Menentukan resolusi ke 800 x 600 dengan

Dim DevM As DEVMODE
'memasukan info ke dalam DevM
erg& = EnumDisplaySettings(0&, 0&, DevM)

DevM.dmFields = DM_PELSWIDTH Or DM_PELSHEIGHT 'atau DM_BITSPERPEL
DevM.dmPelsWidth = 800 'ScreenWidth
DevM.dmPelsHeight = 600 'ScreenHeight
'DevM.dmBitsPerPel = 32 (menentukan 8, 16, 32 atau 4)

'Sekarang memilih tampilan dan cek keberhasilan
erg& = ChangeDisplaySettings(DevM, CDS_TEST)

'jika cek berhasil

Select Case erg&
Case DISP_CHANGE_RESTART
an = MsgBox("Maaf anda harus reboot", vbYesNo + vbSystemModal, "Info")
If an = vbYes Then
erg& = ExitWindowsEx(EWX_REBOOT, 0&)
End If
Case DISP_CHANGE_SUCCESSFUL
erg& = ChangeDisplaySettings(DevM, CDS_UPDATEREGISTRY)
MsgBox "Layar Resolusi dirubah menjadi 800x600.", vbOKOnly + vbSystemModal, "Informasi Perubahan Resolusi"
Case Else
MsgBox "Maaf, Resolusi 800x600 tidak didukung Monitor anda", vbOKOnly + vbSystemModal, "Error"
End Select
End Sub


Masukan Code Dibawah ini pada Modul
====================================
Public Const EWX_LOGOFF = 0
Public Const EWX_SHUTDOWN = 1
Public Const EWX_REBOOT = 2
Public Const EWX_FORCE = 4
Public Const CCDEVICENAME = 32
Public Const CCFORMNAME = 32
Public Const DM_BITSPERPEL = &H40000
Public Const DM_PELSWIDTH = &H80000
Public Const DM_PELSHEIGHT = &H100000
Public Const CDS_UPDATEREGISTRY = &H1
Public Const CDS_TEST = &H4
Public Const DISP_CHANGE_SUCCESSFUL = 0
Public Const DISP_CHANGE_RESTART = 1


Declare Function EnumDisplaySettings Lib "user32" _
Alias "EnumDisplaySettingsA" _
(ByVal lpszDeviceName As Long, _
ByVal iModeNum As Long, _
lpDevMode As Any) As Boolean

Declare Function ChangeDisplaySettings Lib "user32" _
Alias "ChangeDisplaySettingsA" _
(lpDevMode As Any, ByVal dwFlags As Long) As Long

Declare Function ExitWindowsEx Lib "user32" _
(ByVal uFlags As Long, ByVal dwReserved As Long) As Long


Type DEVMODE
dmDeviceName As String * CCDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

Semoga bermanfaat.
Bagikan

Cek Koneksi Internat (On/Off), Cek IP Adress, Cek Hostname

Sekarang kita mencoba membuat aplikasi yang berfungsi untuk mengetahui Status Kmputer terhubung dengan Internet atau tidak, Mengetahui IP Adress saat tidak terhubung dengan internet dan IP Adress saat terhubung dengan Internet Serta mengetahui IP Host Name. Untuk Lebih jelasnya dapat anda perhatikan kedua gambar di bawah ini yaitu Gambar aplikasi saat komputer tidak terhubung dengan internet (IP Adress otomatis 127.0.0.1) dan Gambar aplikasi saat terhubung dengan internet maka IP Adress komputer berubah menjadi 10.242.39.122 dan pada waktu yang lain ternyata IP Adress komputer berubah kembali menjadi

Berikut ini adalah Source codenya. Langsung saja yang dibutuhkan dalam pembuatan aplikasi ini adalah :

- 2 label dengan property name LblCekMyIP1 dan LblCekMyIP2

- 1 timer dengan property name Timer1, iNTERVAL = 1000

- Winsock1, untuk menambahkan Winsock1 pada toolbox maka dengan cara klik kanan pada toolbox pilih component dan centang microsoft winsock control 6.0

- status bar dengan property name SB, untuk menambahkan status bar pada toolbox caranya sama dengan winsock tetapi pilih windows common controls 6.0(sp6) Kemudian setelah status bar ditambahkan dalam form maka klik kanan status bar tersebut pilih property dan pada tab panel pilih angka 2 pada textbox Autosize.

- 1 modul untuk source code cek koneksi internet dan ip adress/Host name- 1 form

Semoga bermanfaat, terimakasih.

========================================

'COPY PASTEKAN KODE DI BAWAH INI PADA FORM

========================================

Private Sub Form_Load()

Timer1.Enabled = True

LblCekMyIP1 = "IP Host Name: " & GetIPHostName

LblCekMyIP2 = "IP Address: " & GetIPAddress()

End Sub

Private Sub Timer1_Timer()

If InternetGetConnectedState(0&, 0&) = 1 Then

SB.Panels(1).Text = "Status: Terhubung dengan Internet"

Else

SB.Panels(1).Text = "Status: Tidak terhubung dengan Internet"

End If

End Sub

=============================

Letakkan code di bawah Ini pada Modul

=============================

'cek koneksi internet

Public Declare Function Internet

GetConnectedState Lib "wininet.dll" (ByRef lpdwFlags As Long, ByVal dwReserved As Long) As Long

'---------CEK IP Adress komputer dan HOST NAME-----

Public Const MAX_WSADescription = 256Public Const MAX_WSASYSStatus = 128'

Public Const ERROR_SUCCESS As Long = 0

Public Const WS_VERSION_REQD As Long = &H101

Public Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF&

Public Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF&

Public Const MIN_SOCKETS_REQD As Long = 1Public Const SOCKET_ERROR As Long = -1

Public Type HostenthName As LonghAliases As LonghAddrType As IntegerhLen As IntegerhAddrList As Long

End Type

Public Type WSADATAwversion As IntegerwHighVersion As IntegerszDescription(0 To MAX_WSADescription) As ByteszSystemStatus(0 To MAX_WSASYSStatus) As BytewMaxSockets As IntegerwMaxUDPDG As IntegerdwVendorInfo As Long

End Type

Public Declare Function WSAGetlastError Lib "wsock32.dll" () As Long

Public Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired As Long, lpWSAdata As WSADATA) As Long

Public Declare Function WSACleanup Lib "wsock32.dll" () As Long

Public Declare Function gethostname Lib "wsock32.dll" (ByVal szHost As String, ByVal dwHostLen As Long) As Long

Public Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal szHost As String) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvdest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)

Public Function GetIPAddress() As String

Dim sHostName As String * 256

Dim lpHost As Long

Dim HOST As Hostent

Dim dwIPAddr As Long

Dim tmpIPAddr() As Byte

Dim i As Integer

Dim sIPAddr As String

If Not SocketsInitialize() Then

GetIPAddress = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPAddress = ""MsgBox "Windows Sockets Error " & Str$(WSAGetlastError()) & " has occurred. Host Name tidak dapat ditampilkan."SocketsCleanup

Exit Function

End If

sHostName = Trim$(sHostName)

lpHost = GetHostByName(sHostName)

If lpHost = 0 Then

GetIPAddress = "" MsgBox "Socket Windows tidak memberikan respon. " & "Host Name tidak dapat ditampilkan." SocketsCleanup

Exit Function

End If

CopyMemory HOST, lpHost, Len(HOST)CopyMemory dwIPAddr, HOST.hAddrList, 4ReDim tmpIPAddr(1 To HOST.hLen)CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLenFor i = 1 To HOST.hLensIPAddr = sIPAddr & tmpIPAddr(i) & "."NextGetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)SocketsCleanup

End Function

Public Function GetIPHostName() As StringDim sHostName As String * 256If Not SocketsInitialize() ThenGetIPHostName = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR ThenGetIPHostName = ""MsgBox "Windows Sockets Error " & Str$(WSAGetlastError()) & " has occurred. Host Name tidak dapat ditampilkan."SocketsCleanup

Exit Function

End IfGetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)SocketsCleanup

End Function

Public Function HiByte(ByVal wParam As Integer)HiByte = wParam \ &H100 And &HFF&

End Function

Public Function LoByte(ByVal wParam As Integer)LoByte = wParam And &HFF&

End Function

Public Sub SocketsCleanup() If WSACleanup() <> error_success_ Then MsgBox " Socket Error terjadi dalam CleanUp."

End If

End Sub

Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

Dim sLoByte As String

Dim sHiByte As StringIf WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS ThenMsgBox "Socket Windows 32-bit tidak respon"SocketsInitialize = False

Exit Function

End If

If WSAD.wMaxSockets = MIN_SOCKETS_REQD Then MsgBox "Aplikasi ini membutuhkan minimum " & CStr(MIN_SOCKETS_REQD) & " Socket yang support." SocketsInitialize = False

Exit Function

End If

If LoByte(WSAD.wversion) < shibyte =" CStr(HiByte(WSAD.wversion))" slobyte =" CStr(LoByte(WSAD.wversion))MsgBox" socketsinitialize =" False">

Exit Function

End If SocketsInitialize = True

End Function

Semoga bermanfaat.
Bagikan

Putar Layar Monitor Secara Flip/Terbalik (Viruskah???)

Sekarang kita akan mencoba membuat program yang agak usil yaitu program yang membuat user keheranan atau malah takut karena program ini akan membuat layar terbalik dan mouse akan menghilang. List di task manager pada tab application juga tidak menunjukan adanya suatu program yang berjalan, kombinasi Alt+Tab dan Alt+F4 juga tidak menyelesaikan masalah, pasti user akan semakin bingung or ketakutan.Jika ditambahi sedikit code registry yang akan membuat program berjalan pada saat windows hidup/startup mungkin akan membuat teman anda atau malah saingan anda menginstal ulang komputernya karena dikira kerjaan virus he..he.., selamat ber-iseng ria. Untuk menormalkan kembali tekan huruf N pada keyboard maka semua akan kembali Normal.Semoga bermanfaat.Program ini merupakan saduran dari buku "Eksplorasi Win32-API dengan Visual Basic" Karya Johan Saputra, terimakasih saya ucapkan pada Mas Johan Saputra, karena tulisan di blog ini sebagian besar yang menyangkut dengan Win32-API merupakan hasil dari pemikiran Mas, yang ada di dalam buku tersebut.


Masukan semua Kode dibawah ini pada form

Private Declare Function GetDC Lib "user32" (ByVal hWND As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hWND As Long, ByVal hWndInsertAfter_ As Long, ByVal X As Long, ByVal y_ As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags_ As Long) As Long
Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long

'Nilai konstan untuk parameter SetWindowPos.
Private Const conHwndTopmost = -1
Private Const conHwndNoTopmost = -2
Private Const conSwpNoActivate = &H10
Private Const conSwpShowWindow = &H40 

Private Sub Form_Load()
Me.AutoRedraw = True 'memastikan Form bisa menampung hasil copy layar.
Me.WindowState = 2 'Maximize.
SelaluTeratas Me.hWND, Me.Left / Screen.TwipsPerPixelX, Me.Top / Screen.TwipsPerPixelY, Me.Height / Screen.TwipsPerPixelY, Me.Width / Screen.TwipsPerPixelX, True
App.TaskVisible = False 'menyembunyikan aplikasi pada task manager (tab Application) tetapi terlihat di tab Process
ShowCursor False 'Sembunyikan cursor.
End Sub 

'Saat Form berubah ukuran (maximize).
Private Sub Form_Resize()
Dim W, H 'Tipe variant.
'Set ukuran rectangle screen.
W = Screen.Width / 15
H = Screen.Height / 15
'kopian layar diambil dan di tampilkan pada Form secara Flip
StretchBlt Me.hdc, 0, H, W, -H, GetDC(0&), 0, 0, W, H, vbSrcCopy
End Sub 

'Fungsi buatan.
Private Function SelaluTeratas(ByVal hWND, FrmX As Long, FrmY As Long, Tinggi As Long, Lebar As Long, ApakahTeratas As Boolean)
If ApakahTeratas = True Then

SetWindowPos hWND, conHwndTopmost, FrmX, FrmY, Lebar, Tinggi, conSwpNoActivate

ElseIf ApakahTeratas = False Then

SetWindowPos hWND, conHwndNoTopmost, FrmX, FrmY, Lebar, Tinggi, conSwpShowWindow
End If

End Function 


'Fungsi buatan untuk Normalisasi seperti keadaan semula.
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)

If KeyCode = vbKeyN Then 'Jika tombol "N" keyboard ditekan.
ShowCursor True
End
End If
End Sub

Semoga bermanfaat.
Download Mal Fungsi Screen

Membuat Aplikasi Edit Registry (150 lebih Tip dan Trik Registry Terintegrasi didalamnya)

Kita akan mencoba membuat aplikasi Edit Registry yang memiliki kemampuan untuk membuka key, membuat key, hapus key dan value, membaca Value Data dengan Tipe RG_SZ, melakukan seting Value kedalam Tipe Value REG_DWORD, REG_SZ DAN REG_BINARY. Ditambah adanya tutorial tip dan trik registry lebih dari 150 tip trik yang terintegrasi didalam aplikasi sehingga dapat langsung dipraktekan.Yang dibutuhkan pada pembuatan aplikasi ini tidak beda dengan aplikasi standar, yaitu textbox, label, commandbutton, checkbox, optionbutton, listbox, image, timer. Lebih jelasnya dapat dilihat pada gambar di bawah ini.


 Ini linknya Edit Registry
Semoga bermanfaat.

Bagikan

Open Close CD Room

Di bawah ini disajikan source code untuk melakukan Open dan Close CD Room, siapa tahu dari code tersebut dapat menginspirasi anda untuk membuat suatu aplikasi yang lebih baru atau lebih kreatif lagi.
Dalam aplikasi ini yang dibutuhkan adalah :
- 3 Commandbutton, dengan properties name Command1, Command2, Command3
- 1 form, dengan properties name form1
- 1 modul, dengan properties name module1

Masukkan Code Dibawah ini pada module1

Option Explicit
    Public Declare Function mciSendString Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long
Public Function OpenCDDoor(ByVal drv As String) As Long
    Dim Alias As String
    Dim retval As Long
    Alias = "Drive" & drv
    retval = -1
    retval = mciSendString("open " & drv & ": type cdaudio alias " & Alias & " wait", vbNullString, 0&, 0&)
    retval = mciSendString("set " & Alias & " door open", vbNullString, 0&, 0&)
    OpenCDDoor = retval
End Function
Public Function CloseCDDoor(ByVal drv As String) As Long
    Dim Alias As String
    Dim retval As Long
    Alias = "Drive" & drv
    retval = -1
    retval = mciSendString("set " & Alias & " door closed", vbNullString, 0&, 0&)
    retval = mciSendString("close " & Alias, vbNullString, 0&, 0&)
    CloseCDDoor = retval
End Function

Masukkan code di bawah inipada form

Private Sub Command1_Click()
OpenCDDoor "G" 'pastikan drive G adalah drive untuk CD/DVD Room, jika bukan G tinggal anda ubah G tersebut menjadi Huruf sesuai dng Drive CD/DVD Room
End Sub
Private Sub Command2_Click()
CloseCDDoor "G" 'pastikan drive G adalah drive untuk CD/DVD Room, jika bukan G tinggal anda ubah G tersebut menjadi Huruf sesuai dng Drive CD/DVD Room
End Sub
Private Sub Command3_Click()
End
End Sub

Semoga bermanfaat.
Download Project Open Close CD-Room

Cek IP Adress Orang Lain Aktif Atau Tidak

Untuk tulisan kali ini disajikan bagaimana cara pembuatan aplikasi yang berfungsi untuk mengetahui status aktif atau tidak akltif dari Komputer tetangga dengan melakukan pencarian IP Adress.Siapa tahu dengan kita mengetahui IP Adress komputer tetangga, kita dapat mencari file, melakukan Shutdown ataupun tujuan positif lainnya he..he..

Yang dibutuhkan dalam pembuatan aplikasi kali ini adalah :
- 1 listbox dengan properties name List1
- 2 textbox dengan propertie name Text1 dan Text2
- 2 commandbutton dengan properties name Command1 dan Command2
- 2 label dengan properties name label1, properties Caption="Cek IP Aktif dari" dan label2 dengan properties caption="Sampai"
Masukkan code di bawah ini pada form

Option Explicit
Const SOCKET_ERROR = 0
Private Declare Function GetHostByName Lib "wsock32.dll" Alias "gethostbyname" (ByVal HostName As String) As Long
Private Declare Function WSAStartup Lib "wsock32.dll" (ByVal wVersionRequired&, lpWSAdata As WSAdata) As Long
Private Declare Function WSACleanup Lib "wsock32.dll" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvdest As Any, hpvSource As Any, ByVal cbCopy As Long)
Private Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
Private Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal HANDLE As Long) As Boolean
Private Declare Function IcmpSendEcho Lib "ICMP" (ByVal IcmpHandle As Long, ByVal DestAddress As Long, ByVal RequestData As String, ByVal RequestSize As Integer, RequestOptns As IP_OPTION_INFORMATION, ReplyBuffer As IP_ECHO_REPLY, ByVal ReplySize As Long, ByVal TimeOut As Long) As Boolean

'type data tambahan
Private Type WSAdata
wVersion As Integer
wHighVersion As Integer
szDescription(0 To 255) As Byte
szSystemStatus(0 To 128) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
ipVendorInfo As Long
End Type

Private Type Hostent
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type

Private Type IP_OPTION_INFORMATION
TTL As Byte
Tos As Byte
Flage As Byte
OptionsSize As Long
OptionsData As String * 128
End Type

Private Type IP_ECHO_REPLY
Address(0 To 3) As Byte
Status As Long
RoundTripTime As Long
DataSize As Integer
Reserved As Integer
data As Long
Options As IP_OPTION_INFORMATION
End Type

Public dir As String
Public Function doPing(ByVal HostName As String) As Boolean
Dim hFile As Long, lpWSAdata As WSAdata
Dim hHostent As Hostent, AddrList As Long
Dim Address As Long, rIP As String
Dim OptInfo As IP_OPTION_INFORMATION
Dim EchoReply As IP_ECHO_REPLY

Call WSAStartup(&H101, lpWSAdata)

If GetHostByName(HostName + String(64 - Len(HostName), 0)) <> SOCKET_ERROR Then
CopyMemory hHostent.h_name, ByVal GetHostByName(HostName + String(64 - Len(HostName), 0)), Len(hHostent)
CopyMemory AddrList, ByVal hHostent.h_addr_list, 4
CopyMemory Address, ByVal AddrList, 4
End If
hFile = IcmpCreateFile()

If hFile = 0 Then
MsgBox " Unable to create file handle", vbCritical + vbOKOnly
doPing = False
Exit Function
End If

OptInfo.TTL = 255
If IcmpSendEcho(hFile, Address, String(32, "A"), 32, OptInfo, EchoReply, Len(EchoReply) + 8, 2000) Then
rIP = CStr(EchoReply.Address(0)) + "." + CStr(EchoReply.Address(1)) + "." + CStr(EchoReply.Address(2)) + "." + CStr(EchoReply.Address(3))
Else
doPing = False
End If

If EchoReply.Status = 0 Then
doPing = True
Else
doPing = False
End If

Call IcmpCloseHandle(hFile)
Call WSACleanup
End Function 

Private Sub Command1_Click()
Dim i As Integer
Dim x, y
Dim result As Boolean
Dim resultString As String

If Trim(Text1) = "" Then
MsgBox "Isikan Alamat IP", vbCritical + vbOKOnly
Text1.SetFocus
Exit Sub
End If

If Trim(Text2) = "" Then
MsgBox "Isikan Batasan/Range Alamat IP", vbCritical + vbOKOnly
Text2.SetFocus
Exit Sub
End If
List1.Clear
x = Split(Text1.Text, ".")
y = Split(Text2.Text, ".")
For i = CInt(x(3)) To CInt(y(3))
dir = x(0) & "." & x(1) & "." & x(2) & "." & i
result = doPing(dir)
If result = True Then
resultString = "Aktif"
Else
resultString = "NonAktif"
End If
List1.AddItem "Pinging " & dir & "..." & resultString
List1.Refresh
Next
End Sub 

Private Sub Command2_Click()
List1.Clear
Text1.Text = ""
Text2.Text = ""
List1.Refresh
End Sub

Terimakasih, semoga bermanfaat.
 Download Cek IP Aktif

Menambah Sound Wav Pada Aplikasi misal Sound Pada Tombol

Tambahkan Sound Wave pada aplikasi anda agar aplikasi akan terlihat lebih menarik.Misal command buttons yang berbunyi pada saat diklik.

Untuk proyek kita kali ini membutuhkan controll, yaitu :
- 2 text box dengan propertis name text1 dan text2
- 4 command buttons dengan properties namenya standar/default tanpa perubahan.
- 3 label dengan properties name default
- contoh-contoh file sound wav yang diletakan di luar aplikasi
- timer dengan properties name timer1 dan dengan interval 100.

Tuliskan code di bawah ini pada modul

Declare Function sndPlaySound Lib "winmm.dll" Alias "sndPlaySoundA" _
(ByVal lpszSoundName As String, ByVal uFlags As Long) As Long
Const SND_SYNC = &H0
Const SND_ASYNC = &H1
Const SND_NODEFAULT = &H2
Const SND_LOOP = &H8
Const SND_NOSTOP = &H10 

Sub PlayWaveSoundOkExit_Click()
soundfile$ = "audio\rain_tag_water.wav"
wFlags% = SND_ASYNC Or SND_NODEFAULT
HaHa = sndPlaySound(soundfile$, wFlags%)
End Sub 

Sub StopTheSound_Click()
StopTheSoundNOW = sndPlaySound(soundfile$, wFlags%)
End Sub 

Sub PlayWaveSoundIntro_Click()
soundfile$ = "audio\a_sparrow.wav"
wFlags% = SND_ASYNC Or SND_NODEFAULT
HaHa = sndPlaySound(soundfile$, wFlags%)
End Sub 

Sub PlayWaveSoundLblTxt_Click()
soundfile$ = "audio\e_twigs.wav"
wFlags% = SND_ASYNC Or SND_NODEFAULT
HaHa = sndPlaySound(soundfile$, wFlags%)
End Sub 

Sub PlayWaveSoundAyam_Click()
soundfile$ = "audio\Ayam berkokok.wav"
wFlags% = SND_ASYNC Or SND_NODEFAULT
HaHa = sndPlaySound(soundfile$, wFlags%)
End Sub

Tuliskan code di bawah ini pada Form

Private Sub Command1_Click()
PlayWaveSoundOkExit_Click
End
End Sub
Private Sub Command2_Click()
PlayWaveSoundAyam_Click
End Sub
Private Sub Command3_Click()
StopTheSoundNOW = sndPlaySound(soundfile$, wFlags%)
End Sub
Private Sub Command4_Click()
PlayWaveSoundOkExit_Click
Timer1.Enabled = False
Command2.Visible = True
Command3.Visible = True
Command4.Visible = False
Command1.Visible = True
End Sub
Private Sub Form_Load()
PlayWaveSoundIntro_Click
MsgBox "Sound Wav Intro telah berbunyi, selanjutnya Sound Wav saat menekan Ok", vbOKOnly, "Info"
PlayWaveSoundOkExit_Click
End Sub
Private Sub Text1_Change()
PlayWaveSoundLblTxt_Click
End Sub
Private Sub Text2_Change()
PlayWaveSoundLblTxt_Click
End Sub
Private Sub Timer1_Timer()
If Not Text1.Text = "" And Not Text2.Text = "" Then
Command4.Visible = True
Else
Command4.Visible = False
End If
If Label3.ForeColor = &HFFFFFF Then
Label3.ForeColor = &H80000008
Else
Label3.ForeColor = &HFFFFFF
End If
End Sub

Terimakasih, semoga bermanfaat.
Download Menambah Sound Wav