Home contoh program vb 6 program aplikasi pemesanan dan pengiriman barang vb 6

Saturday, March 18, 2017

program aplikasi pemesanan dan pengiriman barang vb 6

Diterbitkan
Tags


Aplikasi Pemesanan Dan Pengiriman Barang VB 6.0

Program pemesanan dan pengiriman barang ini polanya mengikuti program perpustakaan dan rental VCD. Perbedaannya adalah pada program pengiriman barang terdapat tambahan proses, yaitu pada pengisian kurir yang mengirimkan barang pesanan dan biaya sisa yang harus di bayar jika uang muka belum lunas.
Normalisasi File
Program Pesanan ini dirancang dengan Normaliasi level ketiga (3NF) dengan bentuk seperti Gambar 
11.1.



Program pemesanan barang ini menyimpan data ke dua tabel yaitu tabel Pesanan dan DetailPsn seperti terlihat pada tabel-tabel berikut ini.
Tabel Pesanan

Pesanan
Nomorpsn
Tanggalpsn
Totalitem
Totalhrg
DP
Sisa
Nomorksm
KodeKsr
TglMintakrm
Ket
P070905005
05/09/07
3
18500
0
18500
KSM02
KSR01
05/09/07
Belum Dikirim
P070918001
18/09/07
3
7000
0
7000
KSM04
KSR01
18/09/07
Belum Dikirim





Tabel DetailPsn

DetailPsn
Nomorpsn
Kodebrg
Jumlahpsn
P070918001
BRG002
2
P070918001
BRG001
1
P070910001
BRG002
2
P070910001
BRG001
1
P070905005
BRG008
1
P070905005
BRG004
1
P070905005
BRG001
1

Database Dan Tabel

Untuk mengetahui file database dan struktur masing-masing tabel berikut type data dan kunci primer maupun kunci tamunya silakan buka CD pendukung buku ini.



Membuat Module
Untuk memulai membuat program Pesanan, aktifkanlah VB kemudian awali dengan membuat module lalu ketik coding berikut ini.
Coding  :

Public Conn As New ADODB.Connection
Public RSBarang As ADODB.Recordset
Public RSKasir As ADODB.Recordset
Public RSKonsumen As ADODB.Recordset
Public RSPesanan As ADODB.Recordset
Public RSDetailPsn As ADODB.Recordset
Public RSKurir As ADODB.Recordset
Public RSPengiriman As ADODB.Recordset
Public RSDetailKrm As ADODB.Recordset
Public RSTransaksi As ADODB.Recordset

Public Sub BukaDB()
Dim STR As String
Set Conn = New ADODB.Connection
Set RSBarang = New ADODB.Recordset
Set RSKasir = New ADODB.Recordset
Set RSKonsumen = New ADODB.Recordset
Set RSPesanan = New ADODB.Recordset
Set RSDetailPsn = New ADODB.Recordset
Set RSKurir = New ADODB.Recordset
Set RSPengiriman = New ADODB.Recordset
Set RSDetailKrm = New ADODB.Recordset
Set RSTransaksi = New ADODB.Recordset
Conn.Open "PROVIDER=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\ADOPesanan.mdb"
End Sub















Transaksi Pemesanan Barang
Dengan asumsi form login, data kasir, barang, konsumen dan kurir telah dibuat, kini saatnya membuat form Pesanan dengan bentuk seperti Gambar 11.3 berikut ini.









Coding :

Private Sub Form_Activate()
DT.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\ADOPesanan.mdb"
DT.RecordSource = "Transaksi"
Set DataGrid1.DataSource = DT
DataGrid1.Refresh
 
If Kodeksr = "" Then
    MsgBox "Kasir tidak terdeteksi"
    Login.Show
    Exit Sub
End If

Call BukaDB
RSBarang.Open "Barang", Conn
List1.Clear
Do Until RSBarang.EOF
    List1.AddItem RSBarang!KodeBrg & vbTab & RSBarang!NamaBrg
    RSBarang.MoveNext
Loop

RSKonsumen.Open "Konsumen", Conn
Combo1.Clear
Do Until RSKonsumen.EOF
    Combo1.AddItem RSKonsumen!Nomorksm
    RSKonsumen.MoveNext
Loop

Call AutoPsn
Call AutoKsm
Call Tabel_Kosong
DT.Recordset.MoveFirst
Tanggal = Date
TglMintakrm.Value = Date
Nomorksm.Enabled = False
CmdSimpan.Enabled = False
End Sub

