Home contoh program vb 6 contoh aplikasi kredit kendaraan vb 6

Saturday, March 18, 2017

contoh aplikasi kredit kendaraan vb 6

Diterbitkan
Tags


Aplikasi Kredit Kendaraan VB 6.0

4.1  Merancang Database Dan Relasi Tabel

Aplikasi ini terdiri dari sebuah database dan beberapa tabel antara lain tabel operator, motor, customer, belicash, belikredit dan tabel bayarcicilan. Bentuk relasinya dapat dilihat pada gambar di bawah ini.



4.2  Membuat Module

Pembuatan module ini bertujuan agar akses database dapat dilakuakn dengan efentif dan efisien. Buatlah module dengan langkah-langkah sebagai berikut :
Cara membuat Modul :
1.              Buka VB
2.              Klik menu Project
3.              Pilih Add Module
4.              Klik Open
5.              Tulis koding di bawah ini kemudian simpan

Public CONN As New ADODB.Connection
Public RSMotor As ADODB.Recordset
Public RSCustomer As ADODB.Recordset
Public RSOperator As ADODB.Recordset
Public RSBeliCash As ADODB.Recordset
Public RSBeliKredit As ADODB.Recordset
Public RSDetailKredit As ADODB.Recordset
Public RSBayarCicilan As ADODB.Recordset

Public Sub BukaDB()
Set CONN = New ADODB.Connection
Set RSMotor = New ADODB.Recordset
Set RSCustomer = New ADODB.Recordset
Set RSOperator = New ADODB.Recordset
Set RSBeliCash = New ADODB.Recordset
Set RSBeliKredit = New ADODB.Recordset
Set RSDetailKredit = New ADODB.Recordset
Set RSBayarCicilan = New ADODB.Recordset
CONN.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\DBkredit.mdb"
End Sub





4.3  Pengolahan Data Operator

Untuk melakukan pengolahan data operator (pengguna aplikasi) buatlah form dengan bentuk seperti gambar di bawah ini :



4.4  Pengolahan Data Motor

Untuk melakukan pengolahan data kendaraan, buatlah form seperti bentuk di bawah ini. Desain tabel motor telah disederhanakan. Para pembaca silakan mengubahkan sesuai kebutuhan. 




4.5  Pengolahan Data Customer

Untuk mengolah data customer, buatlah form seperti bentuk di bawah ini.




4.6  Transaksi Pembelian Tunai

Konsep bembelian tunai ini sifatnya one to one. Bentuk form pembelian tunai dapat dilihat dalam pada di bawah ini.



Coding :
Private Sub Form_Activate()
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\DBKredit.mdb"
Adodc1.RecordSource = "belicash"
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh

'menampilkan daftar kode customer dalam combo1
Call BukaDB
RSCustomer.Open "Customer", CONN
Combo1.Clear
Do Until RSCustomer.EOF
    Combo1.AddItem RSCustomer!Kodecus
    RSCustomer.MoveNext
Loop

'menampilkan daftar kode motor di combo2
RSMotor.Open "Motor", CONN
Combo2.Clear
Do Until RSMotor.EOF
    Combo2.AddItem RSMotor!Kodemtr
    RSMotor.MoveNext
Loop

Call Auto 'memanggil IDCash otomatis dengan pola tanggal
Tanggal = Date
End Sub

'memanggil IDCash otomatis dengan pola tanggal
'buka tabel becash dan cari IDCash yang paling besar
'jika tidak ada maka dibentuk yang baru
'jika sudah ada yang yang paling besar + 1
Private Sub Auto()
Call BukaDB
RSBeliCash.Open "select * from BeliCash Where IdCash In(Select Max(IdCash)From BeliCash)Order By IdCash Desc", CONN
RSBeliCash.Requery
    Dim Urutan As String * 10
    Dim Hitung As Long
    With RSBeliCash
        If .EOF Then
            Urutan = "CS" + Format(Date, "yymmdd") + "01"
            IdCash = Urutan
        Else
            If Mid(!IdCash, 3, 6) <> Format(Date, "yymmdd") Then
                Urutan = "CS" + Format(Date, "yymmdd") + "01"
            Else
                Hitung = Right(!IdCash, 2) + 1
                Urutan = "CS" + Format(Date, "yymmdd") + Right("00" & Hitung, 2)
            End If
        End If
        IdCash = Urutan
    End With
