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

Membuat form menjadi tembus pandang

Jika kalian ingin membuat form menjadi tembus pandang mungkin artikel berikut bisa sebagai referensi, dengan memanfaatkan fungsi API dari windows penulis akan mencoba membuat tampilan form menjadi terlihat transparan.
Berikut preview dari form yang sudah dijalankan

Nah ini untuk scriptnya codenya :
'script code untuk form-nya
Private Sub Form_Load()
Dim bool As Boolean
GetWindowsVersion bool
If Not bool Then
MsgBox "Diperlukan Sistem Operasi Windows 2000 atau Lebih" & vbCrLf & "Program dibatalkan", , "Perhatian"
End
End If
SetLayeredWindow Me.hWnd, True
SetLayeredWindowAttributes Me.hWnd, 0, (255 * 70) / 100, LWA_ALPHA
End Sub

'script code untuk module-nya
Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (lpVersionInformation As OSVERSIONINFO) As Long
Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Declare Function UpdateLayeredWindow Lib "user32.dll" (ByVal hWnd As Long, ByVal hdcDst As Long, pptDst As Any, psize As Any, ByVal hdcSrc As Long, pptSrc As Any, crKey As Long, ByVal pblend As Long, ByVal dwFlags As Long) As Long

Public Type POINTAPI
x As Long
y As Long
End Type

Public Type SIZE
cx As Long
cy As Long
End Type

Public Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Public Const GWL_STYLE = (-16)
Public Const GWL_EXSTYLE = (-20)
Public Const WS_EX_LAYERED = &H80000
Public Const ULW_COLORKEY = &H1
Public Const ULW_ALPHA = &H2
Public Const ULW_OPAQUE = &H4
Public Const AC_SRC_OVER = &H0
Public Const AC_SRC_ALPHA = &H1
Public Const AC_SRC_NO_PREMULT_ALPHA = &H1
Public Const AC_SRC_NO_ALPHA = &H2
Public Const AC_DST_NO_PREMULT_ALPHA = &H10
Public Const AC_DST_NO_ALPHA = &H20
Public Const LWA_COLORKEY = &H1
Public Const LWA_ALPHA = &H2

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 Const VER_PLATFORM_WIN32_WINDOWS = 1
Public Const VER_PLATFORM_WIN32_NT = 2


Public Function IsLayeredWindow(ByVal hWnd As Long) As Boolean
Dim WinInfo As Long

WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
If (WinInfo And WS_EX_LAYERED) = WS_EX_LAYERED Then
IsLayeredWindow = True
Else
IsLayeredWindow = False
End If
End Function

Public Sub SetLayeredWindow(ByVal hWnd As Long, _
ByVal bIsLayered As Boolean)
Dim WinInfo As Long

WinInfo = GetWindowLong(hWnd, GWL_EXSTYLE)
If bIsLayered = True Then
WinInfo = WinInfo Or WS_EX_LAYERED
Else
WinInfo = WinInfo And Not WS_EX_LAYERED
End If
SetWindowLong hWnd, GWL_EXSTYLE, WinInfo
End Sub

' ambil deskripsi sistem operasi
Public Function GetWindowsVersion(ByRef IsWin2000 As Boolean) As String
Dim TheOS As OSVERSIONINFO
Dim strCSDVersion As String

TheOS.dwOSVersionInfoSize = Len(TheOS)
GetVersionEx TheOS
Select Case TheOS.dwPlatformId
Case VER_PLATFORM_WIN32_WINDOWS
If TheOS.dwMinorVersion >= 10 Then
GetWindowsVersion = "Windows 98 version: "
Else
GetWindowsVersion = "Windows 95 version: "
End If
Case VER_PLATFORM_WIN32_NT
GetWindowsVersion = "Windows NT version: "
End Select

' uraikan informasi tambahan dari string dengan null char
If InStr(TheOS.szCSDVersion, Chr(0)) <> 0 Then
strCSDVersion = ": " & Left(TheOS.szCSDVersion, InStr(TheOS.szCSDVersion, Chr(0)) - 1)
Else
strCSDVersion = ""
End If
GetWindowsVersion = GetWindowsVersion & TheOS.dwMajorVersion & "." & _
TheOS.dwMinorVersion & " (Build " & TheOS.dwBuildNumber & strCSDVersion & ")"

' set dalam mode parameter ByRef
If TheOS.dwMajorVersion = 5 Then
IsWin2000 = True
Else
IsWin2000 = False
End If
End Function

Oke deeh silakan kalian mengembangkan tampilan form sesuai dengan ide kalian masing2, maaf kalo penulis terlalu simple memberikan contoh2 pembahasanya karena penulis juga masih amatiran...so kita sharing bareng disini...Oke? yang pasti tetap semangat!!!
oiya yang mo download source code disini

Menghitung selisih hari menggunakan DTPICKER

Kemaren ada yang bertanya kepada penulis tentang bagaimana cara melihat selisih hari jika menggunakan komponen DTpicker, untuk itu penulis akan mencoba membahasnya biar vbthok mania yg pemula juga tahu, untuk yang sudah expert kyknya gak perlu deh..hehehe
Berikut ini tampilan formnya


Sebetulnya sangat mudah menghitung hari berdasarkan DTPicker ataupun menggunakan textbox so jangan dibikin pusing ya..hehehe
ini untuk script codenya..

Private Sub DTPicker2_CloseUp()
Text1.Text = DTPicker2.Value - DTPicker1.Value
End Sub

weedewwww cuma segitu aja script codenya?? yaiyalah kan gampang bgt, hehehe...
So silakan berekspresi dengan VB dan tetep SEMANGAT!!!

Teknik mengurutkan data

Dalam pembuatan aplikasi sebuah program biasanya memiki teknik pengurutan data yang berbeda beda, untuk itu penulis mencoba mengangkat topik ini sebagai bahan referensi bagi vbthok mania khususnya programmer pemula, untuk yang sudah advance kayaknya ini topik terlalu mudah. Jadi sowry yaa…hehehe…

Berikut ini komponen yang harus diaktifkan

Microsoft DataGrid Control 6.0 (OLEDB)

Microsoft ActiveX Data Objects 2.1 Library

Oiya jangan lupa buat database dari microsoft acces yang terdiri field nama dan nilai ipk.

Kemudian buatlah form seperti tampilan yang dibuat penulis berikut

Kemudian tuliskan scriptnya berikut

Option Explicit

Dim cn As New ADODB.Connection

Dim rs As New ADODB.Recordset

Private Sub Casc_Click()

'membuat koneksi baru pada databese ipk

Dim cn2 As New ADODB.Connection

Dim rs As New ADODB.Recordset

cn2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ipk.mdb;Persist Security Info=False"

cn2.Open

rs.CursorLocation = adUseClient

'mengurutkan data secara Ascending, pertama seleksi dimulai dari field ipk lalu kemudian field nama

