Debugers

Setelah sekian lama tidak pernah update kali ini saya akan coba update cara membuat program berbasis clien sever. Program ini merupakan contoh pemrograman client server dengan menggunakan bahasa pemrograman Visual Basic 6.0 dan Microsoft Acces sebagai Database. Program ini dilengkapi dengan operasi record. Sebagai program berbasis sistem informasi, pengguna dapat melakukan pencetakan dengan menggunakan Crystal Report 8.5 sebagai output/laporan. Program ini terdiri atas dua file project, yakni untuk di tempatkan di server dan di sisi client. Mudah-mudahan contoh program ini berguna terutama bagi yang ingin mencoba membuat pemrograman client server.

1. Untuk Server

Tambahkan satu form dan module. Selanjunya copykan listing berikut ini ke dalam form yang telah dipersiapkan sebelumnya

Dim Tampil As ListView
Dim DTM(11) As String
Dim x As Long
Dim Urut As Double

Private Sub cmdQuit_Click()
Unload Me
End Sub

Private Sub Form_Activate()
'menampilkan id client
LblHost.Caption = Socket(0).LocalHostName
LblIP.Caption = Socket(0).LocalIP
Socket(0).LocalPort = 1007
sServerMsg = "Listening to port: " & Socket(0).LocalPort
List1.AddItem (sServerMsg)
Socket(0).Listen
'untuk listview
Lview.GridLines = True
Lview.ListItems.Clear
Lview.View = lvwReport
Lview.ColumnHeaders.Add , , "No Trans", 900
Lview.ColumnHeaders.Add , , "Terima dari", 1300
Lview.ColumnHeaders.Add , , "Uraian", 2600
Lview.ColumnHeaders.Add , , "Kode Akun", 1100
Lview.ColumnHeaders.Add , , "Cara Bayar", 1000
Lview.ColumnHeaders.Add , , "Jumlah (Rp)", 1100
Lview.ColumnHeaders.Add , , "Diterima di", 900
Lview.ColumnHeaders.Add , , "Tanggal", 1000
Lview.ColumnHeaders.Add , , "Penerima", 1000
Call LData
'--------------------------------------
End Sub

Sub LData()
ConnectDb
Rs.Open "select * from [BuktiBayar]", Db, 1, 3
With Rs
If Rs.RecordCount = 0 Then
Set kodok = Lview.ListItems.Add(, , "---")
kodok.SubItems(1) = "---"
kodok.SubItems(2) = "---"
kodok.SubItems(3) = "---"
kodok.SubItems(4) = "---"
kodok.SubItems(5) = "---"
kodok.SubItems(6) = "---"
kodok.SubItems(7) = "---"
kodok.SubItems(8) = "---"
ElseIf .RecordCount > 0 Then
.MoveFirst
Do While Not .EOF
Set kodok = Lview.ListItems.Add(, , ![no transaksi])
kodok.SubItems(1) = ![terima dari]
kodok.SubItems(2) = ![uraian]
kodok.SubItems(3) = ![kode akun]
kodok.SubItems(4) = ![cara bayar]
kodok.SubItems(5) = ![jlh rupiah]
kodok.SubItems(6) = ![Diterima di]
kodok.SubItems(7) = ![Tanggal]
kodok.SubItems(8) = ![penerima]
.MoveNext
Loop
End If
End With
End Sub

Selanjutnya untuk module copykan listing berikut ini:
‘--- ini untuk menghubungkan database

Public Db As ADODB.Connection
Public Rs As ADODB.Recordset

Public Function ConnectDb() As Boolean
On Error GoTo DC
Set Db = New ADODB.Connection
Set Rs = New ADODB.Recordset
Db.CursorLocation = adUseClient

Db.Open "PROVIDER=MSDataShape;Data PROVIDER=Microsoft.Jet.OLEDB.4.0;" & _
"Persist security Info=false;Data source=" & App.Path & "\dbtiram.mdb;"
Exit Function
DC:
MsgBox Err.Number + " " + Err.Description, vbOKOnly, "Disconnect"

End Function


Tambahkan satu form, satu module, dan satu file crystal report. Kemudian copykan listing berikut ini di form