End Sub

'menampilkan identitas customer yang dipilih di combo1
Private Sub COMBO1_Click()
Call BukaDB
RSCustomer.Open "select * from customer where kodecus='" & Combo1 & "'", CONN
If RSCustomer.EOF Then
    MsgBox "kode customer tidak terdaftar"
    Combo1.SetFocus
Else
    LblNama = RSCustomer!nama
    LblAlamat = RSCustomer!alamat
    LblTelepon = RSCustomer!telepon
End If
End Sub

'menampilkan identitas motor yang dipilih di combo2
Private Sub Combo2_Click()
Call BukaDB
RSMotor.Open "select * from Motor where kodemtr='" & Combo2 & "'", CONN
If RSMotor.EOF Then
    MsgBox "kode Motor tidak terdaftar"
    Combo2.SetFocus
Else
    LblMerk = RSMotor!merk
    LblWarna = RSMotor!warna
    LblHarga = Format(RSMotor!harga, "###,###,###,###")
End If
End Sub

Private Sub TxtDibayar_KeyPress(Keyascii As Integer)
    If Keyascii = 13 Then
        TxtDibayar = Format(TxtDibayar, "###,###,###")
        If TxtDibayar = "" Or TxtDibayar < LblHarga Then
            TxtKet = "kurang" & Space(1) & Format(LblHarga - TxtDibayar, "###,###,###")
            CmdSimpan.Enabled = True
            CmdSimpan.SetFocus
        Else
            If TxtDibayar = LblHarga Then
                TxtKet = 0
            Else
                TxtKet = "kembali" & Space(1) & Format(TxtDibayar - LblHarga, "###,###,###")
            End If
        CmdSimpan.Enabled = True
        CmdSimpan.SetFocus
        End If
    End If
    If Not (Keyascii >= Asc("0") And Keyascii <= Asc("9") Or Keyascii = vbKeyBack) Then Keyascii = 0
End Sub

Private Sub CmdSimpan_Keypress(Keyascii As Integer)
    If Keyascii = 27 Then
        TxtDibayar = ""
        TxtKet = ""
        TxtDibayar.SetFocus
    End If
End Sub

Private Sub CmdSimpan_Click()
If Combo1 = "" Or Combo2 = "" Or TxtDibayar = "" Or TxtKet = "" Then
    MsgBox "data belum lengkap"
Else
    Dim SQLTambahJual As String
    SQLTambahJual = "Insert Into BeliCash(IdCash,Tanggal,kodecus,kodemtr,harga,dibayar,keterangan)" & _
    "values('" & IdCash & "','" & Tanggal & "','" & Combo1 & "','" & Combo2 & "','" & LblHarga & "','" & TxtDibayar & "','" & TxtKet & "')"
    CONN.Execute (SQLTambahJual)
    Form_Activate
    Call Bersihkan
    Form_Activate
    Call cetak
End If
End Sub

Sub cetak()
    CR.ReportFileName = App.Path & "\kwitansi beli cash.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Bersihkan()
    Combo1 = ""
    Combo2 = ""
    LblNama = ""
    LblAlamat = ""
    LblTelepon = ""
    LblMerk = ""
    LblWarna = ""
    LblHarga = ""
    TxtDibayar = ""
    TxtKet = ""
End Sub

Private Sub CmdBatal_Click()
Call Bersihkan
Form_Activate
End Sub

Private Sub CmdTutup_Click()
Unload Me
End Sub

Bentuk kwitansi pembayaran cash