rs.Open "select * from nilai order by ipk asc,nama", cn2, adOpenDynamic, adLockOptimistic

'mengkoneksikan record ke DataGrid

Set DataGrid1.DataSource = rs

End Sub

Private Sub CDesc_Click()

'membuat koneksi baru pada databese ipk

Dim cn3 As New ADODB.Connection

Dim rs As New ADODB.Recordset

cn3.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ipk.mdb;Persist Security Info=False"

cn3.Open

rs.CursorLocation = adUseClient

'mengurutkan data secara Descending, pertama seleksi dimulai dari field ipk lalu kemudian field nama

rs.Open "select * from nilai order by ipk desc,nama", cn3, adOpenDynamic, adLockOptimistic

'mengkoneksikan record ke DataGrid

Set DataGrid1.DataSource = rs

End Sub

Private Sub Form_Load()

'mengkoneksikan dan membuka database ipk

cn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ipk.mdb;Persist Security Info=False"

cn.Open

rs.CursorLocation = adUseClient

rs.Open "nilai", cn, adOpenDynamic, adLockOptimistic

'mengkoneksikan record ke DataGrid

Set DataGrid1.DataSource = rs

End Sub

Bagi yang tidak ingin ribet silakan download source codenya disini

Teknik Perulangan atau Looping pada Visual Basic

Kali ini penulis coba angkat topik teori perulangan, kemaren sempet ada yang menanyakan hal ini kepada penulis akhirnya penulis ingin membahasnya.

Loop adalah proses perulangan yang mengerjakan satu atau lebih statement. Loop diperlukan untuk mengerjakan suatu proses operasi secara tahap demi tahap dengan nilai variabel yang menaik atau menurun.

Bila digambarkan aliran loop seperti gambar berikut

Function Do…Loop

Fungsi ini digunakan untuk mengulang blok statement bila kondisi benar atau sampai kondisi menjadi benar. Bila tidak ada perintah keluar fungsi loop akan terus berjalan.

Contoh sintaksnya sebagai berikut

Do [while|until] kondisi

Statement

Exit do

Statement

Loop

Nah sebagai contoh dalam pemrogramannya seperti berikut :

Coba buat 1 project dengan 1 form kemudian isikan script berikut

Private sub form_load()

Dim stptrs, bilrndm, helpfile, context

Do until stptrs = vbno

Bilrndm = int(3 * rnd + 1)

Stptrs = msgbox (“berhenti/lanjut?”, vbyesno, “bilangan random: “&bilrndm, helpfile, context)

Loop

End sub

Nah berikut hasil dari tampilan tersebut

Oke Silakan kalian kembangkan funtion loop ini secara maksimal dengan cara yang kalian inginkan…dan tetap semangat buat belajar

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
Terimakasih

Menjalankan Visual Basic di LINUX

Bagaimana untuk menjalankan program visual basic di linux?? untuk memulainya kalian harus menginstall Wine di sypnatic setelah terinstall baru kemudian masuk ke setting wine dengan masuk ke wine configuration kemudian ikuti langkah berikut

1. Salin riched20.dll, riched32.dll, urlmon.dll, oleaut32.dll, dan hhctrl.ocx dari direktori system32 di windows xp kemudian paste di direktori wine system32 yang ada di linux tersebut.

2. Dalam dialog konfigurasi wine, di bawah tab libraries, setting files yang ada di menu native dengan meng-Add file berikut :

hhctrl.ocx

oleaut32

riched20

riched32

urlmon

Dan ini untuk menetapkan builtin:

ole32

rpcrt4

3. Setting Windows emulation menjadi Windows ME

4. Run the installer normally, ignoring the OLE and Java error messages. Jalankan installer seperti biasa, abaikan OLE Java dan pesan kesalahan. Jika diinginkan, MSDN libraries juga dapat diinstal. Setelah instalasi, setting windows emulation kembali dari windows ME ke Windows XP.

5. Buka terminal dan browse ke direktori wine system32 ) kemudian Jalankan perintah berikut dalam consol linux : wine regsvr32 comcat.dll (ini akan memperbaiki VB6 OLE subsistem)

6. Setelah komponen sudah dimasukkan dan MSDN libraries telah terinstal. Proses Instalasi bisa dilaksanakan dengan masuk ke console kemudian ketik wine setup.exe dimana program visual basic berada.

Selamat mencoba semoga berhasil...

Membuat Task manager sendiri

Task Manager merupakan tool kecil pemantau kinerja Windows. Berbagai aplikasi yang berjalan bisa dilihat dari tool ini. Apabila ada program yang error kita bisa menghentikan program tersebut secara manual lewat task manager dengan menekan tombol end task.Tapi apa jadinya jika pada saat kita coba menjalankan dengan task manager muncul pesan "Task manager has been disable by administrator" pasti repot kan??
Nah kali ini penulis mencoba membuat task manager sendiri,hehehe..bisa untuk mengakali ketika diwarnet lohh...upss...jadi ngajarin yang gak bener neh..sowry2 kita berbuat yang halal aja ya?
Berikut ini bentuk form nya

berikut script kodenya :

Option Explicit

Dim hWndTGT As Long

Private Sub cmdEndTsk_Click()
If hWndTGT = 0 Then Exit Sub

'Kirim pesan close pada handle window yang dipilih
SendMessage hWndTGT, &H112, &HF060, 0
End Sub

Private Sub cmdRefresh_Click()
Dim hWndx As Long
Dim lpStr As String * 255
Dim cnt As Integer
Dim lpClassName As String * 255

'bersihkan isi List1
List1.Clear

'cari nilai Handle Window Desktop
hWndx = FindWindowEx(0, 0, vbNullString, vbNullString)
Do
'dapatkan text dari nilai handle window
GetWindowText hWndx&, lpStr, 255

'dapatkan nama Class dari nilai handle window
GetClassName hWndx&, lpClassName$, 255

If chk1.Value And chk2.Value Then
GoTo IsiData
ElseIf chk1.Value Then
If IsWindowVisible(hWndx) Then
GoTo IsiData
End If
ElseIf chk2.Value Then
If Not IsWindowVisible(hWndx) Then
GoTo IsiData
End If
End If

Ulangi:
'cari nilai handle selanjutnya
hWndx = FindWindowEx(0, hWndx, vbNullString, vbNullString)
DoEvents
Loop While hWndx > 0 'lakukan perulangan hingga tidak ditemukan lagi
'window
Exit Sub
IsiData:
'catat jumlah data yang telah ada pada listBox
cnt = List1.ListCount
'isi ke list berupa nama window dan nama class nya
List1.AddItem Left$(lpStr, lstrlen(lpStr)) + " (" + _
Left$(lpClassName, lstrlen(lpClassName)) + ")"
'isikan nilai hWndx pada itemData
List1.ItemData(cnt) = hWndx
GoTo Ulangi
End Sub