Private Sub Form_Load()
    Kodeksr = Login.TxtKodeKsr
    Namaksr = Login.TxtNamaKsr
    DataGrid1.Col = 1
    CmdSimpan.Enabled = False
End Sub

Private Sub Timer1_Timer()
    Jam = Time$
End Sub

Private Sub AutoPsn()
Call BukaDB
RSPesanan.Open ("select * from pesanan Where NomorPsn In(Select Max(NomorPsn)From Pesanan)Order By NomorPsn Desc"), Conn
RSPesanan.Requery
    Dim Urutan As String * 10
    Dim Hitung As Long
    With RSPesanan
        If .EOF Then
            Urutan = "P" + Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2) + "001"
            NomorPsn = Urutan
            Exit Sub
        Else
            If Mid(!NomorPsn, 2, 6) <> Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2) Then
                Urutan = "P" + Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2) + "001"
            Else
                Hitung = Right(!NomorPsn, 9) + 1
                Urutan = "P" + (Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2)) + Right("000" & Hitung, 3)
            End If
        End If
        NomorPsn = Urutan
    End With
End Sub

Private Sub AutoKsm()
Call BukaDB
RSKonsumen.Open ("select * from Konsumen Where NomorKsm In(Select Max(NomorKsm)From Konsumen)Order By NomorKsm Desc"), Conn
RSKonsumen.Requery
    Dim Urutan As String * 5
    Dim Hitung As Long
    With RSKonsumen
        If .EOF Then
            Urutan = "KSM01"
            Nomorksm = Urutan
        Else
            Hitung = Right(!Nomorksm, 2) + 1
            Urutan = "KSM" + Right("00" & Hitung, 2)
        End If
        Nomorksm = Urutan
    End With
End Sub

Private Sub Nomorksm_Change()
Call BukaDB
RSKonsumen.Open "Select * from konsumen where nomorksm='" & Nomorksm & "'", Conn
RSKonsumen.Requery
If Not RSKonsumen.EOF Then
    Namaksm = RSKonsumen!Namaksm
    Alamatksm = RSKonsumen!Alamatksm
    Teleponksm = RSKonsumen!Teleponksm
End If
End Sub

Private Sub teleponksm_KeyPress(Keyascii As Integer)
If Keyascii = 13 Then
    Call BukaDB
    RSKonsumen.Open "Select * from konsumen where teleponksm='" & Teleponksm & "'", Conn
    RSKonsumen.Requery
    If Not RSKonsumen.EOF Then
        Nomorksm = RSKonsumen!Nomorksm
        Namaksm = RSKonsumen!Namaksm
        Alamatksm = RSKonsumen!Alamatksm
        Teleponksm = RSKonsumen!Teleponksm
        List1.SetFocus
    Else
        Namaksm.SetFocus
    End If
End If
If Not (Keyascii >= Asc("0") And Keyascii <= Asc("9") Or Keyascii = vbKeyBack) Then Keyascii = 0
End Sub

Private Sub Namaksm_KeyPress(Keyascii As Integer)
Keyascii = Asc(UCase(Chr(Keyascii)))
If Keyascii = 13 Then
    Call BukaDB
    RSKonsumen.Open "Select * from konsumen where namaksm='" & Namaksm & "'", Conn
    RSKonsumen.Requery
    If Not RSKonsumen.EOF Then
        Nomorksm = RSKonsumen!Nomorksm
        Alamatksm = RSKonsumen!Alamatksm
        Teleponksm = RSKonsumen!Teleponksm
    End If
    Alamatksm.SetFocus
End If
End Sub

Private Sub alamatksm_KeyPress(Keyascii As Integer)
Keyascii = Asc(UCase(Chr(Keyascii)))
If Keyascii = 13 Then
    Call BukaDB
    RSKonsumen.Open "Select * from konsumen where alamatksm='" & Alamatksm & "'", Conn
    RSKonsumen.Requery
    If Not RSKonsumen.EOF Then
        Nomorksm = RSKonsumen!Nomorksm
        Namaksm = RSKonsumen!Namaksm
        Teleponksm = RSKonsumen!Teleponksm
    End If
    DataGrid1.SetFocus
End If
End Sub

