free download vb6 source code examples program penjualan lengkap

free download vb6 source code examples program penjualan lengkap

free download vb6 source code examples program penjualan lengkap - kumpulan collection contoh source code visual basic 6.0 projects lengkap gratis. Mengingat sekarang ini sudah banyak program beredar di supermarket, toko, swalayan dan lain sebagainya, maka dari itu kita sebagai pengguna komputer program akan lebih baik kalau belajar membuat aplikasi sendiri. Adapun contoh program yang sering di pakai di bagian stap suatu instansi biasanya pengolahan data yakni ganti microsoft word.
free download vb6 source code examples program penjualan lengkap
free download vb6 source code examples program penjualan lengkap
* Kunjungi Channel YouTube Kami di Gudang Tutorial untuk melihat demo program siap pesan

free download vb6 source code examples program penjualan lengkap

Kali ini penulis berniat baik untuk membagikan coding program aplikasi penjualan barang elektronik komputer. silakan anda copy coding dibawah ini dengan nama file: menuutama Caption: Menu Utama, berikut codingnya:
 
Private Sub Form_Load()
Image1.Height = Me.ScaleHeight
Image1.Width = Me.ScaleWidth
Image1.Left = 0
Image1.Top = 0
End Sub
Private Sub Form_Resize()
Image1.Height = Me.ScaleHeight
Image1.Width = Me.ScaleWidth
Image1.Left = 0
Image1.Top = 0
End Sub
Private Sub IDBARANG_Click()
FIDBARANG.Show
End Sub
Private Sub IDJASA_Click()
FIDJASA.Show
End Sub
Private Sub IDKONSUMEN_Click()
FIDKONSUMEN.Show
End Sub
Private Sub KELUAR_Click()
On Error Resume Next
    Dim question As String
    question = MsgBox("Apakah anda yakin ingin keluar dari aplikasi ini.?", vbQuestion + vbYesNo, " Informasi")
    If question = vbYes Then
                 Unload Me
            End
    End If
End Sub
Private Sub LPPENJUALANDANJASA_Click()
On Error GoTo salah
CrystalReport1.ReportFileName = App.Path + "\RDPenjualDJasa.rpt"
CrystalReport1.DataFiles(0) = App.Path + "\DATA.mdb"
CrystalReport1.RetrieveDataFiles
CrystalReport1.Destination = crptToWindow
CrystalReport1.WindowState = crptMaximized
CrystalReport1.Action = 1
salah:
Exit Sub
End Sub
Private Sub RDTRANSAKSI_Click()
On Error GoTo salah
CrystalReport1.ReportFileName = App.Path + "\RDTansaksi.rpt"
CrystalReport1.DataFiles(0) = App.Path + "\DATA.mdb"
CrystalReport1.RetrieveDataFiles
CrystalReport1.Destination = crptToWindow
CrystalReport1.WindowState = crptMaximized
CrystalReport1.Action = 1
salah:
Exit Sub
End Sub
Private Sub TRANSAKSI_Click()
FTRANSAKSI.Show
End Sub
Private Sub TRUKPEMBAYARAN_Click()
FLAPPORG.Show
End Sub


Bentuk tampilan dari menu utama seperti ini:

free download vb6 source code examples program penjualan lengkap
free download vb6 source code examples program penjualan lengkap

Selanjutnya buat lagi form dengan nama : IDKONSUMEN Caption: Input Data Konsumen,
 
Option Explicit
Dim kodeKONSUMEN As String
Sub BKTABLE()
Dim baris As Integer
    tabel.Clear
    tabel.Rows = 2
    tabel.Cols = 4
    tabel.FixedRows = 1
    baris = 0
    tabel.TextMatrix(0, 0) = "Kode Konsumen"
    tabel.TextMatrix(0, 1) = "Nama Konsumen"
    tabel.TextMatrix(0, 2) = "Alamat"
    tabel.TextMatrix(0, 3) = "Telpon"
    tabel.ColWidth(0) = 1500
    tabel.ColWidth(1) = 2500
    tabel.ColWidth(2) = 2500
    tabel.ColWidth(3) = 1500
Set RsKONSUMEN = New ADODB.Recordset
RsKONSUMEN.Open "Select * From KONSUMEN order by KDKONSUMEN", _
connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsKONSUMEN.EOF
            baris = baris + 1
            tabel.Rows = baris + 1
            tabel.TextMatrix(baris, 0) = RsKONSUMEN!KDKONSUMEN
            tabel.TextMatrix(baris, 1) = RsKONSUMEN!NMKONSUMEN
            tabel.TextMatrix(baris, 2) = RsKONSUMEN!Alamat
            tabel.TextMatrix(baris, 3) = RsKONSUMEN!Telp
RsKONSUMEN.MoveNext
Loop
End Sub
Sub EMPT()
KDKONSUMEN.Text = ""
NMKONSUMEN.Text = ""
Alamat.Text = ""
Telp.Text = ""
End Sub
Sub FormMati()
NMKONSUMEN.Enabled = False
Alamat.Enabled = False
Telp.Enabled = False
End Sub
Sub FormHidup()
NMKONSUMEN.Enabled = True
Alamat.Enabled = True
Telp.Enabled = True
End Sub
Sub FormNormal()
Call EMPT
Call FormMati
CKoreksi.Enabled = False
CHapus.Enabled = False
CKeluar.Enabled = True
End Sub
Private Sub ALAMAT_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Simpan: EMPT
End Sub
Private Sub CKeluar_Click()
Unload Me
FMU.SetFocus
End Sub
Private Sub CHapus_Click()
Konfirmasi = MsgBox("Anda yakin akan " _
    & " menghapus pesan ini?", _
    vbYesNo + vbQuestion, "Konfirmasi")
    If Konfirmasi = vbYes Then
        SqlDelete = "DELETE FROM KONSUMEN WHERE  " _
            & " KDKONSUMEN='" & KDKONSUMEN.Text & "'"      
        connect.Execute SqlDelete, , adCmdText
        RsKONSUMEN.Requery
        Call FormNormal
        Call Form_Load
        CKeluar.Enabled = True
    Else
        Call FormNormal
    End If
End Sub
Private Sub CKoreksi_Click()
 If NMKONSUMEN.Text = "" Then
        MsgBox "Nama KONSUMEN tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NMKONSUMEN.SetFocus
    ElseIf Alamat.Text = "" Then
        MsgBox "ALAMAT KONSUMEN tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            Alamat.SetFocus
    ElseIf Telp.Text = "" Then
        MsgBox "Telepon tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            Telp.SetFocus
    Else      
        SqlUpdate = "UPDATE KONSUMEN" _
            & " SET NMKONSUMEN ='" & NMKONSUMEN.Text & "'," _
            & " ALAMAT ='" & Alamat.Text & "', " _
            & " TELP='" & Telp.Text & "' " _
            & " WHERE KDKONSUMEN='" & KDKONSUMEN.Text & "' "                  
        connect.Execute SqlUpdate, , adCmdText
        RsKONSUMEN.Requery
        Call FormNormal      
        MsgBox "Data telah ter_update dalam database !", _
        vbOKOnly + vbInformation, "Konfirmasi"      
        Call Form_Load: CKeluar.Enabled = True
    End If