4.7  Transaksi Pembelian Kredit

Konsep pembelian kredit ini menggunakan relasi one to one, tetapi pada saat pembayarannya menggunakan pola one to many.





Coding :
Private Sub Form_Activate()
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\DBKredit.mdb"
Adodc1.RecordSource = "BeliKredit"
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh

Call BukaDB
RSCustomer.Open "Customer", CONN
Combo1.Clear
Do Until RSCustomer.EOF
    Combo1.AddItem RSCustomer!Kodecus
    RSCustomer.MoveNext
Loop

RSMotor.Open "Motor", CONN
Combo2.Clear
Do Until RSMotor.EOF
    Combo2.AddItem RSMotor!Kodemtr
    RSMotor.MoveNext
Loop
Call Auto
Tanggal = Date
End Sub

Private Sub Auto()
Call BukaDB
RSBeliKredit.Open "select * from BeliKredit Where IdKredit In(Select Max(IdKredit)From BeliKredit)Order By IdKredit Desc", CONN
RSBeliKredit.Requery
    Dim Urutan As String * 10
    Dim Hitung As Long
    With RSBeliKredit
        If .EOF Then
            Urutan = "CR" + Format(Date, "yymmdd") + "01"
            IdKredit = Urutan
        Else
            If Mid(!IdKredit, 3, 6) <> Format(Date, "yymmdd") Then
                Urutan = "CR" + Format(Date, "yymmdd") + "01"
            Else
                Hitung = Right(!IdKredit, 2) + 1
                Urutan = "CR" + Format(Date, "yymmdd") + Right("00" & Hitung, 2)
            End If
        End If
        IdKredit = Urutan
    End With
End Sub

Private Sub COMBO1_Click()
Call BukaDB
RSCustomer.Open "select * from customer where kodecus='" & Combo1 & "'", CONN
If RSCustomer.EOF Then
    MsgBox "kode customer tidak terdaftar"
    Combo1.SetFocus
Else
    LblNama = RSCustomer!nama
    LblAlamat = RSCustomer!alamat
    LblTelepon = RSCustomer!telepon
End If
End Sub

Private Sub Combo2_Click()
Call BukaDB
RSMotor.Open "select * from Motor where kodemtr='" & Combo2 & "'", CONN
If RSMotor.EOF Then
    MsgBox "kode Motor tidak terdaftar"
    Combo2.SetFocus
Else
    LblMerk = RSMotor!merk
    LblHargaCash = Format(RSMotor!harga, "###,###,###,###")
End If
End Sub

Private Sub TxtDibayar_KeyPress(Keyascii As Integer)
    If Keyascii = 13 Then
        If TxtDibayar = "" Or Val(TxtDibayar) < (LblHarga) Then
            TxtKet = "kurang" & Space(1) & Format(LblHarga - TxtDibayar, "###,###,###")
        Else
           
            If TxtDibayar = LblHarga Then
                TxtKet = TxtDibayar - LblHarga
                TxtDibayar = Format(TxtDibayar, "###,###,###")
            Else
                TxtKet = "kembali" & Space(1) & Format(TxtDibayar - LblHarga, "###,###,###")
            End If
        CmdSimpan.Enabled = True
        CmdSimpan.SetFocus
        End If
    End If
    If Not (Keyascii >= Asc("0") And Keyascii <= Asc("9") Or Keyascii = vbKeyBack) Then Keyascii = 0
End Sub

Private Sub CmdSimpan_Keypress(Keyascii As Integer)
    If Keyascii = 27 Then
        TxtDibayar = ""
        TxtKet = ""
        TxtDibayar.SetFocus
    End If
End Sub

Private Sub CmdSimpan_Click()
If Combo1 = "" Or Combo2 = "" Or TxtDP = "" Or TxtBunga = "" Or TxtLama = "" Then
    MsgBox "data belum lengkap"