Dim Tampil As ListView
Dim nou(2) As String
Dim nomor, J1 As Byte
Private Sub CmdCancel_Click()
Call ResetForm(Me)
LblNoTrans.Caption = ""
CmdCancel.Enabled = False
CmdNew.Enabled = True
CmdSave.Enabled = False
CmdPreview.Enabled = False

End Sub

Private Sub CmdConnect_Click()

If CmdConnect.Caption = "&Connect" Then
Winsock1.RemoteHost = "10.16.184.33" ' rubah ip ini menjadi ip server
Winsock1.RemotePort = 1007
Winsock1.Connect
LblCon.Caption = "Connect to server"
Tombol (1)
Me.Caption = "Connect to Server"
CmdConnect.Caption = "&Disconnect"
ElseIf CmdConnect.Caption = "&Disconnect" Then
LblCon.Caption = "Unavailable Connection to server"
Me.Caption = "Unavailable Connection to server"
Winsock1.Close
CmdConnect.Caption = "&Connect"
End If


End Sub


Private Sub cmdEdit_Click()
CmdSave.Caption = "&Update"
End Sub

Private Sub CmdNew_Click()
If Left(Me.Caption, 2) = "Un" Then
MsgBox "Tidak terkoneksi ke server" & Chr(13) _
& "Klik tombol connect terlebih dahulu untuk " _
& "mengkoneksikan ke server", vbOKOnly, "Disconnect"
CmdSave.Caption = "&Save"
Else
CmdNew.Enabled = False
CmdCancel.Enabled = True
CmdSave.Enabled = True

CmdPreview.Enabled = True
Frame1.Enabled = True
Call ResetForm(Me)
'---ambil nomor transaksi dari server
If Winsock1.State = sckConnected Then
Winsock1.SendData "no~"
LblCon.Caption = "Sending Data"
End If


'ambil nomor terakhir dari tabel nomor
'ConnectDb
'Rs.Open "select * from nomor", Db, 1, 3
'If Rs.RecordCount = 0 Then
' no = 1
'ElseIf Rs.RecordCount > 0 Then
' Rs.MoveLast
' no = Rs!nourut + 1
' LblNoTrans.Caption = no
'End If
End If
End Sub
'


Private Sub CmdPreview_Click()
Dim tgl As String
t1 = Format(TxtTgl.Value, "dd mmmm yyyy")
tgl = TxtDiterima.Text & ", " & t1
Cr1.ReportFileName = App.Path & "\reports\bukti_bayar[1].rpt"
'Cr1.ReplaceSelectionFormula "{bukti pembayaran.no transaksi}='" & LblNoTrans.Caption & "'"
Cr1.Formulas(0) = "bterima='" & txtterima.Text & "'"
Cr1.Formulas(1) = "buraian='" & TxtUraian.Text & "'"
Cr1.Formulas(2) = "blg='" & TxtTerbilang.Caption & "'"
Cr1.Formulas(3) = "blg='" & TxtTerbilang.Caption & "'"
Cr1.Formulas(4) = "bkdakun='" & TxtKdAkun.Text & "'"
Cr1.Formulas(5) = "bc_byr='" & TxtDibayarDng.Text & "'"
Cr1.Formulas(6) = "b_tgl='" & tgl & "'"
Cr1.Formulas(7) = "b_penerima='" & TxtPenerima.Text & "'"


'Item.SubItems(1)
' Cr1.PrintReport
Cr1.WindowState = crptMaximized
Cr1.Action = 1
'
'ErrPrint:
' MsgBox Err.Number & " " & Err.Description, vbCritical, "Error Print"
' End If
' Next


End Sub

Private Sub cmdQuit_Click()
Winsock1.Close
Unload Me
End Sub


CmdPreview.Enabled = True
If Winsock1.State = sckConnected Then
Winsock1.SendData "s~" & LblNoTrans.Caption & "~" & txtterima.Text _
& "~" & TxtUraian.Text & " " & "~" & TxtKdAkun.Text & "~" _
& TxtDibayarDng.Text & "~" & TxtRp.Text & "~" & TxtTerbilang.Caption & "~" _
& TxtDiterima.Text & "~" & TxtTgl.Value & "~" & TxtPenerima.Text
LblCon.Caption = "Sending Data"



Else
LblCon.Caption = "Not currently connected to host"
End If