End Sub
Private Sub CTAMBAH_Click()
Call FormHidup
KDKONSUMEN.Enabled = True
Call BuatKodeKONSUMEN
KDKONSUMEN.Text = kodeKONSUMEN
CKoreksi.Enabled = False
CHapus.Enabled = False
CKeluar.Enabled = True
NMKONSUMEN.SetFocus
End Sub
Sub BuatKodeKONSUMEN()
RsKONSUMEN.Requery
Set RsKONSUMEN = New ADODB.Recordset
RsKONSUMEN.Open "Select * From KONSUMEN ", _
connect, adOpenDynamic, adLockBatchOptimistic
If RsKONSUMEN.BOF Then
kodeKONSUMEN = "0001"
Exit Sub
Else
RsKONSUMEN.MoveLast
kodeKONSUMEN = RsKONSUMEN!KDKONSUMEN
kodeKONSUMEN = Right(kodeKONSUMEN, 4)
kodeKONSUMEN = Val(kodeKONSUMEN) + 1
If Len(kodeKONSUMEN) > 4 Then
MsgBox "Kode KONSUMEN Baru Melewati batas ", vbCritical, "ERROR"
Exit Sub
End If
End If
kodeKONSUMEN = "0" & Format(kodeKONSUMEN, "000")
End Sub
Sub Simpan()
If NMKONSUMEN.Text = "" Then
        MsgBox "Nama KONSUMEN tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NMKONSUMEN.SetFocus
    ElseIf Alamat.Text = "" Then
        MsgBox "ALAMAT KONSUMEN tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            Alamat.SetFocus
    ElseIf Telp.Text = "" Then
        MsgBox "Telepon KONSUMEN tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            Telp.SetFocus
    Else  
        SqlInsert = "INSERT INTO KONSUMEN " _
        & " (KDKONSUMEN ,NMKONSUMEN, ALAMAT, TELP)" _
        & " VALUES('" & KDKONSUMEN.Text & "','" & NMKONSUMEN.Text & "','" & Alamat.Text & "','" & Telp.Text & "')"              
        connect.Execute SqlInsert, , adCmdText
        RsKONSUMEN.Requery
        Call FormNormal
        Call Form_Load    
        MsgBox "Data telah tersimpan dalam database !", _
            vbOKOnly + vbInformation, "Konfirmasi"
    End If
End Sub
Private Sub Form_Load()
Call BukaDatabase
CKoreksi.Enabled = False
CHapus.Enabled = False
Call FormMati
KDKONSUMEN.Enabled = False
FMU.Enabled = False
BKTABLE
End Sub
Private Sub Form_Unload(Cancel As Integer)
FMU.Enabled = True
End Sub
Private Sub KDKONSUMEN_Change()
Call FormHidup
CKoreksi.Enabled = True
CHapus.Enabled = True
Set RsKONSUMEN = New ADODB.Recordset
RsKONSUMEN.Open " Select * from KONSUMEN " & " Where KDKONSUMEN ='" _
& KDKONSUMEN.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsKONSUMEN.EOF
On Error Resume Next
KDKONSUMEN.Text = RsKONSUMEN!KDKONSUMEN
NMKONSUMEN.Text = RsKONSUMEN!NMKONSUMEN
Alamat.Text = RsKONSUMEN!Alamat
Telp.Text = RsKONSUMEN!Telp
RsKONSUMEN.MoveNext
Loop
End Sub
Private Sub KDKONSUMEN_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then NMKONSUMEN.SetFocus
End Sub
Private Sub NMKONSUMEN_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Telp.SetFocus
End Sub
Private Sub Telp_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Alamat.SetFocus
If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Or KeyAscii = vbKeyBack Or KeyAscii = Asc("-")) Then KeyAscii = 0
End Sub

Bentuk Tampilan Formnya seperti ini:
Tampilan Form Input Data Konsumen
Tampilan Form Input Data Konsumen
Tambah form lagi dengan Name: idbarang dan Caption: Input Data Barang,
berikut codingnya:

 
Option Explicit
Dim KBR As String
Sub EMPT()
KBRG.Text = ""
NMBR.Text = ""
HRGBR.Text = ""
STNBR.Text = ""
MRKBR.Text = ""
STK.Text = ""
End Sub
Sub BKTABLE()
Dim baris As Integer
    tabel.Clear
    tabel.Rows = 2
    tabel.Cols = 6
    tabel.FixedRows = 1
    baris = 0
    tabel.TextMatrix(0, 0) = "Kode Barang"
    tabel.TextMatrix(0, 1) = "Nama Barang"
    tabel.TextMatrix(0, 2) = "Harga Barang"
    tabel.TextMatrix(0, 3) = "Satuan Barang"
    tabel.TextMatrix(0, 4) = "Merk Barang"
    tabel.TextMatrix(0, 5) = "Stok"
    tabel.ColWidth(0) = 1200
    tabel.ColWidth(1) = 2500
    tabel.ColWidth(2) = 1500
    tabel.ColWidth(3) = 1000
    tabel.ColWidth(4) = 1500
    tabel.ColWidth(5) = 1000
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open "Select * From BARANG order by KDBARANG", _
connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsBARANG.EOF
            baris = baris + 1
            tabel.Rows = baris + 1
            tabel.TextMatrix(baris, 0) = RsBARANG!KDBARANG
            tabel.TextMatrix(baris, 1) = RsBARANG!NMBARANG
            tabel.TextMatrix(baris, 2) = RsBARANG!HRGBARANG
            tabel.TextMatrix(baris, 3) = RsBARANG!STNBARANG
            tabel.TextMatrix(baris, 4) = RsBARANG!MRKBARANG
            tabel.TextMatrix(baris, 5) = RsBARANG!Stok
RsBARANG.MoveNext
Loop
End Sub
Sub EASY()
Call EMPT
CKoreksi.Enabled = False
CKeluar.Enabled = True
End Sub
Private Sub CKeluar_Click()
Unload Me
FMU.SetFocus
End Sub
Private Sub CHapus_Click()
Konfirmasi = MsgBox("Anda yakin akan " _
    & " menghapus pesan ini?", _
    vbYesNo + vbQuestion, "Konfirmasi")
    If Konfirmasi = vbYes Then
        SqlDelete = "DELETE FROM BARANG WHERE  " _
            & " KDBARANG='" & KBRG.Text & "'"
        connect.Execute SqlDelete, , adCmdText
        RsBARANG.Requery
        Call EASY
        Call Form_Load
        CKeluar.Enabled = True
    Else
        Call EASY
    End If
