Code Input Data Pembelian (Sistem Penjualan dan Pembelian Alat Optik)

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 pembelian.

List 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 Form_Load()
 Set dataasal = OpenDatabase(App.Path & "\jualbeli.mdb")
 Set tabelasal = dataasal.OpenRecordset("pembelian", dbOpenDynaset)
 Set tabelcari1 = dataasal.OpenRecordset("suplier", dbOpenDynaset)
 Set tabelcari2 = dataasal.OpenRecordset("barang", dbOpenDynaset)
 Set tabelcari3 = dataasal.OpenRecordset("rincibeli", dbOpenDynaset)

 Set qcari1 = dataasal.OpenRecordset("qbeli", dbOpenDynaset)
 Set qcari2 = dataasal.OpenRecordset("qrbeli", 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("kdsup")
  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
  DBGrid1.Enabled = False
  tfi = "True"
  Call aturisian(tfi)
  tft = "False"
  Call aturtombol(tft)
  Text7.Text = memkdkary
  Text8.Text = memnmkary
  baru.Enabled = True
  rubah.Enabled = True
  Text1.SetFocus
 Else
  If Text1.Text = " " Or Combo1.Text = " " Then
    p = MsgBox("Nomor Nota atau kode suplier belum diisi...!", vbOKOnly + vbInformation, "Informasi")
  Else
   dasar = Text1.Text
   batasan = "nobeli='" & 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("qbeli", 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 Text1.Text = " " Then
 info = MsgBox("Nota beli 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 = "nobeli='" & 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 tambahstok
 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("qbeli", 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 = "nobeli='" & 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("qbeli", dbOpenDynaset)
   Set Data1.Recordset = qcari1
   DBGrid1.ReBind
 End If
End Sub
Private Sub selesai_Click()
 Call seleksirinci
 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()
 Text16.Text = Val(Text14.Text) * Val(Text15.Text)
End Sub
Private Sub Text2_Change()
 Call caribarang
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
   baru.SetFocus
 End If
End Sub
Private Sub Combo1_Change()
 Call carisuplier
End Sub
Private Sub Combo1_Click()
 Call carisuplier
End Sub
Private Sub isiankosong()
    Text1.Text = " "
    DTPicker1.Value = Date
    Combo1.Text = " "
    Text3.Text = " "
    Text4.Text = " "
    Text5.Text = " "
    Text6.Text = " "
    Text7.Text = " "
    Text8.Text = " "
End Sub
Public Sub simpanisian()
    With tabelasal
            !nobeli = Text1.Text
            !tglbeli = DTPicker1.Value
            !kdsup = Combo1.Text
            !kdkary = Text7.Text
    On Error GoTo 0
    End With
End Sub
Public Sub isiantampil()
If qcari1.EOF = False Then
    Text1.Text = qcari1("nobeli")
    DTPicker1.Value = qcari1("tglbeli")
    Combo1.Text = qcari1("kdsup")
    Text3.Text = qcari1("nmsup")
    Text4.Text = qcari1("almsup")
    Text5.Text = qcari1("kotasup")
    Text6.Text = qcari1("telpsup")
    Text7.Text = qcari1("kdkary")
    Text8.Text = qcari1("nmkary")
Else
    Call isiankosong
End If
End Sub
Public Sub aturisian(tfi)
    Text1.Enabled = tfi
    DTPicker1.Enabled = tfi
    Combo1.Enabled = tfi
End Sub
Public Sub aturtombol(tft)
   baru.Enabled = tft
   rubah.Enabled = tft
   hapus.Enabled = tft
   tutup.Enabled = tft
End Sub
Public Sub carisuplier()
   Dim dasar, batasan As String
   dasar = Combo1.Text
   batasan = "kdsup='" & dasar & "'"
   tabelcari1.FindFirst batasan
   If tabelcari1.NoMatch Then
    Text3.Text = " "
    Text4.Text = " "
    Text5.Text = " "
    Text6.Text = " "
   Else
   Text3.Text = tabelcari1("nmsup")
   Text4.Text = tabelcari1("almsup")
   Text5.Text = tabelcari1("kotasup")
   Text6.Text = tabelcari1("telpsup")
   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("hargab")
   Text15.SetFocus
   End If
End Sub
Public Sub simpandetail()
    With tabelcari3
            !nobeli = Text1.Text
            !kdbrg = Text2.Text
            !jmlbeli = Text15.Text
            !hargabeli = 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 qrbeli where trim(nobeli)=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("hargabeli") * tbs("jmlbeli"))
 tbs.MoveNext
 Loop
 End If
 Text9.Text = vsubtotal
 Call simpantotal
 End Sub

Public Sub tambahstok()
   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
Public Sub simpantotal()
 Dim dasar, batasan
   dasar = Text1.Text
   batasan = "nobeli='" & dasar & "'"
   tabelasal.FindFirst batasan
   If tabelasal.EOF = False Then
    tabelasal.Edit
    tabelasal("tottrans") = Val(Text9.Text)
    tabelasal.Update
   End If
End Sub

Tweet