Private Sub cmdToggle_Click()
'Bila window tampak maka
If IsWindowVisible(hWndTGT) Then
'Sembunyikan
ShowWindow hWndTGT, SW_HIDE
Else 'bila tersembunyi maka
'Tampilkan
ShowWindow hWndTGT, SW_SHOW
End If
End Sub

Private Sub Form_Load()

End Sub

Private Sub List1_Click()
'isikan hWndTGT dari nilai handle Window yang dipilih pada ListBox
hWndTGT = List1.ItemData(List1.ListIndex)
End Sub

Untuk modulenya penulis lampirkan bersama file yang bisa didownload disini

Oracle Data Control with Visual Basic

The Oracle Data Control, used with Visual Basic 6, makes creating a dynaset easier, because it does not require you to create the underlying objects. You must set the Connect, DatabaseName, and RecordSource properties. The Oracle Data Control when refreshed, automatically creates a client (if needed), session, database, and dynaset. This section shows two ways to set the properties of the Oracle Data Control to create a dynaset: · by using the Visual Basic Properties window · by programming the properties Setting Oracle Data Control Properties with the Properties Window

1. Start Visual Basic and create a new project.
2. Use the Components option of the Project menu to add "Oracle Data Control" to the project.

The Oracle Data Control will be added to your Visual Basic tool palette and will look like this:



3. To add the Oracle Data Control to a project, simply drag and drop the control onto a form. Resize and position the control. 4. Change the name of the control to ORADataControl. Set up the Connect, DatabaseName, and RecordSource properties as follows to access the Oracle database.



5. When the Oracle Data Control is set up, you can drag and drop a Visual Basic control onto the same form and access the data in the control. Simply set the Data properties to access the data field and source that you want. This figure shows a TextBox control which sets up display of the employee numbers.



6. When the project is run, the data identified by the RecordSource property is displayed using the Oracle Data Control.



You can also use the Microsoft FlexGrid Control to display all the data in the table. You need to add the grid control with the Components option of the Project menu. Setting Oracle Data Control Properties Programmatically The following code fragment demonstrates how to programmatically set the properties of the Oracle Data Control required to create a dynaset. These are the same properties that you can set with the Properties window of Visual Basic.

1. Create a new project and then use the Components option of the Project menu to add "Oracle Data Control" to the project.
2. Drag and drop an Oracle Data Control on a form. Change the name of the control to 'ORADataControl'.
3. After you have inserted an Oracle Data Control onto a form, add the following code to the Load procedure associated with the form.

... 'Set the username and password. ORADataControl.Connect = "scott/tiger" 'Set the database name. ORADataControl.DatabaseName = "ExampleDb" 'Set the record source. ORADataControl.RecordSource = "select * from emp" 'Refresh the data control.
ORADataControl.Refresh ...

You now have a valid client, session, database, and dynaset which can be referenced as follows. object reference client oradatacontrol.database.session.client session oracontrol.database.session database oradatacontrol.database dynaset oradatacontrol.recordset
4. You can access the data in the RecordSource using Visual Basic controls, such as a TextBox as shown in the previous example.

Program Expired atau Shareware

Kali ini penulis akan mencoba membuat program expired/shareware yang berfungsi untuk menonaktifkan program sesuai dengan masa waktu yang sudah kita tentukan, ini adalah sebuah contoh demo yang bisa kalian kembangkan sendiri sesuai ide dan kreasi kalian.
Pemakaiannya mudah, tinggal jalankan program shareware.vbp kemudian sharetest untuk mengetes apa program tersebut sudah dibuat shareware, nah jika sudah habis masa waktunya program meminta no register dan silakan masukkan no register a1234.
Berikut bentuk tampilan programnya



script kodenya sebagai berikut :

'main form shareware

Private Sub Command1_Click()
frmshare.Show

End Sub

Private Sub Command2_Click()
Dim lresult As Long
lresult = DeleteRegKey("\Software\venky", "value")
lresult = DeleteRegKey("\Software\venky", "days")
lresult = DeleteRegKey("\Software\venky", "uses")
lresult = DeleteRegKey("\Software\venky", "lock")
lresult = DeleteRegKey("\Software", "venky")
End Sub

Private Sub Command3_Click()
Unload Me
End Sub


Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim lresult As Long

' Remove the test data from the registry

End Sub

'main form shareware

Private Sub Command1_Click()
Dim lresult As Long
Dim sKey As String
Dim sSubkey As String
Dim sSubkey1 As String
Dim sKeyValue1 As String
sKey = "\Software\venky\shareware"
frmMain.Command2.Enabled = True
If Option1(0).Value = True Then
sSubkey = "days"
If Option2(0).Value = True Then sKeyValue1 = (Date + 30)
If Option2(1).Value = True Then sKeyValue1 = (Date + 15)
If Option2(2).Value = True Then sKeyValue1 = (Date + 1)
lresult = SetRegValue(sKey, sSubkey, sKeyValue1)
lresult = SetRegValue(sKey, "value", Date)
lresult = SetRegValue(sKey, "lock", "true")
End If
If Option1(1).Value = True Then
sSubkey = "uses"
If Option2(3).Value = True Then sKeyValue1 = 1
If Option2(4).Value = True Then sKeyValue1 = 5
If Option2(5).Value = True Then sKeyValue1 = 10
lresult = SetRegValue(sKey, sSubkey, sKeyValue1)
lresult = SetRegValue(sKey, "value", "1")
lresult = SetRegValue(sKey, "lock", "true")
End If
MsgBox "Lock Made"
End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
If Option1(0).Value = True Then
Option2(3).Value = False
Option2(4).Value = False
Option2(5).Value = False
End If
CreateRegKey ("\Software\venky\shareware")
End Sub

Private Sub Option1_Click(Index As Integer)
If Option1(0).Value = True Then
Option2(3).Value = False
Option2(4).Value = False
Option2(5).Value = False
End If
If Option1(1).Value = True Then
Option2(0).Value = False
Option2(1).Value = False
Option2(2).Value = False
End If
End Sub

Private Sub Option2_Click(Index As Integer)
If Option2(2).Value = True Then
Option1(1).Value = False
Option1(0).Value = True
End If
If Option2(1).Value = True Then
Option1(1).Value = False
Option1(0).Value = True
End If
If Option2(0).Value = True Then
Option1(1).Value = False
Option1(0).Value = True
End If
If Option2(3).Value = True Then
Option1(0).Value = False
Option1(1).Value = True
End If
If Option2(4).Value = True Then
Option1(0).Value = False
Option1(1).Value = True
End If
If Option2(5).Value = True Then
Option1(0).Value = False
Option1(1).Value = True
End If
End Sub

'main form testshareware

Dim op4 As Integer
Dim op1 As String

