Jumat, 19 Juli 2013
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.
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.......
- Untuk Server
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
2. Untuk Client
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.......