Else
    Dim SQLTambahJual As String
    SQLTambahJual = "Insert Into BeliKredit(IdKredit,Tanggal,kodecus,kodemtr,harga,uangmuka,bunga,lamacicilan,angsuran,sisa,keterangan)" & _
    "values('" & IdKredit & "','" & Tanggal & "','" & Combo1 & "','" & Combo2 & "','" & LblHargaKredit & "','" & TxtDP & "','" & TxtBunga & "','" & TxtLama & "','" & LblAngsuran & "','" & LblHargaKredit & "','-')"
    CONN.Execute (SQLTambahJual)
    Form_Activate
    Call Bersihkan
    Form_Activate
    Combo2.SetFocus
End If
End Sub

Private Sub Bersihkan()
    Combo1 = ""
    Combo2 = ""
    LblNama = ""
    TxtDP = ""
    TxtBunga = ""
    TxtLama = ""
    LblMerk = ""
    LblHargaCash = ""
    LblHargaKredit = ""
    LblAngsuran = ""
End Sub

Private Sub CmdBatal_Click()
Call Bersihkan
Form_Activate
End Sub

Private Sub CmdTutup_Click()
Unload Me
End Sub

Private Sub TxtBunga_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    If TxtBunga = "" Then
        MsgBox "Bunga harus diisi"
        TxtBunga.SetFocus
        Exit Sub
    Else
        TxtLama.SetFocus
    End If
End If
If Not (Keyascii >= Asc("0") And Keyascii <= Asc("9") Or Keyascii = vbKeyBack) Then Keyascii = 0
End Sub

Private Sub TxtDP_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    If TxtDP = "" Then
        MsgBox "Uang Muka harus diisi"
        TxtDP.SetFocus
        Exit Sub
    Else
        TxtDP = Format(TxtDP, "###,###,###,###")
        TxtBunga.SetFocus
    End If
End If
If Not (Keyascii >= Asc("0") And Keyascii <= Asc("9") Or Keyascii = vbKeyBack) Then Keyascii = 0
   
End Sub

'mencari harga motor kredit dan angsuran perbulan
Private Sub TxtLama_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    LblAngsuran = Round(Pmt(TxtBunga / 100 / 12, TxtLama, LblHargaCash), 0) * -1
    LblAngsuran = Format(LblAngsuran, "###,###,###,###")
    LblHargaKredit = Round(FV(TxtBunga / 100 / 12, TxtLama, LblAngsuran), 0) * -1
    LblHargaKredit = Format(LblHargaKredit, "###,###,###,###")
    CmdSimpan.SetFocus
End If
If Not (Keyascii >= Asc("0") And Keyascii <= Asc("9") Or Keyascii = vbKeyBack) Then Keyascii = 0
End Sub

4.8    Transaksi Pembayaran Cicilan

Untuk melakukan pengolahan data pembayaran cicilan, buatlah form dengan bentuk seperti gambar di bawah ini.




Coding :
Private Sub Form_Activate()
Call BukaDB
Adodc1.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\DBKredit.mdb"
Adodc1.RecordSource = "BeliKredit"
Adodc1.Refresh
Set DataGrid1.DataSource = Adodc1
DataGrid1.Refresh

Adodc2.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\DBKredit.mdb"
Adodc2.RecordSource = "bayarcicilan"
Adodc2.Refresh
Set DataGrid2.DataSource = Adodc2
DataGrid2.Refresh

RSBeliKredit.Open "select * from belikredit where keterangan <>'LUNAS'", CONN
Combo1.Clear
Do While Not RSBeliKredit.EOF
    Combo1.AddItem RSBeliKredit!IdKredit
    RSBeliKredit.MoveNext
Loop

Call Auto
LblTanggalbyr = Date
End Sub