Private Sub Command1_Click()
Unload Me
End Sub

Private Sub Form_Activate()
Dim lresult As Long
Dim sKeyValue As String
Dim op3 As Integer
Dim op As String
Dim op9 As Date
Dim op8 As Date
Dim op10 As Date
Dim op11 As String
lresult = GetRegValue("\Software\venky\shareware", "lock", sKeyValue)
If sKeyValue = "false" Then
Label1.Caption = "Registered Copy'"
Exit Sub
Exit Sub
End If
lresult = GetRegValue("\Software\venky\shareware", "days", sKeyValue)
If Not sKeyValue = "" Then
op = sKeyValue
op9 = op
op8 = Date
lresult = GetRegValue("\Software\venky\shareware", "value", sKeyValue)
op11 = sKeyValue
op10 = op11
If op10 > op8 Then
frmregister.Show
Exit Sub
End If
If op8 < op9 Then
Label1.Caption = (op9 - op8) & " days left"
Exit Sub
Else
frmregister.Show
End If
Else
lresult = GetRegValue("\Software\venky\shareware", "uses", sKeyValue)
op = sKeyValue
op3 = Val(op)
If op3 = 0 Then
MsgBox "Make A Lock First"
Unload frmmain
End If
lresult = GetRegValue("\Software\venky\shareware", "value", sKeyValue)
op1 = sKeyValue
op4 = Val(op1)
If op4 <= op3 Then
Label1.Caption = "This Program has been run " & op1 & " times from a maximum of " & op3 & " times"
Dim op2 As String
op4 = op4 + 1
op2 = op4
lresult = SetRegValue("\Software\venky\shareware", "value", op2)
Else
frmregister.Show
End If
End If
End Sub

'main form register

Private Sub Command1_Click()
If Text1.Text = "" Then
MsgBox "Please Enter Serial no"
Exit Sub
End If
If Text1.Text = "a1234" Then
Dim lresult As Long
lresult = SetRegValue("\Software\venky\shareware", "lock", "false")
If lresult = o Then MsgBox "Registration Successful"
Unload Me
frmmain.Show
Else: MsgBox "Bad Serial No"
End If
End Sub

Private Sub Command2_Click()
Unload Me
Unload frmmain
End Sub

Silakan coba praktekan, untuk module penulis lampirkan pada sourcecode yang bisa didownload disini

Tampilan Menu yang kereen Abezz...

Membuat program agar tampil lebih menawan dan mempunyai daya jual tinggi adalah harapan semua programmer, nah semua itu terletak bagaimana tingkat kerumitan dari program tersebut dibuat, semakin rumit rumus atau logika yang dibuat semakin mahal harga jualnya, Namun tampilan dari suatu program adalah tolak ukur bagi kaum awam yang membeli program yang kita buat.Jika tampilan program yang kita buat tampil menawan meskipun tidak serumit rumus dan logikanya maka harga jualnya juga bisa jadi tinggi. Nah contoh berikut penulis membuat desain form yang menarik plus animasinya...mungkin bisa dijadikan referensi bagi vbthok mania.

Untuk code scriptnya sperti dibawah ini

'untuk main formnya
Option Explicit
Dim mlaku As String
Dim mulai As Integer


Private Sub MDIForm_Activate()
mulai = 0
mlaku = "S E L A M A T D A T A N G"
End Sub

Private Sub Timer1_Timer()
Dim sent As String
mulai = mulai + 1
If mulai > Len(mlaku) Then
mulai = 1
logo.Caption = ""
End If
sent = sent + Mid(mlaku, mulai, 1)


logo.Caption = logo.Caption + sent
End Sub

Private Sub MDIForm_Load()
With RupaToolbar
.ImageList = ImageList1
.Buttons.Item(1).Image = 4
.Buttons.Item(2).Image = 1
.Buttons.Item(3).Image = 15

.Buttons.Item(5).Image = 3
.Buttons.Item(6).Image = 11
.Buttons.Item(7).Image = 14
.Buttons.Item(8).Image = 13
.Buttons.Item(9).Image = 10

.Buttons.Item(11).Image = 16
.Buttons.Item(12).Image = 7
.Buttons.Item(13).Image = 12
.Buttons.Item(14).Image = 2

.Buttons.Item(16).Image = 8
End With

'set toolbar status
RupaToolbar.Visible = GetSetting("Bar", "MDI", "RupaToolbar.Visible", True)
mnuShowToolbar.Checked = GetSetting("Bar", "MDI", "RupaToolbar.Visible", True)
mnuAgent.Checked = GetSetting("Bar", "MDI", "mnuAgent.Checked", True)

Call Init

'Initialize Agent
MyAgent.Characters.Load "Merlin", "Merlin.Acs"
Set myCharacter = MyAgent.Characters("Merlin")

myCharacter.SoundEffectsOn = True

showMerlin
End Sub

Private Sub MDIForm_Unload(Cancel As Integer)
End
End Sub

Private Sub mnuAcct_Click()
frmAccounts.Show 1
End Sub

Private Sub mnuAgent_Click()
mnuAgent.Checked = Not mnuAgent.Checked

SaveSetting "Bar", "MDI", "mnuAgent.Checked", mnuAgent.Checked
showMerlin
End Sub

Private Sub mnuBilling_Click()
frmSales.Show

frmSales.Top = GetSetting("Bar", "frmSales", "Top", (frmMain.Height - frmSales.Height) / 3)
frmSales.Left = GetSetting("Bar", "frmSales", "Left", (frmMain.Width - frmSales.Width) / 2)
End Sub

Private Sub mnuBillingMonitor_Click()
frmBillingMonitor.Show

frmBillingMonitor.Top = GetSetting("Bar", "frmBillingMonitor", "Top", (frmMain.Height - frmBillingMonitor.Height) / 3)
frmBillingMonitor.Left = GetSetting("Bar", "frmBillingMonitor", "Left", (frmMain.Width - frmBillingMonitor.Width) / 2)
End Sub

Private Sub mnuCurrBal_Click()
Dim vAcctName As String
Dim vMsg As String
Dim vAcctNo As Integer
Dim vCurrBal As Single

vAcctNo = frmFind.getKey("Accounts", "AcctName")

If vAcctNo = -1 Then Exit Sub

vAcctName = getAcctDetailsByCode(vAcctNo)!AcctName
vCurrBal = getAcctBalance(vAcctNo)

vMsg = vAcctName & " Has a Balance of Rs : " & IIf(vCurrBal > 0, Format(Abs(vCurrBal), "0.00") & " Dr", Format(Abs(vCurrBal), "0.00") & " Cr")
Merlin vMsg, "Read"
End Sub

Private Sub mnuInward_Click()
ShowInCentre frmInward
End Sub

Private Sub mnuLedger_Click()
ShowInCentre frmLedger
End Sub