Form_Activate
End Sub

Sub Tombol(aktif As Boolean)
CmdNew.Enabled = aktif
CmdSave.Enabled = aktif

End Sub


Private Sub Form_Activate()
'koneksi ke server

Tombol (0)
CmdConnect.Enabled = True
End Sub

Private Sub Form_Load()
Frame1.Enabled = False
CmdNew.Enabled = True
CmdNew.Visible = True
CmdSave.Enabled = False

' CmdPreview.Enabled = False
CmdCancel.Enabled = False
LblNoTrans.Caption = ""


End Sub



Private Sub txtRp_Change() 'Isi besar uang diulangi dengan terbilang huruf...
If Len(TxtRp.Text) = 0 Then
Exit Sub
ElseIf Len(TxtRp.Text) > 0 Then
TxtTerbilang.Caption = "## " & UCase(TerbilangDesimal(TxtRp.Text)) & " RUPIAH ##"
End If
End Sub

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim sData As String
Winsock1.GetData sData, vbString
'Label1.Caption = sData
'kalau record tidak ada
'For J1 = 0 To 1
st = Split(sData, "~")
If Mid(st(0), 1, 2) = "no" Then
'MsgBox "record tidak ditemukan"
LblNoTrans.Visible = True
LblNoTrans.Caption = st(1)
Else 'If Mid(st(0), 1, 1) = "S" Then
MsgBox "Data terupdate"
End If
End Sub


‘selanjutnya tambahkan baris berikut ini di module
‘ini fungsi terbilang
Public Function TerbilangDesimal(InputCurrency As String, _
Optional MataUang As String = "rupiah") As String
Dim strInput As String
Dim strBilangan As String
Dim strPecahan As String
On Error GoTo pesan
Dim strValid As String, huruf As String * 1
Dim i As Integer
'Periksa setiap karakter yg diketikkan ke kotak UserID
strValid = "1234567890,"
For i% = 1 To Len(InputCurrency)
huruf = Chr(Asc(Mid(InputCurrency, i%, 1)))
If InStr(strValid, huruf) = 0 Then
Set AngkaTerbilang = Nothing
MsgBox "Harus karakter angka!", _
vbCritical, "Karakter Tidak Valid"
Exit Function
End If
Next i%

If InputCurrency = "" Then Exit Function
If Len(Trim(InputCurrency)) > 15 Then GoTo pesan

strInput = CStr(InputCurrency) 'Konversi ke string
'Periksa apakah ada tanda "," jika ya berarti pecahan
If InStr(1, strInput, ",", vbBinaryCompare) Then

strBilangan = Left(strInput, InStr(1, strInput, ",", vbBinaryCompare) - 1)
'strBilangan = Right(strInput, InStr(1, strInput, ".", vbBinaryCompare) - 2)
strPecahan = Trim(Right(strInput, Len(strInput) - Len(strBilangan) - 1))

If MataUang <> "" Then


If CLng(Trim(strPecahan)) > 99 Then
strInput = Format(Round(CDbl(strInput), 2), "#0.00")
strPecahan = Format((Right(strInput, Len(strInput) - Len(strBilangan) - 1)), "00")
End If

If Len(Trim(strPecahan)) = 1 Then
strInput = Format(Round(CDbl(strInput), 2), "#0.00")
strPecahan = Format((Right(strInput, Len(strInput) - Len(strBilangan) - 1)), "00")
End If

If CLng(Trim(strPecahan)) = 0 Then
TerbilangDesimal = (KonversiBilangan(strBilangan) & MataUang & " " & KonversiBilangan(strPecahan))
Else
TerbilangDesimal = (KonversiBilangan(strBilangan) & MataUang & " " & KonversiBilangan(strPecahan) & "sen")
End If
Else
TerbilangDesimal = (KonversiBilangan(strBilangan) & "koma " & KonversiPecahan(strPecahan))
End If

Else

TerbilangDesimal = (KonversiBilangan(strInput))

End If
Exit Function
pesan:
TerbilangDesimal = "(maksimal 15 digit)"
End Function