Private Sub Combo1_Keypress(Keyascii As Integer)
Keyascii = Asc(UCase(Chr(Keyascii)))
If Keyascii = 13 Then
    If Combo1 = "" Then
        Call AutoKsm
        MsgBox "silakan isi data konsumen baru"
        Kosongksm
        Teleponksm.SetFocus
        Exit Sub
    Else
        DataGrid1.SetFocus
    End If
End If
If Keyascii = 27 Then
    Combo1 = ""
    Call AutoKsm
    MsgBox "silakan isi data konsumen baru"
    Kosongksm
    Teleponksm.SetFocus
    Exit Sub
End If
End Sub

Private Sub Combo1_Click()
    Call BukaDB
    RSKonsumen.Open "Select * from Konsumen where Nomorksm='" & Combo1 & "'", Conn
    If Not RSKonsumen.EOF Then
        Nomorksm = RSKonsumen!Nomorksm
    End If
    Conn.Close
End Sub

Function Tabel_Kosong()
    DT.Recordset.MoveFirst
    Do While Not DT.Recordset.EOF
        DT.Recordset.Delete
        DT.Recordset.MoveNext
    Loop
    For i = 1 To 1
        DT.Recordset.AddNew
        DT.Recordset!Nomor = i
        DT.Recordset.Update
    Next i
    DataGrid1.Col = 1
End Function

Function Tambah_Baris()
    For i = DT.Recordset.RecordCount To DT.Recordset.RecordCount
        DT.Recordset.AddNew
        DT.Recordset!Nomor = i + 1
        DT.Recordset.Update
    Next i
End Function

Private Sub DataGrid1_KeyPress(Keyascii As Integer)
Keyascii = Asc(UCase(Chr(Keyascii)))
End Sub

Private Sub DataGrid1_AfterColEdit(ByVal ColIndex As Integer)
    If DataGrid1.Col = 1 Then
        Call BukaDB
        RSBarang.Open "Select * from Barang where Kodebrg='" & DT.Recordset!Kode & "'", Conn
        If RSBarang.EOF Then
            Pesan = MsgBox("Kode Barang Tidak Terdaftar")
            List1.SetFocus
            Exit Sub
        End If
        DT.Recordset!Kode = RSBarang!KodeBrg
        DT.Recordset!Nama = RSBarang!NamaBrg
        DT.Recordset!Harga = RSBarang!HargaJual
        DataGrid1.Col = 4
        Exit Sub
    End If
   
    If DataGrid1.Col = 4 Then
        DT.Recordset!Jumlah = DT.Recordset!Jumlah
        DT.Recordset!Total = DT.Recordset!Harga * DT.Recordset!Jumlah
        DT.Recordset.Update
        Call Tambah_Baris
        DT.Recordset.MoveNext
        DataGrid1.Col = 1
        DT.Recordset.MoveLast
        DataGrid1.Refresh
        Total = TotalHarga
        JmlItem = TotalItem
    End If
End Sub

Function TotalHarga()
    Set TTlHarga = New ADODB.Recordset
    TTlHarga.Open "select sum(Total) as JumTotal from Transaksi", Conn
    TotalHarga = TTlHarga!JumTotal
End Function

Function TotalItem()
    Set TTlItem = New ADODB.Recordset
    TTlItem.Open "select sum(Jumlah) as JumItem from Transaksi", Conn
    TotalItem = TTlItem!Jumitem
End Function

Private Sub Bersihkan()
    JmlItem = ""
    Total = ""
    DP = ""
    Sisa = ""
    Stok = ""
End Sub


Sub Kosongksm()
Namaksm = ""
Alamatksm = ""
Teleponksm = ""
End Sub

Private Sub DP_KeyPress(Keyascii As Integer)
    If Keyascii = 13 Then
        If DP = "" Then
            DP = 0
            Sisa = Total
        ElseIf DP = Total Then
            Sisa = 0
        ElseIf DP > Val(Total) Then
            MsgBox "Kembali : " & DP - Total & ""
            Sisa = 0
        ElseIf DP < Val(Total) Then
            Sisa = Total - DP
        End If
       
        CmdSimpan.Enabled = True
        CmdSimpan.SetFocus
    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
        CmdSimpan.Enabled = False
        DP = ""
        DP.SetFocus
    End If
End Sub