Private Sub Auto()
Call BukaDB
RSBayarCicilan.Open "select * from Bayarcicilan Where NomorByr In(Select Max(NomorByr)From Bayarcicilan)Order By NomorByr Desc", CONN
RSBayarCicilan.Requery
    Dim Urutan As String * 10
    Dim Hitung As Long
    With RSBayarCicilan
        If .EOF Then
            Urutan = "BY" + Format(Date, "yymmdd") + "01"
            NomorByr = Urutan
        Else
            If Mid(!NomorByr, 3, 6) <> Format(Date, "yymmdd") Then
                Urutan = "BY" + Format(Date, "yymmdd") + "01"
            Else
                Hitung = Right(!NomorByr, 2) + 1
                Urutan = "BY" + Format(Date, "yymmdd") + Right("00" & Hitung, 2)
            End If
        End If
        NomorByr = Urutan
    End With
End Sub

Private Sub combo1_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    If Combo1 = "" Then
        MsgBox "nomor kredit harus diisi"
        Combo1.SetFocus
    Else
        TxtAngsuran.SetFocus
    End If
End If
End Sub

Private Sub COMBO1_Click()
Call BukaDB
RSBeliKredit.Open "select * from belikredit where idkredit='" & Combo1 & "'", CONN
If Not RSBeliKredit.EOF Then
    'jika belum pernah membayar angsuran maka
    'jatuh tempo pembayaran adalah dimulai dari tanggal beli + 30 hari
    If RSBeliKredit!angsuranke = 0 Then
        LblTanggalTempo = RSBeliKredit!Tanggal + (30 * 1)
    Else
    'jika pernah ada angsuran, maka angsuran berikutnya
    'adalah 30 hari X jumlah angsuran yang penah dibayar
        LblTanggalTempo = RSBeliKredit!Tanggal + (30 * (RSBeliKredit!angsuranke + 1))
    End If
    'jumlah denda adalah 5000 x hari keterlambatan dati tgl jatuh tempo
    If CDate(lbltanggalbayar) > CDate(LblTanggalTempo) Then
        LblTerlambat = CDate(lbltanggalbayar) - CDate(LblTanggalTempo)
        LblDenda = 5000 * LblTerlambat
    Else
        LblTerlambat = 0
        LblDenda = 0
    End If
   
    LblHargaKredit = Format(RSBeliKredit!harga, "###,###,###,###")
    If RSBeliKredit!telahbayar = 0 Then
        LblTelahBayar = 0
    Else
        LblTelahBayar = Format(RSBeliKredit!telahbayar, "###,###,###,###")
    End If
   
    TxtAngsuran = Format(RSBeliKredit!angsuran, "###,###,###,###")
    LblSisaLalu = Format(RSBeliKredit!sisa, "###,###,###,###")
   
    'mencari identitas customer yang dihasilkan dari query belikredit
    RSCustomer.Open "select * from customer where kodecus='" & RSBeliKredit!Kodecus & "'", CONN
    If Not RSCustomer.EOF Then
        LblNama = RSCustomer!nama
        LblAlamat = RSCustomer!alamat
        LblTelepon = RSCustomer!telepon
        LblHP = RSCustomer!HP
    End If
   
    'mencari identitas motor yang dihasilkan dari query belikredit
    RSMotor.Open "select * from Motor where kodemtr='" & RSBeliKredit!Kodemtr & "'", CONN
    If Not RSMotor.EOF Then
        LblMerk = RSMotor!merk
        LblWarna = RSMotor!warna
    End If
End If

End Sub

Private Sub Command1_Click()
Call BukaDB
SIMPANBAYARCICILAN = "INSERT INTO bayarcicilan(nomorbyr,tanggalbyr,idkredit,JUMLAH,sisa,CICILAN,keterangan) VALUES " & _
"('" & NomorByr & "','" & LblTanggalbyr & "','" & Combo1 & "','" & TxtAngsuran & "','" & LblSisaSekarang & "','" & LblCicilanKe & "','" & TxtKeterangan & "')"
CONN.Execute SIMPANBAYARCICILAN