End Sub
Private Sub CKoreksi_Click()
 If NMBR.Text = "" Then
        MsgBox "Nama Barang tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NMBR.SetFocus
    ElseIf HRGBR.Text = "" Then
        MsgBox "Jenis Barang tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            HRGBR.SetFocus
    ElseIf STNBR.Text = "" Then
        MsgBox "STNBR barang tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            STNBR.SetFocus
    Else
        SqlUpdate = "UPDATE BARANG" _
            & " SET NMBARANG='" & NMBR.Text & "'," _
            & " HRGBARANG='" & HRGBR.Text & "', " _
            & " STNBARANG='" & STNBR.Text & "', " _
            & " MRKBARANG='" & MRKBR.Text & "', " _
            & " STOK='" & STK.Text & "' " _
            & " WHERE KDBARANG='" & KBRG.Text & "' "
        connect.Execute SqlUpdate, , adCmdText
        RsBARANG.Requery
        Call EASY
        MsgBox "Data telah ter_update dalam database !", _
        vbOKOnly + vbInformation, "Konfirmasi"
        Call Form_Load: CKeluar.Enabled = True
    End If
End Sub

Sub Simpan()
If NMBR.Text = "" Then
        MsgBox "Nama Barang tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NMBR.SetFocus
    ElseIf HRGBR.Text = "" Then
        MsgBox "Jenis Barang tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            HRGBR.SetFocus
    ElseIf STNBR.Text = "" Then
        MsgBox "STNBR Barang tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            STNBR.SetFocus
    Else
        SqlInsert = "INSERT INTO BARANG " _
        & " (KDBARANG ,NMBARANG, HRGBARANG, STNBARANG,MRKBARANG,STOK)" _
        & " VALUES('" _
        & KBRG.Text & "','" _
        & NMBR.Text & "','" _
        & HRGBR.Text & "','" _
        & STNBR.Text & "','" _
        & MRKBR.Text & "','" _
        & STK.Text & "')"
        connect.Execute SqlInsert, , adCmdText
        RsBARANG.Requery
        Call EASY
        Call Form_Load
        MsgBox "Data telah tersimpan dalam database !", _
            vbOKOnly + vbInformation, "Konfirmasi"
    End If
End Sub
Private Sub CTAMBAH_Click()
KBRG.Enabled = True
Call BKBR
KBRG.Text = KBR
CKoreksi.Enabled = False
CKeluar.Enabled = True
CHapus.Enabled = False
NMBR.SetFocus
End Sub
Sub BKBR()
RsBARANG.Requery
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open "Select * From BARANG order by KDBARANG", _
connect, adOpenDynamic, adLockBatchOptimistic
If RsBARANG.BOF Then
KBR = "0001"
Exit Sub
Else
RsBARANG.MoveLast
KBR = RsBARANG!KDBARANG
KBR = Right(KBR, 4)
KBR = Val(KBR) + 1
If Len(KBR) > 4 Then
MsgBox "Kode Barang Baru Melewati batas ", vbCritical, "ERROR"
Exit Sub
End If
End If
KBR = "0" & Format(KBR, "000")
End Sub
Private Sub Form_Load()
Call BukaDatabase
CHapus.Enabled = False
CKoreksi.Enabled = False
KBRG.Enabled = False
FMU.Enabled = False
Call BKTABLE
End Sub
Private Sub Form_Unload(Cancel As Integer)
FMU.Enabled = True
End Sub
Private Sub HRGBR_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then STNBR.SetFocus
If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Or KeyAscii = vbKeyBack Or KeyAscii = Asc("-")) Then KeyAscii = 0
End Sub
Private Sub KBRG_Change()
CKoreksi.Enabled = True
CHapus.Enabled = True
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open " Select * from BARANG " & " Where KDBARANG ='" _
& KBRG.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsBARANG.EOF
On Error Resume Next
KBRG.Text = RsBARANG!KDBARANG
HRGBR.Text = RsBARANG!HRGBARANG
NMBR.Text = RsBARANG!NMBARANG
STNBR.Text = RsBARANG!STNBARANG
MRKBR.Text = RsBARANG!MRKBARANG
STK.Text = RsBARANG!Stok
RsBARANG.MoveNext
Loop
End Sub
Private Sub KBRG_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then NMBR.SetFocus
End Sub
Private Sub MRKBR_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then STK.SetFocus
End Sub
Private Sub NMBR_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then HRGBR.SetFocus
End Sub
Private Sub STNBR_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then MRKBR.SetFocus
End Sub
Private Sub STK_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then Simpan: EMPT
If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Or KeyAscii = vbKeyBack Or KeyAscii = Asc("-")) Then KeyAscii = 0
End Sub
Tapilan Form Input Data Barang sebagai berikut:

Tapilan Form Input Data Barang
Tapilan Form Input Data Barang

Lanjut tambah lagi form dengan Name: idjasa Caption: Input Data Jasa.
 
Option Explicit
Dim KJS As String
Sub BKTABLE()
Dim baris As Integer
    tabel.Clear
    tabel.Rows = 2
    tabel.Cols = 4
    tabel.FixedRows = 1
    baris = 0
    tabel.TextMatrix(0, 0) = "Kode Jasa"
    tabel.TextMatrix(0, 1) = "Nama Jasa"
    tabel.TextMatrix(0, 2) = "Satuan Jasa"
    tabel.TextMatrix(0, 3) = "Tarif Jasa"
    tabel.ColWidth(0) = 1200
    tabel.ColWidth(1) = 2500
    tabel.ColWidth(2) = 1500
    tabel.ColWidth(3) = 1000
Set RsJASA = New ADODB.Recordset
RsJASA.Open "Select * From JASA order by KDJASA", _
connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsJASA.EOF
            baris = baris + 1
            tabel.Rows = baris + 1
            tabel.TextMatrix(baris, 0) = RsJASA!KDJASA
            tabel.TextMatrix(baris, 1) = RsJASA!NMJASA
            tabel.TextMatrix(baris, 2) = RsJASA!STNJASA
            tabel.TextMatrix(baris, 3) = RsJASA!TRFJASA
RsJASA.MoveNext
Loop
End Sub
Sub EMPT()
KDJS.Text = ""
NMJS.Text = ""
STJS.Text = ""
TRFJS.Text = ""
End Sub
Sub FormMati()
NMJS.Enabled = False
STJS.Enabled = False
TRFJS.Enabled = False
End Sub
Sub FormHidup()
NMJS.Enabled = True
STJS.Enabled = True
TRFJS.Enabled = True
End Sub
Sub FormNormal()
Call EMPT
Call FormMati
CKoreksi.Enabled = False
CKeluar.Enabled = True
End Sub
Private Sub CKeluar_Click()
Unload Me
FMU.SetFocus
End Sub
Private Sub CHapus_Click()
Konfirmasi = MsgBox("Anda yakin akan " _
    & " menghapus pesan ini?", _
    vbYesNo + vbQuestion, "Konfirmasi")
    If Konfirmasi = vbYes Then
        SqlDelete = "DELETE FROM JASA WHERE  " _
            & " KDJASA='" & KDJS.Text & "'"
     
        connect.Execute SqlDelete, , adCmdText
        RsJASA.Requery
        Call FormNormal
        Call Form_Load
        CKeluar.Enabled = True
    Else
        Call FormNormal
    End If