Sub SimpanKsm()
Call BukaDB
RSKonsumen.Open "select * from konsumen where nomorksm='" & Nomorksm & "'", Conn
RSKonsumen.Requery
If RSKonsumen.EOF Then
    Dim SQLTambahksm As String
    SQLTambahksm = "Insert Into Konsumen(NomorKsm,namaksm,AlamatKsm,Teleponksm)" & _
    "values('" & Nomorksm & "','" & Namaksm & "','" & Alamatksm & "','" & Teleponksm & "')"
    Conn.Execute (SQLTambahksm)
End If
End Sub

Private Sub CmdSimpan_Click()
    If Namaksm = "" Or Alamatksm = "" Or Teleponksm = "" Then
        MsgBox "data pemesan belum lengkap"
        Exit Sub
    End If
   
    Dim Input1 As String
    Input1 = "Insert Into Pesanan(NomorPsn,TanggalPsn,JamPsn,Totalitem,TotalHrg,DP,Sisa,Nomorksm,Kodeksr,TglMintakrm,Ket)" & _
    "values('" & NomorPsn & "','" & Tanggal & "','" & Jam & "','" & JmlItem & "','" & Total & "','" & DP & "','" & Sisa & "','" & Nomorksm & "','" & Kodeksr & "','" & TglMintakrm & "','Belum Dikirim')"
    Conn.Execute (Input1)     
    RSTransaksi.Open "select * from Transaksi", Conn
    RSTransaksi.MoveFirst
    Do While Not RSTransaksi.EOF
        If RSTransaksi!Kode <> vbNullString Then
            Dim SQLTambahDetail As String
            SQLTambahDetail = "Insert Into DetailPsn(Nomorpsn,KodeBrg,Jumlahpsn) " & _
            "values ('" & NomorPsn & "','" & RSTransaksi!Kode & "','" & RSTransaksi!Jumlah & "')"
            Conn.Execute (SQLTambahDetail)
        End If
    RSTransaksi.MoveNext
    Loop
   
    Call SimpanKsm
   
    DT.Recordset.MoveFirst
    Do While Not DT.Recordset.EOF
        If DT.Recordset!Kode <> vbNullString Then
            Call BukaDB
            RSBarang.Open "Select * from Barang where Kodebrg='" & DT.Recordset!Kode & "'", Conn
            If Not RSBarang.EOF Then
                Dim Kurangi As String
                Kurangi = "update barang set jumlahbrg='" & RSBarang!JumlahBrg - DT.Recordset!Jumlah & "' where kodebrg='" & DT.Recordset!Kode & "'"
                Conn.Execute (Kurangi)
            End If
        End If
    DT.Recordset.MoveNext
    Loop
    Bersihkan
    Kosongksm
    Form_Activate
    Call Cetak
End Sub

Private Sub CmdBatal_Click()
    Bersihkan
    Form_Activate
End Sub

Private Sub CmdTutup_Click()
    Unload Me
End Sub

Function Cetak()
Call BukaDB
RSPesanan.Open "select * from Pesanan Where NomorPsn In(Select Max(NomorPsn)From Pesanan)Order By NomorPsn Desc", Conn
Tampilkan.Show
Dim JmlHarga, JmlJual, JmlHasil As Double
Dim MGrs As String
Tampilkan.Font = "Courier New"
Tampilkan.Print
Tampilkan.Print
RSKasir.Open "select * From Kasir where KodeKsr= '" & RSPesanan!Kodeksr & "'", Conn
RSKonsumen.Open "select * From Konsumen where Nomorksm= '" & RSPesanan!Nomorksm & "'", Conn
Tampilkan.Print Tab(5); "Nomor      :   "; RSPesanan!NomorPsn
Tampilkan.Print Tab(5); "Tanggal    :   "; Format(RSPesanan!TanggalPsn, "DD-MMMM-YYYY")
Tampilkan.Print Tab(5); "Jam        :   "; Format(RSPesanan!Jampsn, "HH:MM:SS")
Tampilkan.Print Tab(5); "Kasir      :   "; RSKasir!Namaksr
MGrs = String$(33, "-")
Tampilkan.Print Tab(5); "Pemesan    :   "; RSKonsumen!Namaksm
Tampilkan.Print Tab(5); "Alamat     :   "; RSKonsumen!Alamatksm
Tampilkan.Print Tab(5); "Telepon    :   "; RSKonsumen!Teleponksm
Tampilkan.Print Tab(5); MGrs
RSDetailPsn.Open "select * from detailpsn Where NomorPsn='" & RSPesanan!NomorPsn & "'", Conn
RSDetailPsn.MoveFirst
no = 0
Do While Not RSDetailPsn.EOF
    no = no + 1
    Set RSBarang = New ADODB.Recordset
    RSBarang.Open "select * From Barang where Kodebrg= '" & RSDetailPsn!KodeBrg & "'", Conn
    RSBarang.Requery
    Harga = RSBarang!HargaJual
    Jumlah = RSDetailPsn!JumlahPsn
    Hasil = Harga * Jumlah
    Tampilkan.Print Tab(5); no; Space(2); RSBarang!NamaBrg
    Tampilkan.Print Tab(10); RKanan(Jumlah, "##"); Space(1); "X";
    Tampilkan.Print Tab(15); Format(Harga, "###,###,###");
    Tampilkan.Print Tab(25); RKanan(Hasil, "###,###,###")
    RSDetailPsn.MoveNext
