Pada posting kali ini admin akan melakukan sharing tentang kode program aplikasi penjualan dan pembelian alat optik.
Kode Program dibuat menggunakan Bahasa Pemrograman Visual Basic 6 dan database Ms.Access. Untuk lebih jelasnya berikut tampilan program form input data penjualan.
Listing Code Program sebagai berikut :
Dim dataasal As Database
Dim tabelasal As Recordset
Dim tabelcari1, tabelcari2, tabelcari3 As Recordset
Dim qcari1, qcari2 As Recordset
Dim isibaru As String
Dim tfi, tft As String
Private Sub cetak_Click()
If sumberdata.rssqlnotajual_Grouping.State = adStateOpen Then sumberdata.rssqlnotajual_Grouping.Close
sumberdata.sqlnotajual_Grouping Text1.Text
If sumberdata.rssqlnotajual_Grouping.RecordCount = 0 Then
MsgBox "Data belum ada atau tabel masih kosong!"
Else
lapnotajual.Show
End If
End Sub
Private Sub Check1_Click()
If Check1.Value = 1 Then
Text27.Enabled = True
Else
Text27.Enabled = False
End If
End Sub
Private Sub Form_Load()
Set dataasal = OpenDatabase(App.Path & "\jualbeli.mdb")
Set tabelasal = dataasal.OpenRecordset("penjualan", dbOpenDynaset)
Set tabelcari1 = dataasal.OpenRecordset("pelanggan", dbOpenDynaset)
Set tabelcari2 = dataasal.OpenRecordset("barang", dbOpenDynaset)
Set tabelcari3 = dataasal.OpenRecordset("rincijual", dbOpenDynaset)
Set qcari1 = dataasal.OpenRecordset("qjual", dbOpenDynaset)
Set qcari2 = dataasal.OpenRecordset("qrjual", dbOpenDynaset)
Set Data1.Recordset = qcari1
Set Data2.Recordset = qcari2
Set Data3.Recordset = tabelcari2
If tabelcari1.RecordCount > 0 Then
Do While tabelcari1.EOF = False
Combo1.AddItem tabelcari1("kdplg")
tabelcari1.MoveNext
Loop
End If
If tabelasal.RecordCount > 0 Then
tft = "True"
Call aturtombol(tft)
Call isiantampil
Call seleksirinci
Else
tft = "False"
Call aturtombol(tft)
baru.Enabled = True
tutup.Enabled = True
Call isiankosong
End If
tfi = "False"
Call aturisian(tfi)
isibaru = "T"
Picture1.Visible = False
End Sub
Private Sub baru_Click()
Dim info, dasar, batasan As String
If baru.Caption = "&Baru" Then
baru.Caption = "&Simpan"
baru.ToolTipText = "Menyimpan Data"
rubah.Caption = "&Batal"
rubah.ToolTipText = "Membatalkan Data"
isibaru = "Y"
Call isiankosong
If tabelasal.RecordCount > 0 Then
tabelasal.MoveLast
nourut = Val(Right(tabelasal("nojual"), 8)) + 1
If nourut < 10 Then
Text1 = "NJ0000000" + LTrim(Str(nourut))
ElseIf nourut < 100 Then
Text1 = "NJ000000" + LTrim(Str(nourut))
ElseIf nourut < 1000 Then
Text1 = "NJ00000" + LTrim(Str(nourut))
ElseIf nourut < 10000 Then
Text1 = "NJ0000" + LTrim(Str(nourut))
ElseIf nourut < 100000 Then
Text1 = "NJ000" + LTrim(Str(nourut))
ElseIf nourut < 1000000 Then
Text1 = "NJ00" + LTrim(Str(nourut))
ElseIf nourut < 10000000 Then
Text1 = "NJ0" + LTrim(Str(nourut))
ElseIf nourut < 100000000 Then
Text1 = "NJ" + LTrim(Str(nourut))
Else
Text1 = "NJ00000000"
End If
Else
Text1 = "NJ00000001"
End If
DBGrid1.Enabled = False
tfi = "True"
Call aturisian(tfi)
Text27.Enabled = False
tft = "False"
Call aturtombol(tft)
Text7.Text = memkdkary
Text8.Text = memnmkary
baru.Enabled = True
rubah.Enabled = True
Combo1.SetFocus
Else
If Combo1.Text = " " Then
p = MsgBox("Data pelanggan atau detail barang belum diisi...!", vbOKOnly + vbInformation, "Informasi")
Else
If Val(Text9.Text) = 0 Then
Call seleksirinci
End If
dasar = Text1.Text
batasan = "nojual='" & dasar & "'"
tabelasal.FindFirst batasan
If tabelasal.NoMatch Then
tabelasal.AddNew
Call simpanisian
tabelasal.Update
Else
tabelasal.Edit
Call simpanisian
tabelasal.Update
End If
baru.Caption = "&Baru"
baru.ToolTipText = "Mengisi Data Baru"
rubah.Caption = "&Rubah"
rubah.ToolTipText = "Merubah Data"
tft = "True"
Call aturtombol(tft)
tfi = "False"
Call aturisian(tfi)
tabelasal.MoveLast
Set qcari1 = dataasal.OpenRecordset("qjual", dbOpenDynaset)
Set Data1.Recordset = qcari1
DBGrid1.Enabled = True
DBGrid1.ReBind
isibaru = "T"
Picture1.Visible = False
End If
End If
End Sub
Private Sub isidetail_Click()
Dim info
If Combo1.Text = " " Then
info = MsgBox("Data pelanggan belum diisi", 0 + 64, "Informasi")
Else
Picture1.Visible = True
Call bersihdetail
Text2.SetFocus
End If
End Sub
Private Sub OK_Click()
Dim info
Dim dasar1, dasar2, batasan
If Text10.Text = " " Then
info = MsgBox("Data barang belum terdaftar/dipilih", 0 + 64, "Informasi")
Text2.SetFocus
Else
dasar1 = Text1.Text
dasar2 = Text2.Text
batasan = "nojual='" & dasar1 & "' and kdbrg='" & dasar2 & "'"
tabelcari3.FindFirst batasan
If tabelcari3.NoMatch Then
tabelcari3.AddNew
Call simpandetail
tabelcari3.Update
Else
tabelcari3.Edit
Call simpandetail
tabelcari3.Update
End If
Call kurangstok
Call bersihdetail
Text2.SetFocus
End If
End Sub
Private Sub rubah_Click()
If rubah.Caption = "&Rubah" Then
baru.Caption = "&Simpan"
baru.ToolTipText = "Menyimpan Data"
rubah.Caption = "&Batal"
rubah.ToolTipText = "Membatalkan Data"
tfi = "True"
Call aturisian(tfi)
tft = "False"
Call aturtombol(tft)
baru.Enabled = True
rubah.Enabled = True
DTPicker1.SetFocus
Else
baru.Caption = "&Baru"
baru.ToolTipText = "Mengisi Data Baru"
rubah.Caption = "&Rubah"
rubah.ToolTipText = "Merubah Data"
If tabelasal.RecordCount > 0 Then
tft = "True"
Call aturtombol(tft)
Call isiantampil
Else
tft = "False"
Call aturtombol(tft)
baru.Enabled = True
tutup.Enabled = True
Call isiankosong
End If
tfi = "False"
Call aturisian(tfi)
Set qcari1 = dataasal.OpenRecordset("qjual", dbOpenDynaset)
Set Data1.Recordset = qcari1
DBGrid1.Enabled = True
isibaru = "T"
End If
End Sub
Private Sub hapus_Click()
Dim hapus
Dim dasar, batasan As String
hapus = MsgBox("Yakin akan dihapus ?", 4 + 32, "Konfirmasi")
If hapus = 6 Then
dasar = Text1.Text
batasan = "nojual='" & dasar & "'"
tabelasal.FindFirst batasan
If tabelasal.NoMatch Then
MsgBox "Tidak ada data yang dihapus"
Else
tabelasal.Delete
End If
If tabelasal.RecordCount > 0 Then
tabelasal.MoveNext
Else
tabelasal.MoveFirst
End If
Set qcari1 = dataasal.OpenRecordset("qjual", dbOpenDynaset)
Set Data1.Recordset = qcari1
DBGrid1.ReBind
End If
End Sub
Private Sub selesai_Click()
Dim dasar As String
Call seleksirinci
Text26.Text = Val(Text9.Text) - Val(Text25.Text)
dasar = Text1.Text
batasan = "nojual='" & dasar & "'"
tabelasal.FindFirst batasan
If tabelasal.NoMatch Then
tabelasal.AddNew
Call simpanisian
tabelasal.Update
Else
tabelasal.Edit
Call simpanisian
tabelasal.Update
End If
Picture1.Visible = False
End Sub
Private Sub Text1_Change()
Call seleksirinci
End Sub
Private Sub Text14_Change()
Text16.Text = Val(Text14.Text) * Val(Text15.Text)
End Sub
Private Sub Text15_Change()
If Val(Text15.Text) > Val(Text28.Text) Then
MsgBox "Jumlah stok tidak memadai..!"
OK.Enabled = False
Text15.SetFocus
Else
OK.Enabled = True
Text16.Text = Val(Text14.Text) * Val(Text15.Text)
End If
End Sub
Private Sub Text17_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text17.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text17.SetFocus
Else
Text18.SetFocus
End If
End If
End Sub
Private Sub Text18_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text18.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text18.SetFocus
Else
Text19.SetFocus
End If
End If
End Sub
Private Sub Text19_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text19.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text19.SetFocus
Else
Text20.SetFocus
End If
End If
End Sub
Private Sub Text2_Change()
Call caribarang
End Sub
Private Sub Text20_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text20.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text20.SetFocus
Else
Text21.SetFocus
End If
End If
End Sub
Private Sub Text21_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text21.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text21.SetFocus
Else
Text22.SetFocus
End If
End If
End Sub
Private Sub Text22_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text22.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text22.SetFocus
Else
Text23.SetFocus
End If
End If
End Sub
Private Sub Text23_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text23.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text23.SetFocus
Else
Text24.SetFocus
End If
End If
End Sub
Private Sub Text24_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text24.Text)) > 8 Then
MsgBox ("Isian tidak valid, maksimal 8 karakter")
Text24.SetFocus
Else
baru.SetFocus
End If
End If
End Sub
Private Sub Text25_Change()
If Val(Text25.Text) <= Val(Text9.Text) Then
Text26.Text = Val(Text9.Text) - Val(Text25.Text)
Else
MsgBox "Uang muka melebihi nilai transaksi..!"
Text26.Text = 0
End If
End Sub
Private Sub Text27_Change()
If Val(Text27.Text) < 100 Then
Text25.Text = (Val(Text27.Text) / 100) * Val(Text9.Text)
Else
MsgBox "Prosentase diskon tidak valid..!"
End If
End Sub
Private Sub tutup_Click()
Unload Me
End Sub
Private Sub DBGrid1_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
If isibaru = "T" Then
Call isiantampil
End If
End Sub
Private Sub DBGrid3_DblClick()
Text2.Text = tabelcari2("kdbrg")
End Sub
Private Sub DBGrid3_RowColChange(LastRow As Variant, ByVal LastCol As Integer)
Text2.Text = tabelcari2("kdbrg")
End Sub
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Len(Trim(Text1.Text)) > 10 Then
MsgBox ("Isian tidak valid, maksimal 10 karakter")
Text1.SetFocus
Else
DTPicker1.SetFocus
End If
End If
End Sub
Private Sub DTPicker1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Combo1.SetFocus
End If
End Sub
Private Sub DBGrid3_Click()
Text2.Text = tabelcari2("kdbrg")
Text15.SetFocus
End Sub
Private Sub combo1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Text17.SetFocus
End If
End Sub
Private Sub Combo1_Change()
Call caripelanggan
End Sub
Private Sub Combo1_Click()
Call caripelanggan
End Sub
Private Sub isiankosong()
Text1.Text = " "
DTPicker1.Value = Date
Combo1.Text = " "
Text3.Text = " "
Text4.Text = " "
Text5.Text = " "
Text6.Text = " "
Text7.Text = " "
Text8.Text = " "
Text17.Text = " "
Text18.Text = " "
Text19.Text = " "
Text20.Text = " "
Text21.Text = " "
Text22.Text = " "
Text23.Text = " "
Text24.Text = " "
Text25.Text = 0
Text26.Text = 0
Text27.Text = 0
DTPicker2.Value = Date
Check1.Value = 0
End Sub
Public Sub simpanisian()
With tabelasal
!nojual = Text1.Text
!tglterima = DTPicker1.Value
!kdplg = Combo1.Text
!kdkary = Text7.Text
!rsph = Text17.Text
!rcyl = Text18.Text
!raxis = Text19.Text
!rpd = Text20.Text
!lsph = Text21.Text
!lcyl = Text22.Text
!laxis = Text23.Text
!aadd = Text24.Text
!tglselesai = DTPicker2.Value
!niltrans = Text9.Text
!nilaidiskon = Text25.Text
!bayar = Text26.Text
!pdis = Text27.Text
On Error GoTo 0
End With
End Sub
Public Sub isiantampil()
If qcari1.EOF = False Then
Text1.Text = qcari1("nojual")
DTPicker1.Value = qcari1("tglterima")
Combo1.Text = qcari1("kdplg")
Text3.Text = qcari1("nmplg")
Text4.Text = qcari1("almplg")
Text5.Text = qcari1("kotaplg")
Text6.Text = qcari1("telpplg")
Text7.Text = qcari1("kdkary")
Text8.Text = qcari1("nmkary")
Text17.Text = qcari1("rsph")
Text18.Text = qcari1("rcyl")
Text19.Text = qcari1("raxis")
Text20.Text = qcari1("rpd")
Text21.Text = qcari1("lsph")
Text22.Text = qcari1("lcyl")
Text23.Text = qcari1("laxis")
Text24.Text = qcari1("aadd")
Text9.Text = qcari1("niltrans")
Text25.Text = qcari1("nilaidiskon")
DTPicker2.Value = qcari1("tglselesai")
Text26.Text = qcari1("bayar")
Text27.Text = qcari1("pdis")
If Val(Text27.Text) > 0 Then
Check1.Value = 1
Else
Check1.Value = 0
End If
Else
Call isiankosong
End If
End Sub
Public Sub aturisian(tfi)
DTPicker1.Enabled = tfi
Combo1.Enabled = tfi
Text17.Enabled = tfi
Text18.Enabled = tfi
Text19.Enabled = tfi
Text20.Enabled = tfi
Text21.Enabled = tfi
Text22.Enabled = tfi
Text23.Enabled = tfi
Text24.Enabled = tfi
DTPicker2.Enabled = tfi
Check1.Enabled = tfi
Text27.Enabled = tfi
End Sub
Public Sub aturtombol(tft)
baru.Enabled = tft
rubah.Enabled = tft
hapus.Enabled = tft
cetak.Enabled = tft
tutup.Enabled = tft
End Sub
Public Sub caripelanggan()
Dim dasar, batasan As String
dasar = Combo1.Text
batasan = "kdplg='" & dasar & "'"
tabelcari1.FindFirst batasan
If tabelcari1.NoMatch Then
Text3.Text = " "
Text4.Text = " "
Text5.Text = " "
Text6.Text = " "
Else
Text3.Text = tabelcari1("nmplg")
Text4.Text = tabelcari1("almplg")
Text5.Text = tabelcari1("kotaplg")
Text6.Text = tabelcari1("telpplg")
End If
End Sub
Private Sub tutupisi_Click()
Picture1.Visible = False
End Sub
Public Sub caribarang()
Dim dasar, batasan As String
dasar = Text2.Text
batasan = "kdbrg='" & dasar & "'"
tabelcari2.FindFirst batasan
If tabelcari2.NoMatch Then
Text10.Text = " "
Text11.Text = " "
Text12.Text = " "
Text13.Text = " "
Text14.Text = 0
Else
Text10.Text = tabelcari2("jenis")
Text11.Text = tabelcari2("merek")
Text12.Text = tabelcari2("bahan")
Text13.Text = tabelcari2("model")
Text14.Text = tabelcari2("hargaj")
Text28.Text = tabelcari2("stok")
Text15.SetFocus
End If
End Sub
Public Sub simpandetail()
With tabelcari3
!nojual = Text1.Text
!kdbrg = Text2.Text
!jmljual = Text15.Text
!hargajual = Text14.Text
On Error GoTo 0
End With
End Sub
Public Sub bersihdetail()
Text2.Text = " "
Text10.Text = " "
Text11.Text = " "
Text12.Text = " "
Text13.Text = " "
Text14.Text = 0
Text15.Text = 0
Text16.Text = 0
End Sub
Public Sub seleksirinci()
Dim vnota As String
Dim vsubtotal As Double
vsubtotal = 0
saring = "parameters vnota string;select * from qrjual where trim(nojual)=trim(vnota)"
Set tds = dataasal.CreateQueryDef("", saring)
tds.Parameters![vnota] = Text1.Text
Set tbs = tds.OpenRecordset()
Set Data2.Recordset = tbs
DBGrid1.ReBind
If tbs.RecordCount > 0 Then
tbs.MoveFirst
Do While tbs.EOF = False
vsubtotal = vsubtotal + (tbs("hargajual") * tbs("jmljual"))
tbs.MoveNext
Loop
End If
Text9.Text = vsubtotal
Text26.Text = Val(Text9.Text) - Val(Text25.Text)
End Sub
Public Sub kurangstok()
Dim dasar, batasan As String
dasar = Text2.Text
batasan = "kdbrg='" & dasar & "'"
tabelcari2.FindFirst batasan
If tabelcari2.EOF = False Then
tabelcari2.Edit
tabelcari2("stok") = tabelcari2("stok") + Val(Text15.Text)
tabelcari2.Update
End If
End Sub
0 Response to "Code Program Input Data Penjualan (Sistem Penjualan dan Pembelian Alat Optik)"
Posting Komentar