End Sub
Private Sub CKoreksi_Click()
 If NMJS.Text = "" Then
        MsgBox "Nama jasa tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NMJS.SetFocus
    ElseIf STJS.Text = "" Then
        MsgBox "satuan jasa tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            STJS.SetFocus
    ElseIf TRFJS.Text = "" Then
        MsgBox "tarif jasa tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            TRFJS.SetFocus
    Else
        SqlUpdate = "UPDATE JASA" _
            & " SET NMJASA='" & NMJS.Text & "'," _
            & " STNJASA='" & STJS.Text & "', " _
            & " TRFJASA='" & TRFJS.Text & "' " _
            & " WHERE KDJASA='" & KDJS.Text & "' "
        connect.Execute SqlUpdate, , adCmdText
        RsJASA.Requery
        Call FormNormal
        MsgBox "Data telah ter_update dalam database !", _
        vbOKOnly + vbInformation, "Konfirmasi"
     
        Call Form_Load: CKeluar.Enabled = True
    End If
End Sub
Private Sub CTAMBAH_Click()
Call FormHidup
KDJS.Enabled = True
Call BuatKJS
KDJS.Text = KJS
CKoreksi.Enabled = False
CKeluar.Enabled = True
CHapus.Enabled = False
NMJS.SetFocus
End Sub
Sub BuatKJS()
RsJASA.Requery
Set RsJASA = New ADODB.Recordset
RsJASA.Open "Select * From JASA order by KDJASA", _
connect, adOpenDynamic, adLockBatchOptimistic
If RsJASA.BOF Then
KJS = "0001"
Exit Sub
Else
RsJASA.MoveLast
KJS = RsJASA!KDJASA
KJS = Right(KJS, 4)
KJS = Val(KJS) + 1
If Len(KJS) > 4 Then
MsgBox "Kode Barang Baru Melewati batas ", vbCritical, "ERROR"
Exit Sub
End If
End If
KJS = "0" & Format(KJS, "000")
End Sub
Sub Simpan()
If NMJS.Text = "" Then
        MsgBox "Nama jasa tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NMJS.SetFocus
    ElseIf STJS.Text = "" Then
        MsgBox "satuan jasa tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            STJS.SetFocus
    ElseIf TRFJS.Text = "" Then
        MsgBox "tarif jasa tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            TRFJS.SetFocus
    Else
        SqlInsert = "INSERT INTO JASA " _
        & " (KDJASA ,NMJASA, STNJASA, TRFJASA)" _
        & " VALUES('" _
        & KDJS.Text & "','" _
        & NMJS.Text & "','" _
        & STJS.Text & "','" _
        & TRFJS.Text & "')"
        connect.Execute SqlInsert, , adCmdText
        RsJASA.Requery
        Call FormNormal
        Call Form_Load
        MsgBox "Data telah tersimpan dalam database !", _
            vbOKOnly + vbInformation, "Konfirmasi"
    End If
End Sub
Private Sub Form_Load()
Call BukaDatabase
CHapus.Enabled = False
CKoreksi.Enabled = False
Call FormMati
KDJS.Enabled = False
FMU.Enabled = False
Call BKTABLE
End Sub
Private Sub Form_Unload(Cancel As Integer)
FMU.Enabled = True
End Sub
Private Sub KDJS_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then NMJS.SetFocus
End Sub
Private Sub STJS_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then TRFJS.SetFocus
End Sub
Private Sub KDJS_Change()
Call FormHidup
CKoreksi.Enabled = True
CHapus.Enabled = True
Set RsJASA = New ADODB.Recordset
RsJASA.Open " Select * from JASA " & " Where KDJASA ='" _
& KDJS.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsJASA.EOF
On Error Resume Next
KDJS.Text = RsJASA!KDJASA
STJS.Text = RsJASA!STNJASA
NMJS.Text = RsJASA!NMJASA
TRFJS.Text = RsJASA!TRFJASA
RsJASA.MoveNext
Loop
End Sub
Private Sub NMJS_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then STJS.SetFocus
End Sub
Private Sub TRFJS_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then Simpan: EMPT
If Not (KeyAscii >= Asc("0") And KeyAscii <= Asc("9") Or KeyAscii = vbKeyBack Or KeyAscii = Asc("-")) Then KeyAscii = 0
End Sub


Ini Tampilan Formnya:

Tampilan Input Form Data Jasa
Tampilan Input Form Data Jasa

Tambuh lagi form baru dengan Name: Transaksi dan Caption: Transaksi .
Berikut Codingnya:
 
Option Explicit
Dim KBR As String
Sub EMPT()
HRGBARANG.Text = "0"
Stok.Text = "0"
JMLBARANG.Text = "0"
TOTHARGA.Text = "0"
TRFJASA.Text = "0"
JLMTARIF.Text = "0"
TOTTARIF.Text = "0"
JLMBAYAR.Text = "0"
TTemp.Text = ""
KET.Text = "-"
End Sub
Sub BKONSUM()
RsTRANSAKSI.Requery
Set RsTRANSAKSI = New ADODB.Recordset
RsTRANSAKSI.Open "Select * From TRANSAKSI order by NOTRANSAKSI", _
connect, adOpenDynamic, adLockBatchOptimistic
If RsTRANSAKSI.BOF Then
KBR = "0001"
Exit Sub
Else
RsTRANSAKSI.MoveLast
KBR = RsTRANSAKSI!NOTRANSAKSI
KBR = Right(KBR, 4)
KBR = Val(KBR) + 1
If Len(KBR) > 4 Then
MsgBox "Kode Transaksi Out Of Line ", vbCritical, "Sorry"
Exit Sub
End If
End If
KBR = "0" & Format(KBR, "000")
End Sub
Sub MKTRANS()
Dim vntgjl As Variant
Dim vnDummy As Variant
CNOTRANSAKSI.Clear
Call BukaDatabase
RsTRANSAKSI.Requery
Set RsTRANSAKSI = New ADODB.Recordset
RsTRANSAKSI.Open "Select * From TRANSAKSI order by NOTRANSAKSI", _
connect, adOpenDynamic, adLockBatchOptimistic
   Do While Not RsTRANSAKSI.EOF
      vntgjl = RsTRANSAKSI!NOTRANSAKSI
      If IsNull(vntgjl) Then vntgjl = ""
      CNOTRANSAKSI.AddItem CStr(vntgjl)
      CNOTRANSAKSI.Text = CStr(vntgjl)
      RsTRANSAKSI.MoveNext
   Loop