Loop
Tampilkan.Print Tab(5); MGrs
Tampilkan.Print Tab(5); "Total      :";
Tampilkan.Print Tab(25); RKanan(RSPesanan!totalhrg, "###,###,###");
Tampilkan.Print Tab(5); "Uang Muka  :";
Tampilkan.Print Tab(25); RKanan(RSPesanan!DP, "###,###,###");
Tampilkan.Print Tab(5); MGrs
Tampilkan.Print Tab(5); "Sisa       :";
Tampilkan.Print Tab(25); RKanan(RSPesanan!Sisa, "###,###,###");
Tampilkan.Print Tab(5); MGrs
Tampilkan.Print
Tampilkan.Print
Tampilkan.Print
Conn.Close
End Function

Private Function RKanan(NData, CFormat) As String
    RKanan = Format(NData, CFormat)
    RKanan = Space(Len(CFormat) - Len(RKanan)) + RKanan
End Function

Private Sub List1_keyPress(Keyascii As Integer)
    If Keyascii = 13 Then
        If DataGrid1.SelText <> Left(List1, 6) Then
            DataGrid1.SelText = Left(List1, 6)
            DT.Recordset.Update
            Call BukaDB
            RSBarang.Open "Select * from Barang where KodeBrg='" & Left(List1, 6) & "'", Conn
            RSBarang.Requery
            If Not RSBarang.EOF Then
                DT.Recordset!Kode = RSBarang!KodeBrg
                DT.Recordset!Nama = RSBarang!NamaBrg
                DT.Recordset!Harga = RSBarang!HargaJual
                Stok = RSBarang!JumlahBrg
                DT.Recordset.Update
                DataGrid1.SetFocus
                DataGrid1.Col = 4
            End If
        End If
    End If
End Sub
Transaksi Pengiriman Barang
Logika dasar dalam program pengiriman barang ini adalah membaca kembali data yang telah disimpan dalam tabel pesanan dan detailpsn, kemudian kirimkan oleh kurir dan isilah berapa sisa pembayarannya. Setelah itu berilah keterangan di tabel pesanan bahwa data dengan nomor kirim tersebut telah dikirimkan.



Coding :

Private Sub Form_Activate()
DT.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & App.Path & "\ADOPesanan.mdb"
DT.RecordSource = "Transaksi1"
Set DataGrid1.DataSource = DT
DataGrid1.Refresh
   
If Kodeksr = "" Then
    MsgBox "Kasir tidak terdeteksi"
    Login.Show
    Exit Sub
End If

Call Autokrm
Call Tabel_Kosong
Tanggal = Date
CmdSimpan.Enabled = False
Combo1.SetFocus

Call BukaDB
RSPesanan.Open "Select * from Pesanan where ket='BELUM DIKIRIM'", Conn
Combo1.Clear
Do Until RSPesanan.EOF
    Combo1.AddItem RSPesanan!NomorPsn
    RSPesanan.MoveNext
Loop
   
RSKurir.Open "Select * from kurir ", Conn
Combo2.Clear
Do Until RSKurir.EOF

    Combo2.AddItem RSKurir!Kodekrr
    RSKurir.MoveNext
Loop
Conn.Close
End Sub

Private Sub Form_Load()
    Kodeksr = Login.TxtKodeKsr
    Namaksr = Login.TxtNamaKsr
    DataGrid1.Col = 1
    CmdSimpan.Enabled = False
End Sub