'Fungsi ini untuk mengkonversi nilai pecahan (setelah angka 0)
Private Function KonversiPecahan(strAngka As String) As String
Dim i%, strJmlHuruf$, Urai$, Kar$
If strAngka = "" Then Exit Function
strJmlHuruf = Trim(strAngka)
Urai = ""
Kar = ""
For i = 1 To Len(strJmlHuruf)
'Tampung setiap satu karakter ke Kar
Kar = Mid(strAngka, i, 1)
Urai = Urai & Kata(CInt(Kar))
Next i
KonversiPecahan = Urai
End Function
'Fungsi ini untuk menterjemahkan setiap satu angka ke kata
Private Function Kata(angka As Byte) As String
Select Case angka
Case 1: Kata = "Satu "
Case 2: Kata = "Dua "
Case 3: Kata = "Tiga "
Case 4: Kata = "Empat "
Case 5: Kata = "Lima "
Case 6: Kata = "Enam "
Case 7: Kata = "Tujuh "
Case 8: Kata = "Delapan "
Case 9: Kata = "Sembilan "
Case 0: Kata = "Nol "
End Select
End Function
'Ini untuk mengkonversi nilai bilangan sebelum pecahan
Private Function KonversiBilangan(strAngka As String) As String
Dim strJmlHuruf$, intPecahan As Integer, strPecahan$, Urai$, Bil1$, strTot$, Bil2$
Dim X, Y, z As Integer

If strAngka = "" Then Exit Function
strJmlHuruf = Trim(strAngka)
X = 0
Y = 0
Urai = ""
While (X < x =" X" strtot =" Mid(strJmlHuruf," y =" Y" z =" Len(strJmlHuruf)" bil1 = "NOL " z =" 1" z =" 7" z =" 10" z =" 13)" bil1 = "Satu " z =" 4)" x =" 1)" bil1 = "Se" bil1 = "Satu " z =" 2" z =" 5" z =" 8" z =" 11" z =" 14)" x =" X" strtot =" Mid(strJmlHuruf," z =" Len(strJmlHuruf)" bil2 = "" bil1 = "Sepuluh " bil1 = "Sebelas " bil1 = "Dua Belas " bil1 = "Tiga Belas " bil1 = "Empat Belas " bil1 = "Lima Belas " bil1 = "Enam Belas " bil1 = "Tujuh Belas " bil1 = "Delapan Belas " bil1 = "Sembilan Belas " bil1 = "Se" bil1 = "Dua " bil1 = "Tiga " bil1 = "Empat " bil1 = "Lima " bil1 = "Enam " bil1 = "Tujuh " bil1 = "Delapan " bil1 = "Sembilan " bil1 = ""> 0) Then
If (z = 2 Or z = 5 Or z = 8 Or z = 11 Or z = 14) Then
Bil2 = "Puluh "
ElseIf (z = 3 Or z = 6 Or z = 9 Or z = 12 Or z = 15) Then
Bil2 = "Ratus "
Else
Bil2 = ""
End If
Else
Bil2 = ""
End If
If (Y > 0) Then
Select Case z
Case 4
Bil2 = Bil2 + "Ribu "
Y = 0
Case 7
Bil2 = Bil2 + "Juta "
Y = 0
Case 10
Bil2 = Bil2 + "Milyar "
Y = 0
Case 13
Bil2 = Bil2 + "Trilyun "
Y = 0
End Select
End If
Urai = Urai + Bil1 + Bil2
Wend
KonversiBilangan = Urai
End Function

‘ini fungsi untuk mereset form
Public Sub ResetForm(layar As Form)
For Each CNTRL In layar.Controls
If (TypeOf CNTRL Is TextBox) Then
CNTRL.Text = ""
ElseIf (TypeOf CNTRL Is DTPicker) Then
CNTRL.Value = Date
CNTRL.MaxDate = Date
End If
Next CNTRL

End Sub

Catatan:
1. Sebelum menjalankan program ada baiknya mengcopykan file lvbutton. Selanjutnya file tersebut diextract dan dicopykan ke c:\windows\system atau c:\windows\system32
2. Untuk menjalankannya jalankan kedua program terlebih dahulu secara bersama-sama.......

Installasi crystal report versi 7 pada windows 7 merupakan salah satu kendala dalam memindahkan crystal report ke windows 7. Saya temukan solusi pada www.tek-tips.com ada beberapa langkah yang bisa kita lakukan sehingga crystal report 7 bisa kita jalankan pada windows 7.
Langkah-langkahnya adalah sebagai berikut:

• Salin folder installasi ke hardisk, karena akan dilakukan perubahan pada salah satu file dalam folder installasi, jadi agar folder ini juga nanti masih bisa digunakan pada komputer lain, sebaiknya dibuat salinannya. Dan gunakan folder installasi ini untuk melakukan langkah-langkah berikutnya.
• Buka folder installasi, kemudian cari file setup.inf

  Lalu jalankan istalasi crystal reportnya sampai selesai, jalankan crystal reportnya tapi sebelumnya sebaiknya atur terlebih dahulunya compability-nya pada Windows 2000 atau windows XP.
dak akhirnya selamat mencoba dan selamat berkreasi dengan CR 8.5.........Sekian dan semoga bermanfaat.

Berikut langkah-langkah untuk membuat laporan :

1. Buat data environment di visual basic
2. Buat laporan dengan menggunakan data report

Selanjutnya buat form untuk menampilkan laporan yang dibuat tadi seperti gambar berikut ini :

Selanjutnya ketikkan coding berikut ini untuk pada halaman coding editor
Koneksi Database
Private Sub Form_Load()
Me.Dlap.DatabaseName = App.Path + "\MyDatabase.mdb"
Me.txtnota.Enabled = False
Me.ccari.Enabled = False
Me.Dp1.Enabled = False
Me.Dp2.Enabled = False
Me.Dp1.Value = Date
Me.Dp2.Value = Date
End Sub
Menampilkan Laporan

Private Sub CTampil_Click()

'A. Menampilkan Per Periode
If Me.opt3.Value = True Then
de1.Commands(4).CommandText = "
select jual.nota, jual.tgl, jual.kasir, subjual.nota, subjual.kdbar, subjual.nmbar,
subjual.harga, subjual.jml, subjual.subtotal from jual, subjual
where jual.nota = subjual.nota
and jual.tgl between #" & Me.Dp1.Value & "# and #" & Me.Dp2.Value & "#"

Lap_Penjualan.Refresh
Lap_Penjualan.Show
'B. Menampilkan Laporan Per Nota
ElseIf Me.Opt2.Value = True Then
de1.Commands(4).CommandText = "
select jual.nota, jual.tgl, jual.kasir, subjual.nota, subjual.kdbar, subjual.nmbar,
subjual.harga, subjual.jml, subjual.subtotal from jual, subjual
where jual.nota = subjual.nota
and subjual.nota = '" + Me.txtnota.Text + "'"

Lap_Penjualan.Refresh
Lap_Penjualan.Show
'C. Menampilkan Semua Laporan Penjualan
Else
Lap_Penjualan.Refresh
Lap_Penjualan.Show
End If
End Sub
Tuk kali ini sekian dulu semoga bermamfaat dan sampai jumpa lagi di episode selanjutnya debugdebugers.blogspot.

Pada Kesempatan Kali ini Debuger's menyajikan langkah membuat form lagin pada Visual Basic atau yang lebih sering di sebut dengan VB, berikut langkah-langkahnya :
Desain sebuah form seperti gambar dibawah ini :