End Sub
Sub MKKONSUMEN()
Dim vntgjl As Variant
Dim vnDummy As Variant
KDKONSUMEN.Clear
Call BukaDatabase
RsKONSUMEN.Requery
Set RsKONSUMEN = New ADODB.Recordset
RsKONSUMEN.Open "Select * From KONSUMEN order by KDKONSUMEN", _
connect, adOpenDynamic, adLockBatchOptimistic
   Do While Not RsKONSUMEN.EOF
      vntgjl = RsKONSUMEN!KDKONSUMEN
      If IsNull(vntgjl) Then vntgjl = ""
      KDKONSUMEN.AddItem CStr(vntgjl)
      KDKONSUMEN.Text = CStr(vntgjl)
      RsKONSUMEN.MoveNext
   Loop
End Sub
Sub KMBARANG()
Dim vntgjl As Variant
Dim vnDummy As Variant
KDBARANG.Clear
Call BukaDatabase
RsBARANG.Requery
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open "Select * From BARANG order by KDBARANG", _
connect, adOpenDynamic, adLockBatchOptimistic
   Do While Not RsBARANG.EOF
      vntgjl = RsBARANG!KDBARANG
      If IsNull(vntgjl) Then vntgjl = ""
      KDBARANG.AddItem CStr(vntgjl)
      KDBARANG.Text = CStr(vntgjl)
      RsBARANG.MoveNext
   Loop
   KDBARANG.AddItem "-"
End Sub
Sub MAKEBARANG()
Dim vntgjl As Variant
Dim vnDummy As Variant
NMBARANG.Clear
Call BukaDatabase
RsBARANG.Requery
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open "Select * From BARANG order by NMBARANG", _
connect, adOpenDynamic, adLockBatchOptimistic
   Do While Not RsBARANG.EOF
      vntgjl = RsBARANG!NMBARANG
      If IsNull(vntgjl) Then vntgjl = ""
      NMBARANG.AddItem CStr(vntgjl)
      NMBARANG.Text = CStr(vntgjl)
      RsBARANG.MoveNext
   Loop
    NMBARANG.AddItem "-"
End Sub
Sub KMJASA()
Dim vntgjl As Variant
Dim vnDummy As Variant
KDJASA.Clear
Call BukaDatabase
RsJASA.Requery
Set RsJASA = New ADODB.Recordset
RsJASA.Open "Select * From JASA order by KDJASA", _
connect, adOpenDynamic, adLockBatchOptimistic
   Do While Not RsJASA.EOF
      vntgjl = RsJASA!KDJASA
      If IsNull(vntgjl) Then vntgjl = ""
      KDJASA.AddItem CStr(vntgjl)
      KDJASA.Text = CStr(vntgjl)
      RsJASA.MoveNext
   Loop
   KDJASA.AddItem "-"
End Sub
Sub MAKEJASA()
Dim vntgjl As Variant
Dim vnDummy As Variant
NMJASA.Clear
Call BukaDatabase
RsJASA.Requery
Set RsJASA = New ADODB.Recordset
RsJASA.Open "Select * From JASA order by NMJASA", _
connect, adOpenDynamic, adLockBatchOptimistic
   Do While Not RsJASA.EOF
      vntgjl = RsJASA!NMJASA
      If IsNull(vntgjl) Then vntgjl = ""
      NMJASA.AddItem CStr(vntgjl)
      NMJASA.Text = CStr(vntgjl)
      RsJASA.MoveNext
   Loop
   NMJASA.AddItem "-"
End Sub
Private Sub CHapus_Click()
Konfirmasi = MsgBox("Anda yakin akan " _
    & " menghapus pesan ini?", _
    vbYesNo + vbQuestion, "Konfirmasi")
    If Konfirmasi = vbYes Then
        SqlDelete = "DELETE FROM TRANSAKSI WHERE  " _
            & " NOTRANSAKSI='" & NOTRANSAKSI.Text & "'"
        connect.Execute SqlDelete, , adCmdText
        RsTRANSAKSI.Requery
        Call Form_Load
        CKeluar.Enabled = True
    Else
    End If
End Sub
Private Sub CKeluar_Click()
Unload Me
End Sub
Private Sub CKoreksi_Click()
 If NOTRANSAKSI.Text = "" Then
        MsgBox "NO Transaksi tidak boleh kosong!", _
            vbInformation + vbOKOnly, "Perhatian"
            NOTRANSAKSI.SetFocus
    ElseIf KDKONSUMEN.Text = "" Then
        MsgBox "Kode Konsumen belum dipilih!", _
            vbInformation + vbOKOnly, "Perhatian"
            KDKONSUMEN.SetFocus
    ElseIf KDBARANG.Text = "" Then
        MsgBox "Kode Barang belum dipilih", _
            vbInformation + vbOKOnly, "Perhatian"
            KDBARANG.SetFocus
    ElseIf KDJASA.Text = "" Then
        MsgBox "Kode Jasa belum dipilih", _
            vbInformation + vbOKOnly, "Perhatian"
            KDJASA.SetFocus
    Else
        SqlUpdate = "UPDATE TRANSAKSI" _
            & " SET KDKONSUMEN='" & KDKONSUMEN.Text & "'," _
            & " TGLTRANSAKSI='" & TGLTRANS.Text & "', " _
            & " KDBARANG='" & KDBARANG.Text & "', " _
            & " NMBARANG='" & NMBARANG.Text & "', " _
            & " HRGBARANG='" & HRGBARANG.Text & "', " _
            & " STOK='" & Stok.Text & "', " _
            & " JMHBARANG='" & JMLBARANG.Text & "', " _
            & " TOTHARGA='" & TOTHARGA.Text & "', " _
            & " KDJASA='" & KDJASA.Text & "', " _
            & " NMJASA='" & NMJASA.Text & "', " _
            & " TRFJASA='" & TRFJASA.Text & "', " _
            & " JLMTARIF='" & JLMTARIF.Text & "', " _
            & " TOTTARIF='" & TOTTARIF.Text & "', " _
            & " JMLBAYAR='" & JLMBAYAR.Text & "', " _
            & " KET='" & KET.Text & "' " _
            & " WHERE NOTRANSAKSI='" & NOTRANSAKSI.Text & "' "
        connect.Execute SqlUpdate, , adCmdText
        RsTRANSAKSI.Requery
        MsgBox "Data telah ter_update dalam database !", _
        vbOKOnly + vbInformation, "Konfirmasi"
        Call Form_Load: CKeluar.Enabled = True
    End If