'sisa pembayaran terus berkurang akibat pembayaran
'jumlah telah bayar terus bertambah
'jika sisa sekarang = 0 maka keterangan =lunas
'indikasi angsuran terus berubah 1,2,3 dan seterusnya
RSBeliKredit.Open "SELECT * FROM BELIKREDIT WHERE IDKREDIT='" & Combo1 & "'", CONN
If Not RSBeliKredit.EOF Then
    If LblSisaSekarang = 0 Then
        updatedata = "UPDATE BeliKredit SET SISA='" & LblSisaSekarang & "',telahbayar= '" & RSBeliKredit!telahbayar + TxtAngsuran & "',ANGSURANKE='" & LblCicilanKe & "',keterangan='LUNAS' WHERE idkredit='" & Combo1 & "'"
        CONN.Execute updatedata
        CONN.Close
    Else
        updatedata = "UPDATE BeliKredit SET SISA='" & RSBeliKredit!sisa - TxtAngsuran & "',telahbayar= '" & RSBeliKredit!telahbayar + TxtAngsuran & "',ANGSURANKE='" & LblCicilanKe & "',keterangan='-' WHERE idkredit='" & Combo1 & "'"
        CONN.Execute updatedata
        CONN.Close
    End If
   
    Call BukaDB
    RSBeliKredit.Open "SELECT * FROM BeliKredit WHERE IDKredit='" & Combo1 & "' AND SISA=0", CONN
    If Not RSBeliKredit.EOF Then
        UBAHKET = "UPDATE BeliKredit SET KETerangan='LUNAS' WHERE IDKredit='" & Combo1 & "'"
        CONN.Execute UBAHKET
    End If
    Form_Activate
    Call Bersihkan
    Combo1.SetFocus
End If
End Sub

Private Sub TxtAngsuran_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    Call BukaDB
    RSBeliKredit.Open "SELECT * FROM belikredit WHERE idkredit='" & Combo1 & "'", CONN
    'jika angsuran melebihi sisa pembayaran,
    'maka tampilkan dalam keterangan uang kembaliannya
    If Val(TxtAngsuran) > RSBeliKredit!sisa Then
        TxtAngsuran = Format(TxtAngsuran, "###,###,###,###")
        TxtKeterangan = "kembali" & Space(1) & Format(TxtAngsuran - RSBeliKredit!sisa, "###,###,###,###") & Space(1) & "LUNAS"
        LblCicilanKe = 1
        LblSisaSekarang = 0
    Else
        'sisa sekarang tampil setelah dikurang angsuran
        'indikasi cicilan terus berubah yaitu cicilan bulan lalu + 1
        LblSisaSekarang = Format(LblHargaKredit - TxtAngsuran, "###,###,###,###")
        RSBayarCicilan.Open "SELECT COUNT(idkredit) AS KETEMU FROM bayarcicilan WHERE idkredit='" & Combo1 & "'", CONN
        If Not RSBayarCicilan.EOF Then
            LblCicilanKe = RSBayarCicilan!ketemu + 1
        Else
            LblCicilanKe = 1
        End If
        'tampilkan dalam keterangan indikasi pembayaran bulan jatuh tempo
        TxtKeterangan = "Pembayaran Bulan" & Space(1) & Format(LblTanggalTempo, "MMMM")
    End If
    TxtKeterangan.SetFocus
End If
End Sub

Private Sub TxtKeterangan_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    If TxtKeterangan = "" Then
        TxtKeterangan = "-"
    Else
        Command1.SetFocus
    End If
End If
End Sub

Private Sub Command2_Click()
Call Bersihkan
End Sub

Private Sub Command3_Click()
Unload Me
End Sub

Sub Bersihkan()
Combo1 = ""
LblNama = ""
LblAlamat = ""
LblTelepon = ""
LblHP = ""
LblMerk = ""
LblWarna = ""
LblHargaKredit = ""
LblTanggalTempo = ""
LblTerlambat = ""
LblTelahBayar = ""
LblSisaLalu = ""
LblDenda = ""
TxtAngsuran = ""
LblCicilanKe = ""
LblSisaSekarang = ""
TxtKeterangan = "-"
End Sub