Private Sub Autokrm()
Call BukaDB
RSPengiriman.Open ("select * from pengiriman Where Nomorkrm In(Select Max(Nomorkrm)From Pengiriman)Order By Nomorkrm Desc"), Conn
RSPengiriman.Requery
    Dim Urutan As String * 10
    Dim Hitung As Long
    With RSPengiriman
        If .EOF Then
            Urutan = "K" + Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2) + "001"
            Nomorkrm = Urutan
        Else
            If Mid(!Nomorkrm, 2, 6) <> Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2) Then
                Urutan = "K" + Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2) + "001"
            Else
                Hitung = Mid(!Nomorkrm, 9) + 1
                Urutan = "K" + (Right(Date, 2) + Mid(Date, 4, 2) + Left(Date, 2)) + Right("000" & Hitung, 3)
            End If
        End If
        Nomorkrm = Urutan
    End With
End Sub

Function Tabel_Kosong()
If DT.Recordset.RecordCount > 0 Then
    DT.Recordset.MoveFirst
    Do While Not DT.Recordset.EOF
        DT.Recordset.Delete
        DT.Recordset.MoveNext
    Loop
End If
End Function

Private Sub Combo1_Keypress(Keyascii As Integer)
If Keyascii = 27 Then Unload Me
If Keyascii = 13 Then
    Call BukaDB
    RSPesanan.Open "Select * from Pesanan where nomorpsn='" & Combo1 & "'", Conn
    RSPesanan.Requery
    If RSPesanan.EOF Then
        MsgBox "Nomor pesanan tidak terdaftar"
        Combo1.SetFocus
        Exit Sub
    Else
        Combo2.SetFocus
    End If
End If

End Sub

Private Sub Combo1_Click()
Call BukaDB
RSPesanan.Open "Select * from Pesanan where nomorpsn='" & Combo1 & "'", Conn
RSPesanan.Requery
If Not RSPesanan.EOF Then
    TglMintakrm = CDate(RSPesanan!TglMintakrm)
    Total = Format(RSPesanan!TotalHrg, "###,###,###")
    Sisa = Format(RSPesanan!Sisa, "###,###,###")
    DP = Format(RSPesanan!DP, "###,###,###")
   
    If Total = Sisa Then
        DP = 0
    Else
        DP = Format(RSPesanan!DP, "###,###,###")
    End If
   
    If Val(DP) >= Val(Total) Then
        Sisa = 0
        Kembali = 0
    Else
        Sisa = Format(RSPesanan!Sisa, "###,###,###")
    End If
   
    JmlItem = Val(RSPesanan!TotalItem)
    NomorKsm = RSPesanan!NomorKsm
    Dim RS As New ADODB.Recordset
    RS.Open "select barang.kodebrg,barang.namabrg,barang.hargajual,jumlahpsn,hargajual*jumlahpsn as total  from barang,detailpsn where left(nomorpsn,10)='" & Combo1 & "' and barang.kodebrg=detailpsn.kodebrg", Conn
    Call Tabel_Kosong
    RS.MoveFirst
    Nomor = 0
    Do While Not RS.EOF
        Nomor = Nomor + 1
        DT.Recordset.AddNew
        DT.Recordset!Nomor = Nomor
        DT.Recordset!Kode = RS!KodeBrg
        DT.Recordset!Nama = RS!NamaBrg
        DT.Recordset!Harga = RS!HargaJual
        DT.Recordset!Jumlah = RS!JumlahPsn
        DT.Recordset!Total = RS!Total
        DT.Recordset.Update
        RS.MoveNext
    Loop
Else
    MsgBox "nomor pesanan tidak terdaftar"
    Combo1.SetFocus
    Exit Sub
End If
End Sub

Private Sub Nomorksm_Change()
Call BukaDB
RSKonsumen.Open "Select * from konsumen where nomorksm='" & NomorKsm & "'", Conn
RSKonsumen.Requery
If Not RSKonsumen.EOF Then
    NamaKsm = RSKonsumen!NamaKsm
    AlamatKsm = RSKonsumen!AlamatKsm
    TeleponKsm = RSKonsumen!TeleponKsm
End If
End Sub

Private Sub Combo2_click()
Call BukaDB
RSKurir.Open "select * from kurir where kodekrr='" & Combo2 & "'", Conn
If Not RSKurir.EOF Then
    NamaKrr = RSKurir!NamaKrr
Else
    MsgBox "kode kurir tidak terdaftar"
    Combo2.SetFocus