End Sub
Private Sub KDBARANG_Click()
NMBARANG.Text = "-"
HRGBARANG.Text = "0"
Stok.Text = "0"
JMLBARANG.Text = "0"
TOTHARGA.Text = "0"
JLMBAYAR.Text = "0"
KET.Text = "-"
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open " Select * from BARANG " & " Where KDBARANG ='" _
& KDBARANG.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsBARANG.EOF
On Error Resume Next
KDBARANG.Text = RsBARANG!KDBARANG
NMBARANG.Text = RsBARANG!NMBARANG
HRGBARANG.Text = RsBARANG!HRGBARANG
Stok.Text = RsBARANG!Stok
KBRG.Text = RsBARANG!KDBARANG
NMBR.Text = RsBARANG!NMBARANG
HRGBR.Text = RsBARANG!HRGBARANG
STNBR.Text = RsBARANG!STNBARANG
MRKBR.Text = RsBARANG!MRKBARANG
STK.Text = RsBARANG!Stok
RsBARANG.MoveNext
Loop
If KDBARANG.Text = "-" Then
    KDBARANG.Text = "-"
    HRGBARANG.Text = "0"
    Stok.Text = "0"
    JMLBARANG.Text = "0"
    TOTHARGA.Text = "0"
    TOTHARGA.Text = "0"
    KET.Text = "0"
End If
End Sub
Private Sub CSAVEAS_Click()
If KDKONSUMEN.Text = "" Then
            KDKONSUMEN.Text = "-"
    ElseIf JMLBARANG.Text = "" Then
            KDBARANG.Text = "-"
            NMBARANG.Text = "-"
            HRGBARANG.Text = "0"
            Stok.Text = "0"
            JMLBARANG.Text = "0"
            TOTHARGA.Text = "0"
    ElseIf NMJASA.Text = "" Then
            KDJASA.Text = "-"
            NMJASA.Text = "-"
            TRFJASA.Text = "0"
            JLMTARIF.Text = "0"
            TOTTARIF.Text = "0"
    ElseIf KET.Text = "" Then
            KET.Text = "-"
    ElseIf JLMBAYAR.Text = "" Then
            JLMBAYAR.SetFocus
    Else
        SqlInsert = "INSERT INTO TRANSAKSI " _
        & " (NOTRANSAKSI,KDKONSUMEN,TGLTRANSAKSI,KDBARANG,NMBARANG,HRGBARANG,STOK,JMHBARANG,TOTHARGA,KDJASA,NMJASA,TRFJASA,JLMTARIF,TOTTARIF,JMLBAYAR,KET)" _
        & " VALUES('" _
        & NOTRANSAKSI.Text & "','" _
        & KDKONSUMEN.Text & "','" _
        & TGLTRANS.Text & "','" _
        & KDBARANG.Text & "','" _
        & NMBARANG.Text & "','" _
        & HRGBARANG.Text & "','" _
        & Stok.Text & "','" _
        & JMLBARANG.Text & "','" _
        & TOTHARGA.Text & "','" _
        & KDJASA.Text & "','" _
        & NMJASA.Text & "','" _
        & TRFJASA.Text & "','" _
        & JLMTARIF.Text & "','" _
        & TOTTARIF.Text & "','" _
        & JLMBAYAR.Text & "','" _
        & KET.Text & "')"
        connect.Execute SqlInsert, , adCmdText
        RsTRANSAKSI.Requery
        SqlUpdate = "UPDATE BARANG" _
            & " SET NMBARANG='" & NMBR.Text & "'," _
            & " HRGBARANG='" & HRGBR.Text & "', " _
            & " STNBARANG='" & STNBR.Text & "', " _
            & " MRKBARANG='" & MRKBR.Text & "', " _
            & " STOK='" & STK.Text & "' " _
            & " WHERE KDBARANG='" & KBRG.Text & "' "
        connect.Execute SqlUpdate, , adCmdText
        RsBARANG.Requery
        EMPT
        TGLTRANS.Text = TglSkrg(Date)
        MKTRANS
        KMBARANG
        KMJASA
        BKTABLE
        FMU.Enabled = False
        MAKEBARANG
        MAKEJASA
        MsgBox "Data telah tersimpan dalam database !", _
            vbOKOnly + vbInformation, "Konfirmasi"
    End If
End Sub
Private Sub CSimpan_Click()
If KDKONSUMEN.Text = "" Then
            KDKONSUMEN.SetFocus
    Else
        SqlInsert = "INSERT INTO TRANSAKSI " _
        & " (NOTRANSAKSI,KDKONSUMEN,TGLTRANSAKSI,KDBARANG,NMBARANG,HRGBARANG,STOK,JMHBARANG,TOTHARGA,KDJASA,NMJASA,TRFJASA,JLMTARIF,TOTTARIF,JMLBAYAR,KET)" _
        & " VALUES('" _
        & NOTRANSAKSI.Text & "','" _
        & KDKONSUMEN.Text & "','" _
        & TGLTRANS.Text & "','" _
        & KDBARANG.Text & "','" _
        & NMBARANG.Text & "','" _
        & HRGBARANG.Text & "','" _
        & Stok.Text & "','" _
        & JMLBARANG.Text & "','" _
        & TOTHARGA.Text & "','" _
        & KDJASA.Text & "','" _
        & NMJASA.Text & "','" _
        & TRFJASA.Text & "','" _
        & JLMTARIF.Text & "','" _
        & TOTTARIF.Text & "','" _
        & JLMBAYAR.Text & "','" _
        & KET.Text & "')"
        connect.Execute SqlInsert, , adCmdText
        RsTRANSAKSI.Requery
        SqlUpdate = "UPDATE BARANG" _
            & " SET NMBARANG='" & NMBR.Text & "'," _
            & " HRGBARANG='" & HRGBR.Text & "', " _
            & " STNBARANG='" & STNBR.Text & "', " _
            & " MRKBARANG='" & MRKBR.Text & "', " _
            & " STOK='" & STK.Text & "' " _
            & " WHERE KDBARANG='" & KBRG.Text & "' "
        connect.Execute SqlUpdate, , adCmdText
        RsBARANG.Requery
        EMPT
        TGLTRANS.Text = TglSkrg(Date)
        MKTRANS
        KMBARANG
        KMJASA
        BKTABLE
        FMU.Enabled = False
        MAKEBARANG
        MAKEJASA
        MsgBox "Data telah tersimpan dalam database !", _
            vbOKOnly + vbInformation, "Konfirmasi"
    End If
End Sub
Private Sub CTAMBAH_Click()
BKONSUM
EMPT
NOTRANSAKSI.Text = KBR
AKTIFBUTTON
Frame2.Enabled = True
End Sub
Private Sub Form_Load()
EMPT
TGLTRANS.Text = TglSkrg(Date)
MKKONSUMEN
MKTRANS
KMBARANG
KMJASA
BKTABLE
FMU.Enabled = False
MAKEBARANG
MAKEJASA
End Sub
Private Sub Form_Unload(Cancel As Integer)
FMU.Enabled = True
End Sub
Private Sub JLMTARIF_Change()
TOTTARIF.Text = Val(JLMTARIF.Text) * Val(TRFJASA.Text)
End Sub
Private Sub JMLBARANG_Change()
If Val(JMLBARANG.Text) > Val(Stok.Text) Then
JMLBARANG.Text = "0"
Else
TOTHARGA.Text = Val(JMLBARANG.Text) * Val(HRGBARANG.Text)
STK.Text = Val(Stok.Text) - Val(JMLBARANG.Text)
End If
End Sub
Private Sub KDJASA_Click()
NMJASA.Text = "-"
TRFJASA.Text = "0"
JLMTARIF.Text = "0"
TOTTARIF.Text = "0"
Set RsJASA = New ADODB.Recordset
RsJASA.Open " Select * from JASA " & " Where KDJASA ='" _
& KDJASA.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsJASA.EOF
On Error Resume Next
KDJASA.Text = RsJASA!KDJASA
NMJASA.Text = RsJASA!NMJASA
TRFJASA.Text = RsJASA!TRFJASA
RsJASA.MoveNext
Loop
If KDJASA.Text = "-" Then
    KDJASA.Text = "-"
    TRFJASA.Text = "0"
    JLMTARIF.Text = "0"
    TOTTARIF.Text = "0"