4.9  Pembuatan Laporan

4.9.3   Laporan Pembelian

Laporan pembelian ini dibagi menjadi dua bagian utama yaitu laporan pembelian cash dan kredit. Setiap jenis laporan ini dibagi menjadi tiga bagian lagi yaitu laporan harian, laporan bulanan dan laporan seluruh data. Bentuk form untuk memanggil laporan pembelian terlihat pada gambar di bawah ini.




Coding :
Private Sub Form_Load()
'On Error Resume Next
Call BukaDB
'cari data tanggal di tabel belicash
RSBeliCash.Open "Select Distinct Tanggal From BeliCash order By 1", CONN
RSBeliCash.Requery
Do Until RSBeliCash.EOF
    'tampilkan dalam combo1
    Combo1.AddItem Format(RSBeliCash!Tanggal, "DD-MMM-YYYY")
    RSBeliCash.MoveNext
Loop

Dim RSBulan As New ADODB.Recordset
'cari bulan dalam tabel belicash
RSBulan.Open "select distinct month(Tanggal) as Bulan from BeliCash", CONN
Do While Not RSBulan.EOF
    'tampilkan dalam combo2
    Combo2.AddItem RSBulan!Bulan & Space(5) & MonthName(RSBulan!Bulan)
    RSBulan.MoveNext
Loop

Dim RSTahun As New ADODB.Recordset
'cari tahun di tabel belicash
RSTahun.Open "select distinct year(Tanggal)  as Tahun from BeliCash", CONN
Do While Not RSTahun.EOF
    'tampilkan dalam combo3
    Combo3.AddItem RSTahun!Tahun
    RSTahun.MoveNext
Loop


RSBeliKredit.Open "Select Distinct Tanggal From BeliKredit order By 1", CONN
RSBeliKredit.Requery
Do Until RSBeliKredit.EOF
    Combo4.AddItem Format(RSBeliKredit!Tanggal, "DD-MMM-YYYY")
    RSBeliKredit.MoveNext
Loop

Dim RSBulanKredit As New ADODB.Recordset
RSBulanKredit.Open "select distinct month(Tanggal) as Bulan from BeliKredit", CONN
Do While Not RSBulanKredit.EOF
    Combo5.AddItem RSBulanKredit!Bulan & Space(5) & MonthName(RSBulanKredit!Bulan)
    RSBulanKredit.MoveNext
Loop

Dim RSTahunKredit As New ADODB.Recordset
RSTahunKredit.Open "select distinct year(Tanggal)  as Tahun from BeliKredit", CONN
Do While Not RSTahunKredit.EOF
    Combo6.AddItem RSTahunKredit!Tahun
    RSTahunKredit.MoveNext
Loop

CONN.Close
End Sub

Private Sub COMBO1_Click()
    CR.SelectionFormula = "Totext({BeliCash.Tanggal})='" & CDate(Combo1) & "'"
    CR.ReportFileName = App.Path & "\lap beli cash harian.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Combo3_Click()
    Call BukaDB
    RSBeliCash.Open "select * from BeliCash where month(Tanggal)='" & Val(Left(Combo2, 2)) & "' and year(Tanggal)='" & (Combo3) & "'", CONN
    If RSBeliCash.EOF Then
        MsgBox "Data tidak ditemukan"
        Exit Sub
        Combo4.SetFocus
    End If
    CR.SelectionFormula = "Month({BeliCash.Tanggal})=" & Val(Left(Combo2, 2)) & " and Year({BeliCash.Tanggal})=" & Val(Combo3.Text)
    CR.ReportFileName = App.Path & "\LAP beli cash bulanan.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Combo4_Click()
    CR.SelectionFormula = "Totext({BeliKredit.Tanggal})='" & CDate(Combo4) & "'"
    CR.ReportFileName = App.Path & "\LAP BELI KREDIT HARIAN.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Combo6_Click()