End If
Conn.Close
End Sub

Private Sub Combo2_KeyPress(Keyascii As Integer)
Keyascii = Asc(UCase(Chr(Keyascii)))
If Keyascii = 13 Then
    Call BukaDB
    RSKurir.Open "select * from kurir where kodekrr='" & Combo2 & "'", Conn
    If Not RSKurir.EOF Then
        NamaKrr = RSKurir!NamaKrr
    Else
        MsgBox "kode kurir tidak terdaftar"
        Combo2.SetFocus
        Exit Sub
    End If
   
    If Val(DP) >= Val(Total) Then
        Dibayar.Enabled = False
        Dibayar = 0
        CmdSimpan.Enabled = True
        CmdSimpan.SetFocus
    Else
        Dibayar.Enabled = True
        Dibayar.SetFocus
    End If
End If
End Sub

Private Sub Dibayar_KeyPress(Keyascii As Integer)
    If Keyascii = 13 Then
        If Dibayar = "" Or Val(Dibayar) < (Sisa) Then
            MsgBox "Jumlah Pembayaran Kurang"
            Dibayar.SetFocus
        Else
            Dibayar = Format(Dibayar, "###,###,###")
            If Dibayar = Sisa Then
                Kembali = Dibayar - Sisa
            Else
                Kembali = Format(Dibayar - Sisa, "###,###,###")
            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 Timer1_Timer()
    Jam = Time$
End Sub




Private Sub Bersihkan()
    Combo1 = ""
    JmlItem = ""
    Total = ""
    DP = ""
    Sisa = ""
    TglMintakrm = ""
    Combo2 = ""
    Dibayar = ""
    NomorKsm = ""
    NamaKsm = ""
    AlamatKsm = ""
    TeleponKsm = ""
    Kembali = ""
    NamaKrr = ""
End Sub

Private Sub CmdSimpan_Click()
    If Combo1 = "" Or Combo2 = "" Then
        MsgBox "data pengiriman belum lengkap"
        Exit Sub
    Else
        If Sisa <> 0 And Dibayar = "" Then
            MsgBox "Pembayaran belum lunas"
            Dibayar.SetFocus
            Exit Sub
        End If
    End If
   
    'simpan ke tabel pengiriman
    Dim SimpanPesanan As String
    SimpanPesanan = "Insert Into Pengiriman(Nomorkrm,Nomorpsn,Tanggalkrm,Total,DP,Sisa,Dibayar,Kembali,Nomorksm,Kodeksr,Kodekrr)" & _
    "values('" & Nomorkrm & "','" & Combo1 & "','" & Tanggal & "','" & Total & "','" & DP & "','" & Sisa & "','" & Dibayar & "','" & Kembali & "','" & NomorKsm & "','" & Kodeksr & "','" & Combo2 & "')"
    Conn.Execute (SimpanPesanan)
   
    'ubah ket di tabel pesanan
    Dim SimpanPesanan1 As String
    SimpanPesanan1 = "Update Pesanan set Ket='TELAH DIKIRIM' where nomorpsn='" & Combo1 & "'"
    Conn.Execute (SimpanPesanan1)
   
    'simpan ke tabel detailkrm
    DT.Recordset.MoveFirst
    Do While Not DT.Recordset.EOF
        Dim SimpanDetailPsn As String
        SimpanDetailPsn = "Insert Into Detailkrm(Nomorkrm,KodeBrg,Jumlahkrm) " & _
        "values ('" & Nomorkrm & "','" & DT.Recordset!Kode & "','" & DT.Recordset!Jumlah & "')"
        Conn.Execute (SimpanDetailPsn)
    DT.Recordset.MoveNext
    Loop
      
    Bersihkan
    Form_Activate
End Sub

Private Sub CmdBatal_Click()
Conn.Close
Bersihkan
Form_Activate
End Sub

Private Sub CmdTutup_Click()
    Unload Me
End Sub

Catatan :

Dalam CD pendukung buku kami telah membuat program ini lengkap dengan laporan yang sifatnya parsial dan laporan akumulasi baik pemesanan maupun pengiriman barang. Selain itu telah dibuatkan pula program rincian pemesanan dan pengiriman barang. Silakan dilihat programnya satu persatu.

Artikel Terkait

uus rusmawan

Next Post
Previous Post


EmoticonEmoticon

Subscribe to: Post Comments (Atom)