End If
End Sub
Sub BKTABLE()
Dim baris As Integer
    tabel.Clear
    tabel.Rows = 2
    tabel.Cols = 16
    tabel.FixedRows = 1
    baris = 0
    tabel.TextMatrix(0, 0) = "No Transaksi"
    tabel.TextMatrix(0, 1) = "Kode Konsumen"
    tabel.TextMatrix(0, 2) = "Tanggal Transaksi"
    tabel.TextMatrix(0, 3) = "Kode Barang"
    tabel.TextMatrix(0, 4) = "Nama Barang"
    tabel.TextMatrix(0, 5) = "Harga Barang"
    tabel.TextMatrix(0, 6) = "Stok"
    tabel.TextMatrix(0, 7) = "Jumlah Barang"
    tabel.TextMatrix(0, 8) = "Total Harga"
    tabel.TextMatrix(0, 9) = "Kode Jasa"
    tabel.TextMatrix(0, 10) = "Nama Jasa"
    tabel.TextMatrix(0, 11) = "Tarif Jasa"
    tabel.TextMatrix(0, 12) = "Jumlah Tarif"
    tabel.TextMatrix(0, 13) = "Total Tarif"
    tabel.TextMatrix(0, 14) = "Jumlah Bayar"
    tabel.TextMatrix(0, 15) = "Keterangan"
    tabel.ColWidth(0) = 1500
    tabel.ColWidth(1) = 1500
    tabel.ColWidth(2) = 1500
    tabel.ColWidth(3) = 1500
    tabel.ColWidth(4) = 2500
    tabel.ColWidth(5) = 1500
    tabel.ColWidth(6) = 1000
    tabel.ColWidth(7) = 1000
    tabel.ColWidth(8) = 2000
    tabel.ColWidth(9) = 2000
    tabel.ColWidth(10) = 2000
    tabel.ColWidth(11) = 2000
    tabel.ColWidth(12) = 1500
    tabel.ColWidth(13) = 1500
    tabel.ColWidth(14) = 1500
    tabel.ColWidth(15) = 2500
Set RsTRANSAKSI = New ADODB.Recordset
RsTRANSAKSI.Open "Select * From TRANSAKSI order by NOTRANSAKSI", _
connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsTRANSAKSI.EOF
            baris = baris + 1
            tabel.Rows = baris + 1
            tabel.TextMatrix(baris, 0) = RsTRANSAKSI!NOTRANSAKSI
            tabel.TextMatrix(baris, 1) = RsTRANSAKSI!KDKONSUMEN
            tabel.TextMatrix(baris, 2) = RsTRANSAKSI!TGLTRANSAKSI
            tabel.TextMatrix(baris, 3) = RsTRANSAKSI!KDBARANG
            tabel.TextMatrix(baris, 4) = RsTRANSAKSI!NMBARANG
            tabel.TextMatrix(baris, 5) = RsTRANSAKSI!HRGBARANG
            tabel.TextMatrix(baris, 6) = RsTRANSAKSI!Stok
            tabel.TextMatrix(baris, 7) = RsTRANSAKSI!JMHBARANG
            tabel.TextMatrix(baris, 8) = RsTRANSAKSI!TOTHARGA
            tabel.TextMatrix(baris, 9) = RsTRANSAKSI!KDJASA
            tabel.TextMatrix(baris, 10) = RsTRANSAKSI!NMJASA
            tabel.TextMatrix(baris, 11) = RsTRANSAKSI!TRFJASA
            tabel.TextMatrix(baris, 12) = RsTRANSAKSI!JLMTARIF
            tabel.TextMatrix(baris, 13) = RsTRANSAKSI!TOTTARIF
            tabel.TextMatrix(baris, 14) = RsTRANSAKSI!JMLBAYAR
            tabel.TextMatrix(baris, 15) = RsTRANSAKSI!KET
RsTRANSAKSI.MoveNext
Loop
End Sub
Private Sub KDKONSUMEN_Click()
Set RsKONSUMEN = New ADODB.Recordset
RsKONSUMEN.Open " Select * from KONSUMEN" & " Where KDKONSUMEN ='" _
& KDKONSUMEN.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsKONSUMEN.EOF
On Error Resume Next
NMKONSUMEN.Text = RsKONSUMEN!NMKONSUMEN
RsKONSUMEN.MoveNext
Loop
End Sub
Private Sub NMBARANG_Click()
HRGBARANG.Text = "0"
Stok.Text = "0"
JMLBARANG.Text = "0"
TOTHARGA.Text = "0"
JLMBAYAR.Text = "0"
KET.Text = "-"
Set RsBARANG = New ADODB.Recordset
RsBARANG.Open " Select * from BARANG " & " Where NMBARANG ='" _
& NMBARANG.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsBARANG.EOF
On Error Resume Next
KDBARANG.Text = RsBARANG!KDBARANG
HRGBARANG.Text = RsBARANG!HRGBARANG
Stok.Text = RsBARANG!Stok
KBRG.Text = RsBARANG!KDBARANG
NMBR.Text = RsBARANG!NMBARANG
HRGBR.Text = RsBARANG!HRGBARANG
STNBR.Text = RsBARANG!STNBARANG
MRKBR.Text = RsBARANG!MRKBARANG
STK.Text = RsBARANG!Stok
RsBARANG.MoveNext
Loop
If NMBARANG.Text = "-" Then
    KDBARANG.Text = "-"
    HRGBARANG.Text = "0"
    Stok.Text = "0"
    JMLBARANG.Text = "0"
    TOTHARGA.Text = "0"
    TOTHARGA.Text = "0"
    KET.Text = "-"
End If
JMLBARANG.SetFocus
End Sub
Private Sub NMJASA_Click()
TRFJASA.Text = "0"
JLMTARIF.Text = "0"
TOTTARIF.Text = "0"
Set RsJASA = New ADODB.Recordset
RsJASA.Open " Select * from JASA " & " Where NMJASA ='" _
& NMJASA.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsJASA.EOF
On Error Resume Next
KDJASA.Text = RsJASA!KDJASA
NMJASA.Text = RsJASA!NMJASA
TRFJASA.Text = RsJASA!TRFJASA
RsJASA.MoveNext
Loop
If NMJASA.Text = "-" Then
    KDJASA.Text = "-"
    TRFJASA.Text = "0"
    JLMTARIF.Text = "0"
    TOTTARIF.Text = "0"