Private Sub mnuLoose_Click()
frmLoose.Show 1
End Sub

Private Sub mnuPayment_Click()
frmVoucher.Init ("Payment")
End Sub

Private Sub mnuProduct_Click()
frmProducts.Show 1
End Sub

Private Sub mnuProductUpdate_Click()
ShowInCentre frmProductsUpdate
End Sub

Private Sub mnuQuit_Click()
End
End Sub

Private Sub mnuReceipt_Click()
frmVoucher.Init ("Receipt")
End Sub

Private Sub mnuSalesSummary_Click()
frmDates.Show 1
If datesSelected Then ShowInCentre frmSalesSummary
End Sub

Private Sub mnuShowToolbar_Click()
RupaToolbar.Visible = Not RupaToolbar.Visible
mnuShowToolbar.Checked = Not mnuShowToolbar.Checked

SaveSetting "Bar", "MDI", "RupaToolbar.Visible", RupaToolbar.Visible
End Sub

Private Sub mnuStock_Click()
Call initDtEnv
rptStock.Show
End Sub

Private Sub RupaToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Key
Case "Accounts"
mnuAcct_Click

Case "Products"
mnuProduct_Click

Case "Update_Products"
mnuProductUpdate_Click

Case "Sales"
mnuBilling_Click

Case "Inward"
mnuInward_Click

Case "Receipt"
mnuReceipt_Click

Case "Payment"
mnuPayment_Click

Case "Loose"
mnuLoose_Click

Case "Ledger"
mnuLedger_Click

Case "Stock"
mnuStock_Click

Case "Sales_Summary"
mnuSalesSummary_Click

Case "Billing_Monitor"
mnuBillingMonitor_Click

Case "Quit"
mnuQuit_Click
End Select
End Sub

' untuk form splash nya
'Software license by www.Vbthok.co.cc
'Programmer by ToMee
'2008

Option Explicit

Private Sub Form_Load()

End Sub

Private Sub Timer1_Timer()
Static count As Integer
count = count + 1

If count = 1 Then
lblDisp = "Software Initialized ..."

ElseIf count = 2 Then
lblDisp = "Menyiapkan Database ..."

ElseIf count = 3 Then
lblDisp = "Menyiapkan Aplikasi..."

ElseIf count = 4 Then
lblDisp = "Wait..."

ElseIf count = 5 Then
Timer1.Enabled = False
Unload Me
frmMain.Show
frmWelcome.Show
End If
End Sub

'untuk form welcome nya
'Software license by www.Vbthok.co.cc
'Programmer by ToMee
'2008

Option Explicit

Private Sub Form_Activate()
lblTime = "Login Time : " & Time
lblDate = Format(Date, "dd-MMM-yyyy")

Call popUp
End Sub

Private Sub Form_Load()
Me.Left = Screen.Width - (Me.Width + 60)
Me.Top = Screen.Height - 600 'assumed height for taskbar
End Sub

Private Sub popUp()
Dim h As Integer

h = Me.Height
Me.Height = 0

While Me.Height < height =" Me.Height" top =" Me.Top"> 0
Me.Height = Me.Height - 1
Me.Top = Me.Top + 1
DoEvents
Wend
Unload Me
End Sub

Private Sub Timer1_Timer()
popDown
End Sub

Silakan dicoba dan silakan lihat hasilnya..keren kan?Untuk fungsi modul2nya silakan diliat sendiri dalam paket sorce code yang bisa didownload disini

Membuat Buku Tamu

Program Buku Tamu ini dibuat penulis untuk memberikan contoh kepada vbthok mania supaya dapat mengembangkan ide dari program yang sudah dicontohkan, Bagi yang berpengalaman maaf ini hanya untuk pemula..hehehe...
Tampilan sekilas previewnya seperti ini



dan berikut scriptnya :

Private Sub Command1_Click()
If (Text1.Text <> "") And (Text2.Text <> "") And (Text3.Text <> "") _
And (Text4.Text <> "") Then
Adodc1.RecordSource = "select * from buku"
Adodc1.Refresh
With Adodc1.Recordset
.AddNew
!nama = Text1.Text
!alamat = Text2.Text
!pekerjaan = Text3.Text
!tlp = Text4.Text
.Update
End With
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text1.SetFocus
Else
MsgBox "data yang anda isi belum lengkap !", vbInformation + vbOKOnly, "Simpan"
Text1.SetFocus
End If
End Sub

Private Sub Command2_Click()
If Frame4.Left = 0 Then
Timer4.Enabled = True
If Frame3.Left = 7800 Then Timer1.Enabled = True
Else
If Frame3.Left = 7800 Then Timer1.Enabled = True
End If
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text1.SetFocus
End Sub

Private Sub Command3_Click()
If Frame3.Left = 0 Then
Timer2.Enabled = True
If Frame4.Left = 7800 Then Timer3.Enabled = True
Else
If Frame4.Left = 7800 Then Timer3.Enabled = True
End If
Adodc1.RecordSource = "select * from buku order by nama"
Adodc1.Refresh
Combo1.ListIndex = 0
Combo1.SetFocus
Text5.Text = ""
End Sub

Private Sub Command4_Click()
End
End Sub

Private Sub Command5_Click()
If Frame4.Left = 0 Then
Timer4.Enabled = True
If Frame3.Left = 0 Then Timer1.Enabled = True
End If
If Frame3.Left = 0 Then
Timer2.Enabled = True
If Frame4.Left = 0 Then Timer3.Enabled = True
End If
End Sub

Private Sub Form_Load()
Timer1.Enabled = False
Timer2.Enabled = False
Timer3.Enabled = False
Timer4.Enabled = False
End Sub

Private Sub Text5_Change()
If Combo1.ListIndex = 0 Then
Adodc1.RecordSource = "select * from buku where nama like'%" & _
Text5.Text & "%'"
Adodc1.Refresh

ElseIf Combo1.ListIndex = 1 Then
Adodc1.RecordSource = "select * from buku where alamat like'%" & _
Text5.Text & "%'"
Adodc1.Refresh

ElseIf Combo1.ListIndex = 2 Then
Adodc1.RecordSource = "select * from buku where pekerjaan like'%" & _
Text5.Text & "%'"
Adodc1.Refresh

ElseIf Combo1.ListIndex = 3 Then
Adodc1.RecordSource = "select * from buku where tlp like'%" & _
Text5.Text & "%'"
Adodc1.Refresh
End If
End Sub

Private Sub Timer1_Timer()
Frame3.Left = Frame3.Left - 100
If Frame3.Left = 0 Then Timer1.Enabled = False
End Sub

Private Sub Timer2_Timer()
Frame3.Left = Frame3.Left + 100
If Frame3.Left = 7800 Then Timer2.Enabled = False
End Sub