Kemudian pada halam coding editor ketik coding berikut ini :
'Call buat_koneksi
If cek.State = 1 Then cek.Close
cek.Open "select * from user_login where " & _ "user_id='" & Replace(Text1, "'", "''") & "'", koneksi, adOpenDynamic, adLockOptimistic
If Not cek.EOF Then
cek.Close
cek.Open "select * from user_login "
& _ "where user_id='" & Replace(Text1, "'", "''") & "' " & _ "and password='" & Replace(Text2, "'", "''") & "'", koneksi, adOpenDynamic, adLockOptimistic
If Not cek.EOF Then
MDIForm1.mnuData.Enabled = True
MDIForm1.mnuFile.Enabled = True
MDIForm1.mnuHelp.Enabled = True
MDIForm1.mnuReport.Enabled = True
MDIForm1.mnuView.Enabled = True
MDIForm1.mnuTrans.Enabled = True
MDIForm1.vbButton1.Enabled = True
MDIForm1.vbButton3.Enabled = True
MDIForm1.cmdMNUMekanik.Enabled = True
MDIForm1.cmdMNUSpare.Enabled = True
MDIForm1.cmdMNUSupplier.Enabled = True
MDIForm1.cmdLog.Enabled = True
MDIForm1.cmdLog.ToolTipText = "LogOut"
If cek!Level = "Admin" Then
MDIForm1.vbButton2.Enabled = True
MDIForm1.mnuIUser.Enabled = True
Else
MDIForm1.vbButton2.Enabled = False
MDIForm1.mnuIUser.Enabled = False
End If
frmLogin.Hide
MDIForm1.Show
Else
n = n + 1
MsgBox "Sorry, User or Password is Wrong !", vbExclamation, "Warning"
With Text1
.SelStart = 0
.SelLength = Len(Text1)
.SetFocus
End With
Text2 = ""
If n > 3 Then
MsgBox "Sorry, you're have a 3x
Wrong, Application will Close!", 64, "Information"
End
End If
End If
Else
n = n + 1
MsgBox "Sorry, User or Password is Wrong !", vbExclamation, "Warning"
With Text1
.SelStart = 0
.SelLength = Len(Text1)
.SetFocus
End With
Text2 = ""
If n > 3 Then
MsgBox "Sorry, you're have a 3x Wrong, Application will Close!", 64, "Information"
End
End If
End If

Demikian salah satu cara untuk membuat form login pada VB 6.0, Semoga bermamfaat bagi anda yang sedang belajar Visual Basic.

Simpan Data :   Data1.Recordset.AddNew
Data1.Recordset!namakolom1 = Text1.Text
Data1.Recordset!namakolom2 = Text2.Text 
Data1.Recordset.Update 
Data1.Refresh 
Pencarian Data :
Data1.Recordset.Index = "KodeIdx" 
Data1.Recordset.Seek "=", Textcari.Text 
If Not Data1.Recordset.NoMatch Then 
Text1.Text = Data1.Recordset!namakolom1 
 Text2.Text = Data1.Recordset!namakolom2 
Else 
MsgBox "Maaf, Data Tidak Ditemukan!" 
End if
Edit Data : 
Kode ini sebaiknya dijalankan setelah kode pencarian dijalankan terlebih dahulu. 
Data1.Recordset.Edit 
Data1.Recordset!namakolom1=Text1.Text 
Data1.Recordset!namakolom2=Text2.Text 
Data1.Recordset.Update 
Data1.Refresh 
Hapus Data : 
Kode ini sebaiknya dijalankan setelah kode pencarian dijalankan terlebih dahulu. 
Data1.Recordset.Delete 
Data1.Refresh 

Untuk ADODC gunakan code berikut :
Simpan Data : 
Adodc1.Recordset.AddNew 
Adodc1.Recordset!namakolom1 = Text1.Text 
Adodc1.Recordset!namakolom2 = Text2.Text 
Adodc1.Recordset.Update 
Adodc1.Refresh 
'Pencarian Data : 
Adodc1.Recordset.Find "namakolom1='" + Text1.Text + "'", , adSearchForward, 1 
If Not Adodc1.Recordset.EOF Then 
Text1.Text = Adodc1.Recordset!namakolom1 
Text2.Text = Adodc1.Recordset!namakolom2 
Else 
MsgBox "Maaf, Data Tidak Ditemukan!" 
End if 
Edit Data : 
Kode ini sebaiknya dijalankan setelah kode pencarian dijalankan terlebih dahulu. 
Adodc1.Recordset!namakolom1=Text1.Text 
Adodc1.Recordset!namakolom2=Text2.Text 
Adodc1.Recordset.Update 
Adodc1.Refresh 
Hapus Data : 
Kode ini sebaiknya dijalankan setelah kode pencarian dijalankan terlebih dahulu. 
Adodc1.Recordset.Delete 
Adodc1.Refresh 

Selamat mencoba semoga berhasil Salam "Debuger's"

Fungsi terbilang adalah fungsi yang melakukan konversi dari angka menjadi teks terbilangnya, misalnya 123,4567 menjadi seratus dua puluh tiga koma empat lima enam tujuh.

LISTING PROGRAM:


Listing 1. Fungsi terbilang

Public Function Terbilang(x As Double) As String
Dim tampung As Double
Dim teks As String