End If
TRFJASA.SetFocus
End Sub
Private Sub NOTRANSAKSI_Change()
EMPT
Set RsTRANSAKSI = New ADODB.Recordset
RsTRANSAKSI.Open " Select * from TRANSAKSI " & " Where NOTRANSAKSI ='" _
& NOTRANSAKSI.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsTRANSAKSI.EOF
On Error Resume Next
NOTRANSAKSI.Text = RsTRANSAKSI!NOTRANSAKSI
KDKONSUMEN.Text = RsTRANSAKSI!KDKONSUMEN
TGLTRANS.Text = RsTRANSAKSI!TGLTRANSAKSI
KDBARANG.Text = RsTRANSAKSI!KDBARANG
NMBARANG.Text = RsTRANSAKSI!NMBARANG
HRGBARANG.Text = RsTRANSAKSI!HRGBARANG
Stok.Text = RsTRANSAKSI!Stok
JMLBARANG.Text = RsTRANSAKSI!JMHBARANG
TOTHARGA.Text = RsTRANSAKSI!TOTHARGA
KDJASA.Text = RsTRANSAKSI!KDJASA
NMJASA.Text = RsTRANSAKSI!NMJASA
TRFJASA.Text = RsTRANSAKSI!TRFJASA
JLMTARIF.Text = RsTRANSAKSI!JLMTARIF
TOTTARIF.Text = RsTRANSAKSI!TOTTARIF
JLMBAYAR.Text = RsTRANSAKSI!JMLBAYAR
TTemp.Text = RsTRANSAKSI!JMLBAYAR
KET.Text = RsTRANSAKSI!KET
RsTRANSAKSI.MoveNext
Loop
AKTIFBUTTON
Frame2.Enabled = True
Set RsKONSUMEN = New ADODB.Recordset
RsKONSUMEN.Open " Select * from KONSUMEN" & " Where KDKONSUMEN ='" _
& KDKONSUMEN.Text & "'" _
, connect, adOpenDynamic, adLockBatchOptimistic
Do While Not RsKONSUMEN.EOF
On Error Resume Next
NMKONSUMEN.Text = RsKONSUMEN!NMKONSUMEN
RsKONSUMEN.MoveNext
Loop
End Sub
Private Sub tabel_Click()
On Error GoTo make
NOTRANSAKSI.Text = CNOTRANSAKSI.Text
CNOTRANSAKSI.ListIndex = tabel.RowSel - 1
make:
End Sub
Private Sub TOTHARGA_Change()
JLMBAYAR.Text = Val(TOTHARGA.Text) + Val(TOTTARIF.Text)
End Sub
Private Sub TOTTARIF_Change()
JLMBAYAR.Text = Val(TOTHARGA.Text) + Val(TOTTARIF.Text)
End Sub
Sub AKTIFBUTTON()
If TTemp.Text = "" Then
    CKoreksi.Enabled = False
    CHapus.Enabled = False
    CSimpan.Visible = True
    CSAVEAS.Visible = False
Else
    CKoreksi.Enabled = True
    CHapus.Enabled = True
    CSimpan.Visible = False
    CSAVEAS.Visible = True
End If
End Sub



Berikut Tampilan Dari Form Transaksi:

Tampilan Dari Form Transaksi
Tampilan Dari Form Transaksi
Selanjutnya Anda klik Menu Project- klik Add Module, kemudian copy-paste kan coding dibawah ini:
 
Option Explicit
Public connect As New ADODB.Connection
Public RsKONSUMEN As ADODB.Recordset
Public RsBARANG As ADODB.Recordset
Public RsJASA As ADODB.Recordset
Public RsTRANSAKSI As ADODB.Recordset
Public RsJUALBRG As ADODB.Recordset
Public Rs As ADODB.Recordset
Public StrAkses As String
Public SqlInsert As String
Public SqlDelete As String
Public SqlUpdate As String
Public SQL As String
Public Konfirmasi As String
Public Sub BukaDatabase()
    StrAkses = "Provider=Microsoft.Jet.OLEDB.4.0;Persist " _
          & "Security Info=False;Data Source=" _
          & App.Path + "\DATA.Mdb"
    On Error Resume Next
    If connect.State = adStateOpen Then
        connect.Close
        Set connect = New ADODB.Connection
        connect.Open StrAkses
    Else
        connect.Open StrAkses
    End If
    Set RsKONSUMEN = New ADODB.Recordset
    RsKONSUMEN.Open "SELECT * FROM KONSUMEN", connect, adOpenDynamic, adLockBatchOptimistic
    Set RsBARANG = New ADODB.Recordset
    RsBARANG.Open "SELECT * FROM BARANG", connect, adOpenDynamic, adLockBatchOptimistic
    Set RsJASA = New ADODB.Recordset
    RsJASA.Open "SELECT * FROM JASA", connect, adOpenDynamic, adLockBatchOptimistic
    Set RsTRANSAKSI = New ADODB.Recordset
    RsTRANSAKSI.Open "SELECT * FROM TRANSAKSI", connect, adOpenDynamic, adLockBatchOptimistic
 
    Set RsJUALBRG = New ADODB.Recordset
    RsJUALBRG.Open "SELECT * FROM JUALBRG", connect, adOpenDynamic, adLockBatchOptimistic
End Sub
Public Function TglSkrg(tgl As Date) As String
    TglSkrg = Format(Day(tgl), "00") & "/" _
            & Format(Month(tgl), "00") & "/" _
            & Format(Year(tgl))
End Function
Public Function GetAppPath() As String
    GetAppPath = IIf(Right$(App.Path, 1) = "\", App.Path, App.Path & "\")
End Function



Database pada program aplikasi ini seperti berikut:

Database
Database


Selanjutnya Tampilan Rekap Data Transaksi Penjualan seperti pada gambar dibawah ini:

Rekap Data Transaksi Penjualan
Rekap Data Transaksi Penjualan


Jika anda belum puas dengan artikel ini penulis mohon maaf, karen utnuk menjelaskan satu persatu secara rinci lumayan sulit. Jika anda menginginkan file project vb 6 secara lengkap, anda dapat menghubungi penulis di No HP: 0853-6789-7220.

Penulis akan meminta anda mengirim uang ke alamat rekening yang nantinya penulis tunjuk melalui no handphone. Nominal harga jasa dari aplikasi ini dapat di negosiasikan nantinya.

terima kasih telah berkunjung
Unknown

Share this

Related Posts

Next
« Prev Post
Previous
Next Post »

Masukkan Saran Anda. Komentar Atau Permohonan Terbit Artikel Keinginan Anda

Subscribe to: Post Comments (Atom)