Call BukaDB
RSBeliKredit.Open "select * from BeliKredit where month(Tanggal)='" & Val(Left(Combo5, 2)) & "' and year(Tanggal)='" & (Combo6) & "'", CONN
If RSBeliKredit.EOF Then
    MsgBox "Data tidak ditemukan"
    Exit Sub
    Combo4.SetFocus
End If
CR.SelectionFormula = "Month({BeliKredit.Tanggal})=" & Val(Left(Combo5, 2)) & " and Year({BeliKredit.Tanggal})=" & Val(Combo6.Text)
CR.ReportFileName = App.Path & "\LAP BELI KREDIT BULANAN.rpt"
CR.WindowState = crptMaximized
CR.RetrieveDataFiles
CR.Action = 1
End Sub


Private Sub Command1_Click()
    CR.ReportFileName = App.Path & "\lap beli cash.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Command2_Click()
    CR.ReportFileName = App.Path & "\lap BELI KREDIT.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Hasil dari coding tersebut terlihat pada gambar-gambar di bawah ini.


4.9.4   Laporan Pembayaran

Laporan pembayaran ini dibuat sesederhana mungkin yaitu terdiri dari laporan pembayaran harian, bulanan dan laporan pembayaran seluruh data. Bentuk form untuk memanggil laporan pembayaran terlihat pada gambar di bawah ini.


Coding :
Private Sub Form_Load()
'On Error Resume Next
Call BukaDB
RSBayarCicilan.Open "Select Distinct TanggalByr From BayarCicilan order By 1", CONN
RSBayarCicilan.Requery
Do Until RSBayarCicilan.EOF
    Combo1.AddItem Format(RSBayarCicilan!TanggalByr, "DD-MMM-YYYY")
    RSBayarCicilan.MoveNext
Loop

Dim RSBulan As New ADODB.Recordset
RSBulan.Open "select distinct month(TanggalByr) as Bulan from BayarCicilan", CONN
Do While Not RSBulan.EOF
    Combo2.AddItem RSBulan!Bulan & Space(5) & MonthName(RSBulan!Bulan)
    RSBulan.MoveNext
Loop

Dim RSTahun As New ADODB.Recordset
RSTahun.Open "select distinct year(TanggalByr)  as Tahun from BayarCicilan", CONN
Do While Not RSTahun.EOF
    Combo3.AddItem RSTahun!Tahun
    RSTahun.MoveNext
Loop
CONN.Close
End Sub

Private Sub COMBO1_Click()
    CR.SelectionFormula = "Totext({BayarCicilan.TanggalByr})='" & CDate(Combo1) & "'"
    CR.ReportFileName = App.Path & "\lap bayar cicilan harian.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Combo3_Click()
    Call BukaDB
    RSBayarCicilan.Open "select * from BayarCicilan where month(TanggalByr)='" & Val(Left(Combo2, 2)) & "' and year(TanggalByr)='" & (Combo3) & "'", CONN
    If RSBayarCicilan.EOF Then
        MsgBox "Data tidak ditemukan"
        Exit Sub
        Combo4.SetFocus
    End If
    CR.SelectionFormula = "Month({BayarCicilan.TanggalByr})=" & Val(Left(Combo2, 2)) & " and Year({BayarCicilan.TanggalByr})=" & Val(Combo3.Text)
    CR.ReportFileName = App.Path & "\LAP bayar cicilan bulanan.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Private Sub Command1_Click()
    CR.ReportFileName = App.Path & "\lap bayar cicilan.rpt"
    CR.WindowState = crptMaximized
    CR.RetrieveDataFiles
    CR.Action = 1
End Sub

Hasil laporan dari coding tersebut terlihat pada gambar-gambar berikut ini.

Artikel Terkait

uus rusmawan

Next Post
Previous Post


EmoticonEmoticon

Subscribe to: Post Comments (Atom)