Private Sub Timer3_Timer()
Frame4.Left = Frame4.Left - 100
If Frame4.Left = 0 Then Timer3.Enabled = False
End Sub

Private Sub Timer4_Timer()
Frame4.Left = Frame4.Left + 100
If Frame4.Left = 7800 Then Timer4.Enabled = False
End Sub

so, mudah bukan...silakan kalian kembangkan sendiri..thanks
Lagi lagi yang gak mo ribet silakan download disini

Billing Wartel

Nah kali ini penulis membuat contoh program billing wartel yang berfungsi menghitung jumlah uang yang harus dikeluarkan berdasarkan waktu yang digunakan untuk telpon. Untuk Penggunaan timer dengan biaya pemakaian bisa kalian atur dengan ide kalian sendiri.
Berikut bentuk form yang sudah dibuat

Dan berikut scriptnya

Dim awal As Date
Dim akhir As Date

Private Sub Cmul_Click()
awal = Time
Timer1.Enabled = True
Timer1.Interval = 1
Cmul.Enabled = False
Csel.Enabled = True
Csel.SetFocus
End Sub

Private Sub Csel_Click()
Timer1.Enabled = False
Cmul.Enabled = True
Csel.Enabled = False
Cmul.SetFocus
End Sub

Private Sub Form_Activate()
Cmul.SetFocus
End Sub

Private Sub Timer1_Timer()
Dim total As Date
Dim bayar As Integer
akhir = Time
total = akhir - awal
bayar = Round(1000000 * total)
Text1.Text = total
Text2.Text = Format(bayar, "Rp #,#")
End Sub

Mudah Sekali bukan?? Silakan kalian coba dan kembangkan sendiri dari contoh yang sudah ada.
Bagi yang tidak mau ambil pusing silakan download programnya disini

Membuat aplikasi pembuat database ( Database Creator )

Kali ini penulis akan membuat aplikasi yang berfungsi untuk membuat database access dengan menggunakan visual basic. Dengan aplikasi ini diharapkan kalian bisa mengembangkan untuk membuat aplikasi yang lebih sempurna dan untuk mempermudah pembuatan database.
Berikut bentuk tampilan form, silakan kalian buat bentuk seperti contoh dibawah ini atau sesuai dengan ide yang kamu kembangkan sendiri.


Nah berikut kode scriptnya :

Dim eng As New DBEngine
Dim db As Database
Dim cn As ADODB.Connection
Dim rs As Recordset
Dim str As String
Dim fname As String
Dim fso As New FileSystemObject
' API DECLARATION OF SLEEP
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
'API FUNCTION TO OPEN OUTLOOK EXPRESS
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 Sub Check1_Click()

If Check1.Value = 0 Then
txtp1.Text = ""
txtp2.Text = ""
txtp1.BackColor = &H80000011
txtp2.BackColor = &H80000011
txtp1.Locked = True
txtp2.Locked = True
lblstrength.Width = 555
lblstrength.BackColor = &H8080FF
lblstrength.Caption = "Low"
Frame3.Visible = False
txtp1.TabStop = False
txtp2.TabStop = False
Else
txtp1.SetFocus
txtp1.BackColor = vbWhite
txtp2.BackColor = vbWhite
txtp1.Locked = False
txtp2.Locked = False
txtp1.TabStop = True
txtp2.TabStop = True
End If
End Sub

Private Sub Check1_LostFocus()
If Check1.Value = 0 Then
txtp1.TabStop = False
txtp2.TabStop = False
ElseIf Check1.Value = 1 Then
txtp1.TabStop = True
txtp2.TabStop = True
End If
End Sub

Private Sub Command1_Click()
On Error GoTo handler
If txtpath <> "" Then
If Check1.Value = 1 Then
validate
Else
create_database
status
str = MsgBox("Do u want to open database ?", vbQuestion + vbYesNo, "Open ?")
If str = vbYes Then ShellExecute Me.hwnd, "open", fname, "", "", 1
End If
Else
MsgBox "Select Path for Creating Database", vbInformation, "No Path..."
Command3.SetFocus
End If
Exit Sub
handler:
If Err.Number = 3204 Then
str = MsgBox("Database already exists" & vbCrLf & "Do U want to Repalce it ?", vbInformation + vbYesNo, "File alredy exists")
If str = vbYes Then
fso.DeleteFile (txtpath)
validate
Exit Sub
Else
txtpath.Text = ""
Command3.SetFocus
End If
Else
MsgBox Err.Description, vbInformation, "Info.."
Exit Sub
End If
End Sub

Private Sub Command2_Click()
On Error GoTo handler
ShellExecute Me.hwnd, "OPEN", "mailto:tomee@indosatcommunity.com ; tom_mee@telkom.net", "", "", 1
Exit Sub
handler:
MsgBox Err.Description, vbInformation, "Info.."
End Sub



Private Sub Command3_Click()
On Error GoTo handler
CommonDialog1.DialogTitle = "Create Database..."
CommonDialog1.Filter = "MS-Access files(*.mdb)|*.mdb"
CommonDialog1.ShowSave
txtpath.Text = CommonDialog1.FileName
Exit Sub
handler:
If Err.Number = 32755 Then
MsgBox "Don't U want to create database ?", vbQuestion, "Quit ?"
Else
MsgBox Err.Description, vbInformation, "Info..."
End If
End Sub

Private Sub Command4_Click()
On Error GoTo handler
ShellExecute Me.hwnd, "open", App.Path & "\notes.txt", "", "", 1
Exit Sub
handler:
MsgBox Err.Description, vbExclamation, "Error"
End Sub

Private Sub CommandButton1_Click()
Unload Me
End Sub

Private Sub Form_Load()
StatusBar1.Panels(2).Text = "STATUS"
txtp1.BackColor = &H80000011
txtp2.BackColor = &H80000011
End Sub


Private Sub status()
Picture1.Visible = True
For i = 0 To 7
Picture1.Picture = LoadPicture(App.Path & "\pics\" & i & ".BMP")
If i < text = "Database Created" text = "Table Created" visible =" False" text = "STATUS"> "" And txtp2.Text <> "" Then
If txtp1.Text <> txtp2.Text Then
MsgBox "Password doesn't match", vbCritical, "Password Mismatch"
txtp1.Text = ""
txtp2.Text = ""
txtp1.SetFocus
Else
create_database
status
str = MsgBox("Do u want to open database ?", vbQuestion + vbYesNo, "Open ?")
If str = vbYes Then ShellExecute Me.hwnd, "open", fname, "", "", 1
End If
Else
If Check1.Value = 1 Then
MsgBox "Password Mandatory", vbCritical, "Blank Password"
If txtp1.Text = "" Then
txtp1.SetFocus
Else
txtp2.SetFocus
End If
Else
create_database
status
str = MsgBox("Do u want to open database ?", vbQuestion + vbYesNo, "Open ?")
If str = vbYes Then ShellExecute Me.hwnd, "open", fname, "", "", 1
End If
End If
End Sub


Private Sub Return_to_normal()
txtp1.Text = ""
txtp2.Text = ""
txtpath.Text = ""
txtpath.SetFocus
Check1.Value = 0
Check1_Click
lblstrength.Width = 555
lblstrength.BackColor = &H8080FF
lblstrength.Caption = "Low"
Frame3.Visible = False
End Sub

Private Sub mnuabout_Click()
Form2.Show , Me
End Sub

Private Sub mnume_Click()
Form2.Show , Me
End Sub

Private Sub txtp1_Change()
Frame3.Visible = True
If Len(txtp1.Text) <= 5 Then lblstrength.Width = 555 lblstrength.BackColor = &H8080FF lblstrength.Caption = "Low" ElseIf Len(txtp1.Text) >= 6 And Len(txtp1.Text) <= 10 Then lblstrength.Width = 900 lblstrength.BackColor = &H80FFFF lblstrength.Caption = "Medium" ElseIf Len(txtp1.Text) > 10 Then
lblstrength.Width = 1605
lblstrength.BackColor = &H80FF80
lblstrength.Caption = "Strong"
End If
End Sub

Private Sub create_database()
fname = txtpath.Text
Set db = eng.Workspaces(0).CreateDatabase(txtpath, dbLangGeneral & ";pwd=" & Trim(txtp1.Text) & ";")
db.Close
Set cn = New ADODB.Connection
cn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & txtpath.Text & ";persist security info=true ; jet oledb:database password =" & txtp1.Text & ";"
cn.Execute "create table Sample(empno number,ename text(50),sal number,date_of_birth date,date_of_joining date,constraint pk primary key(empno))"
cn.Close
End Sub

Private Sub txtp1_click()
move_focus
End Sub

Private Sub txtp2_click()
move_focus
End Sub


Private Sub move_focus()
If Check1.Value = 0 Then
Check1.SetFocus
Else
End If
End Sub

Nah selamat mencoba, bagi yang males membuat dan ingin mendownload silakan download disini

Membuat Mouse Bergerak dengan fungsi API

Berikut ini penulis akan membuat sebuah contoh program sederhana yang memanfaatkan fungsi API dan dibuat dengan Visual Basic 6.0 yang akan membuat mouse bergerak gerak.

Langkah-Langkahnya :

1. Buat 1 project baru dengan 1 CommandButton, dan 1 buah timer.
2. Atur interval timer menjadi 100 dan nilai enable dibuat false pada jendela properties.
3. Ketik kode berikut ke dalam code editor form :


Option Explicit
Private Declare Function SetCursorPos Lib “user32″ (ByVal x As Long, ByVal y As Long) As Long

Dim xx As Integer
Dim yy As Integer

Private Type POINTAPI
x As Long
y As Long
End Type

Private Declare Function GetCursorPos Lib “user32″ (lpPoint As POINTAPI) As Long
Dim sh As Integer
Dim sw As Integer

Private Sub Command1_Click()
Timer1.Enabled = True
xx = Rnd * 10 + 1
yy = Rnd * 10 + 1
End Sub

Private Sub Command1_KeyDown(KeyCode As Integer, Shift As Integer)
If vbKeyEscape Then
Timer1.Enabled = False
End If
End Sub

Private Sub Timer1_Timer()
Dim pt As POINTAPI

GetCursorPos pt
’sebelum merubah kordinat posisi kursor, program harus mendapatkan terlebih
’dahulu posisi kursor berada.
sh = (Screen.Height / 15) - 1
sw = (Screen.Width / 15) - 1

If pt.x <= 0 Then xx = -xx
If pt.x >= sw Then xx = -xx
If pt.y <= 0 Then yy = -yy
If pt.y >= sh Then yy = -yy

DoEvents
pt.x = pt.x + xx
pt.y = pt.y + yy

SetCursorPos pt.x, pt.y
Label1.Caption = “Koordinat Posisi Kursor (X, Y): ” & pt.x & ” , ” & pt.y
End Sub

Fungsi API yang digunakan dalam program :

* SetCursorPos, fungsi API SetCursorPos terdapat pada file pustaka user32.dll Fungsi ini berguna untuk merubah kordinat posisi kursor.

Parameter :

x : merupakan suatu point dengan acuan kordinat sumbu x.
y : merupakan suatu point dengan acuan kordinat sumbu y.

* GetCursorPos, fungsi ini berguna untuk mendapatkan kordinat posisi kursor pada layar dengan mengembalikan nilai kordinat posisi (x,y).

Parameter :

lpPoint : merupakan deklarasi struktur POINTAPI yang berguna sebagai penerima kordinat posisi kursor pada layar. Sebelumnya kita harus mendeklarasikan Type POINT API terlebih dahulu.

visual basic + sql server + active report

Ketika kita membangun sebuah aplikasi database, kita tentunya menginginkan perpaduan yang ideal antara bahasa pemrograman, database dan reporting tool. Menurut saya… untuk membangun aplikasi khususnya yang berbasis desktop, komposisi yang paling ideal adalah visual basic 6 + sql server + active report.

Dengan perpaduan tersebut, kita dapat membangun berbagai aplikasi client-server beserta reportingnya tanpa membutuhkan banyak komponen tambahan.
Untuk reporting, sebenarnya paling powerfull adalah menggunakan crystal report. Tetapi, terlalu banyak komponen yang diperlukan saat kita akan mengkompilasi dan membuat installer dari aplikasi kita. Mungkin bagi yang sudah mahir, tidak ada kesulitan dalam hal tersebut. Namun bagi pemula seperti saya tentunya akan kebingungan memilih komponen mana saja yang harus disertakan.
Ok… Langsung aja yach… dalam bagian ini saya akan mencoba berbagi dan menunjukkan pengalaman saya untuk membuat hubungan antara ketiganya.

1. Buat satu database di SQL Server 2000 dan jangan lupa untuk membuat sedikitnya satu table. Sebagai contoh database sekolah dan table siswa.


2. Bagaimana? Sudah kan? Selanjutnya kita akan beralih ke VB 6 dan hal pertama yang harus dibuat adalah modul koneksi dengan database.
3. Buka Project baru VB6 dan tambahkan satu modul ke dalamnya kemudian ketikkan kode berikut :

Public koneksi as adodb.connection
Public sub konekdb()
Set koneksi=new ADODB.connection
With koneksi
.CommandTimeout = 300
.CursorLocation = adUseClient
.ConnectionString = strCon
.Open "Provider=SQLOLEDB.1;" & _
"Data Source=(local);" & _
"Initial Catalog=sekolah;" & _
"User ID=sa;" & _
"Password=passwordsauser;" & _
"Persist Security Info=True;" & _
"OLE DB Services = -2;"
End With
If err.Number Then
MsgBox "Gagal menghubungi komputer Inven!" & vbNewLine & err.Description, vbOKOnly + vbCritical
Exit sub
End If
End sub

O ya.. tambahkan juga reference Microsoft ActiveX Data Objects 2.x Library
4. Tambahkan modul satu lagi untuk menampung kode state form dan kodenya :

Public Enum FormState
adStateAddMode = 0
adStateEditMode = 1
adStatePopupMode = 2
End Enum

5. Kalau sudah kita buka form1 dan letakkan beberapa komponen diantaranya
-1 listview
-5 textbox
-6 command button
-1 masked box
dengan default name nya aja dan atur posisinya seperti ini

6. Create satu active report dengan klik kanan pada project1 pilih add--> Data Dynamics ActiveReports2.0 kemudian tambahkan komponen sebagai berikut :


Dan beberapa label seperti pada gambar ini :

7. Kemudian pada form1 ketikkan kode berikut :

Dim WithEvents rs As ADODB.Recordset
Public state As FormState
Private Sub Command1_Click()
kosongfield
releasefield
Text1.SetFocus
SetButtons False
Me.state = adStateAddMode
End Sub

Private Sub Command2_Click()
releasefield
SetButtons False
Me.state = adStateEditMode
End Sub

Private Sub Command3_Click()
Dim strsqldel As String
On Error Resume Next
strsqldel = "delete from tblsiswa where nis='" & ListView1.SelectedItem.Text & "'"
If ListView1.SelectedItem.Text = "" Then
MsgBox "Tidak ada rekord yang akan dihapus", vbInformation, "Informasi"
Else
X = MsgBox("Apakah anda yakin ingin menghapus data secara permanen? ", vbExclamation + vbYesNo, "konfirmasi")
If X = vbYes Then
koneksi.Execute strsqldel
rs.Requery
Call Form_Load
Else
End If
End If
End Sub

Private Sub Command4_Click()
On Error Resume Next
If Me.state = adStateAddMode Then
strkueri = "insert into tblsiswa values('" & Text1.Text & "', " & _
" '" & Text2.Text & "'," & _
" '" & Text3.Text & "'," & _
" '" & Me.MaskEdBox1.Text & "'," & _
" '" & Text5.Text & "')"
pesan = "Data berhasil ditambahkan"
ElseIf Me.state = adStateEditMode Then
strkueri = "update tblsiswa set nis='" & Text1.Text & "'," & _
" nama= '" & Text2.Text & "', " & _
" tempat_lahir='" & Text3.Text & "'," & _
" tanggal_lahir= '" & MaskEdBox1.Text & "'," & _
" agama= '" & Text5.Text & "'where nis='" & ListView1.SelectedItem.Text & "'"
pesan = "Data berhasil diedit"
End If
koneksi.Execute strkueri
MsgBox "" & pesan, vbInformation, "Informasi"
'refreshrekord
SetButtons True
Call Form_Load
End Sub

Private Sub Command5_Click()
Call Form_Load
End Sub

Private Sub Command6_Click()
End
End Sub

Private Sub Command7_Click()
With ActiveReport1.DataControl1
.CursorLocation = koneksi.CursorLocation
.CursorType = ddADOOpenDynamic
.ConnectionString = koneksi.ConnectionString
.Source = "select * from tblsiswa"
End With
ActiveReport1.Show
End Sub

Private Sub Form_Load()
On Error Resume Next
konekdb
Set rs = New ADODB.Recordset
rs.Open "select * from tblsiswa", koneksi
ListView1.ListItems.Clear
If rs.RecordCount <> 0 Then
filltext
isilist
kuncifield
SetButtons True
Else
End If
End Sub
Sub filltext()
Text1.Text = rs!nis
Text2.Text = rs!nama
Text3.Text = rs!tempat_lahir
MaskEdBox1.Mask = ""
Me.MaskEdBox1.Text = rs!tanggal_lahir
Text5.Text = rs!agama
Dim ListVwItem As MSComctlLib.ListItem
Dim Value As String
Dim Value2 As String
Value = rs!nis
For Each ListVwItem In ListView1.ListItems
If Trim(ListVwItem.Text) = Trim(Value) Then 'find complete words
ListVwItem.Selected = True
ListVwItem.EnsureVisible
Exit For
End If
Next
End Sub
Sub isilist()
On Error Resume Next
With rs
For i = 0 To rs.Fields.Count
ListView1.ColumnHeaders.Add i + 1, , rs.Fields(i).Name
Next i
.MoveFirst
Do While Not .EOF
Set LI = ListView1.ListItems.Add(, , Trim(!nis))
LI.SubItems(1) = Trim(!nama)
LI.SubItems(2) = Trim(!tempat_lahir)
LI.SubItems(3) = Trim(!tanggal_lahir)
LI.SubItems(4) = Trim(!agama)
.MoveNext
Loop

End With
End Sub
Sub kosongfield()
On Error Resume Next
Dim txt As Control
'clear the text boxes
For Each txt In Me
If TypeOf txt Is TextBox Then txt.Text = ""
Next
Me.MaskEdBox1.Text = ""
MaskEdBox1.Mask = "##/##/####"
End Sub
Sub kuncifield()
On Error Resume Next
Dim txt As Control
'Locked the text boxes
For Each txt In Me
If TypeOf txt Is TextBox Then txt.Locked = True
Next
Me.MaskEdBox1.Enabled = False
End Sub
Sub releasefield()
On Error Resume Next
Dim txt As Control
'UnLocked the text boxes
For Each txt In Me
If TypeOf txt Is TextBox Then txt.Locked = False
Next
Me.MaskEdBox1.Enabled = True
End Sub
Sub SetButtons(bVal As Boolean)
Command1.Visible = bVal
Command2.Visible = bVal
Command4.Visible = Not bVal
Command5.Visible = Not bVal
Command3.Visible = bVal
Command6.Visible = bVal
Command7.Visible = bVal
End Sub
Private Sub ListView1_ItemClick(ByVal Item As MSComctlLib.ListItem)
Dim Item2 As ListItem
Set Item2 = ListView1.ListItems.Item(ListView1.SelectedItem.Index)
rs.MoveFirst
'Text1 = UCase(Trim(Text1))
'msgbox""&
rs.Find (" nis = '" & Me.ListView1.SelectedItem & "'")
If rs.AbsolutePosition > 0 Then
filltext
ElseIf rs.AbsolutePosition <>

8. Yang terakhir ketik kode berikut pada active report

Private Sub PageFooter_BeforePrint()
Me.lblpage.Caption = Me.pageNumber
End Sub

Private Sub ReportHeader_BeforePrint()
lbldate.Caption = "Di cetak tanggal : " & Format(Date, "dd/mm/yyyy")
End Sub