Mata Kuliah : Pemrograman Jaringan – KA3B

Pertemuan : 13 – Kartu Stock

NIM : 4.41.17.1.17
Nama : Kukuh Wicaksono

Database Penjualan :
1. Tabel Stok_barang

Hasil Program :
1. Form Tutup Stok

Code Program :
Private Sub Form_Load()
nyambung
Dim i As Integer
For i = 1 To 12
cmbbulan.AddItem i
Next i
For i = Year(Date) - 5 To Year(Date) + 5
cmbtahun.AddItem i
Next i
cmbbulan.Text = Month(Date)
cmbtahun.Text = Year(Date)
End Sub
Private Sub cmdok_Click()
On Error GoTo errTutup
Dim rs As New ADODB.Recordset
Dim strSQL As String
Dim tutup As Long
Dim i As Integer
strSQL = "select * from barang order by kd_brg"
rs.Open strSQL, dbcon, adOpenForwardOnly
If rs.RecordCount < 1 Then
MsgBox "Data masih kosong!!!", vbCritical, "Warning"
Set rs = Nothing
Exit Sub
End If
If cek_data(Val(cmbbulan.Text), Val(cmbtahun.Text)) = True Then
tutup = MsgBox("Stok sudah pernah di TUTUP, TUTUP ULANG?",
vbOKCancel + vbQuestion, "Pesan")
If tutup = vbOK Then
'hapus data lama
dbcon.Execute "delete from stok_barang where " & "bulan="
& _
Val(cmbbulan.Text) & " and tahun=" & Val(cmbtahun.Text)
Else
Set rs = Nothing
Exit Sub
End If
End If
ProgressBar1.Min = 0
ProgressBar1.Max = 100
i = (100 / rs.RecordCount)

While Not rs.EOF

dbcon.Execute "insert into
stok_barang(tanggal,bulan,tahun,kd_brg,stok,harga_beli,harga_jual
,keterangan)" & "values('" & Format(Now, "yyyy-mm-dd") & "'," &
Val(cmbbulan.Text) & "," & Val(cmbtahun.Text) _
& ",'" & rs.Fields(0) & "'," & rs.Fields(5) & "," &
rs.Fields(4) & "," & rs.Fields(3) _
& ",'stok awal bulan : " & cmbbulan.Text & "')"
'ProgressBar1.Value = i
lblproses.Caption = Trim(Str(i)) & " % completed"
DoEvents
i = i + (100 / rs.RecordCount)
rs.MoveNext

Wend
Set rs = Nothing
lblproses.Caption = ProgressBar1.Max & " % completed"
MsgBox "Tutup Stok Sukses....", vbInformation, "Informasi"
Unload Me
Exit Sub

errTutup:
MsgBox "Error : " & Err.Description, vbExclamation, "Error"
End Sub

Private Sub cmdkeluar_Click()

Unload Me
End Sub

Private Function cek_data(xbulan As Integer, xtahun As Integer)

As Boolean
Dim rs As New ADODB.Recordset
Dim sSql As String
Dim hasil As Boolean

hasil = False
sSql = "select * from stok_barang where bulan=" & xbulan & "
and tahun=" & xtahun
rs.Open sSql, dbcon, adOpenForwardOnly
If rs.RecordCount > 1 Then
hasil = True
 Else
hasil = False
End If
cek_data = hasil
Set rs = Nothing
End Function

2. Form Kartu Stok

Code Program :
Private Sub Form_Load()
nyambung
kolom
Dim bln, thn As Integer
cmbkd_brg.Clear

isi_combo
If cmbkd_brg.ListCount > 0 Then
cmbkd_brg.ListIndex = 0
Else
cmbkd_brg.ListIndex = -1
End If
'isi bulan
cmbbulan.Clear
For bln = 1 To 12
cmbbulan.AddItem Str(bln)
Next bln
cmbbulan.Text = Month(Date)
'isi tahun
cmbtahun.Clear
For thn = Year(Date) - 5 To Year(Date) + 5
cmbtahun.AddItem Str(thn)
Next thn
 cmbtahun.Text = Year(Date)
End Sub
Private Sub cmdcari_Click()
lstdata.ListItems.Clear
baca_stok_awalbulan Val(cmbbulan.Text), _
Val(cmbtahun.Text), cmbkd_brg.Text
baca_beli Val(cmbbulan.Text), Val(cmbtahun.Text), _
cmbkd_brg.Text
baca_jual Val(cmbbulan.Text), Val(cmbtahun.Text), _
cmbkd_brg.Text
End Sub
Private Sub cmdexport_Click()
cetak_kartu
End Sub
Private Sub kolom()
lstdata.ColumnHeaders.Add 1, , "Tanggal", 800
lstdata.ColumnHeaders.Add 2, , "No. Faktur", 1500
lstdata.ColumnHeaders.Add 3, , "Qty", 800
lstdata.ColumnHeaders.Add 4, , "Harga", 1000
lstdata.ColumnHeaders.Add 5, , "TotBeli", 1000
lstdata.ColumnHeaders.Add 6, , "Qty", 800
lstdata.ColumnHeaders.Add 7, , "Harga", 1000
lstdata.ColumnHeaders.Add 8, , "TotJual", 1000
lstdata.ColumnHeaders.Add 9, , "Qty", 800
lstdata.ColumnHeaders.Add 10, , "Harga", 1000
lstdata.ColumnHeaders.Add 11, , "Total", 1000
End Sub

Private Sub isi_combo()

Dim msql As String
Dim rs As New ADODB.Recordset
msql = "select * from barang order by kd_brg"
rs.Open msql, dbcon, adOpenForwardOnly
For a = 1 To rs.RecordCount
cmbkd_brg.AddItem rs!kd_brg 'combo barang
rs.MoveNext
Next a
rs.Close
Set rs = Nothing
End Sub

Private Sub baca_stok_awalbulan(xbulan As Integer, xtahun As

Integer, kd As String)
Dim rs As New ADODB.Recordset
Dim xsql As String
Dim i As Integer

xsql = "select * from stok_barang where kd_brg='" & kd _

& "' and month(tanggal)=" & _
xbulan & " and year(tanggal)=" & xtahun & " order by tanggal "
rs.Open xsql, dbcon, adOpenForwardOnly
If rs.RecordCount >= 1 Then
 For i = 1 To rs.RecordCount
lstdata.ListItems.Add , , rs.Fields(1)
'tgl_beli

lstdata.ListItems(lstdata.ListItems.Count).SubItems(1) = _
rs.Fields(0) 'faktur/referensi

lstdata.ListItems(lstdata.ListItems.Count).SubItems(8) = _
rs.Fields(5) 'qty

lstdata.ListItems(lstdata.ListItems.Count).SubItems(9) = _
rs.Fields(6) 'harga beli

lstdata.ListItems(lstdata.ListItems.Count).SubItems(10) = _
rs.Fields(5) * rs.Fields(6) 'tot

rs.MoveNext
Next i
End If
Set rs = Nothing
End Sub

Private Sub baca_beli(xbulan As Integer, xtahun As Integer, kd As

String)
Dim rs As New ADODB.Recordset
Dim xsql As String
Dim i As Integer
Dim qsblm As Integer

xsql = "select * from lapbeli where kd_brg='" & kd _

& "' and month(tgl_beli)=" & _
xbulan & " and year(tgl_beli)=" & xtahun & " order by tgl_beli
"
rs.Open xsql, dbcon, adOpenForwardOnly

If rs.RecordCount >= 1 Then

For i = 1 To rs.RecordCount
qsblm = 0
lstdata.ListItems.Add , , rs.Fields(1) 'tgl_beli
lstdata.ListItems(lstdata.ListItems.Count).SubItems(1) = _
rs.Fields(0) 'faktur
lstdata.ListItems(lstdata.ListItems.Count).SubItems(2) = _
rs.Fields(7) 'qty
lstdata.ListItems(lstdata.ListItems.Count).SubItems(3) = _
rs.Fields(6) 'harga
lstdata.ListItems(lstdata.ListItems.Count).SubItems(4) = _
rs.Fields(8) 'tot

If lstdata.ListItems.Count > 1 Then

qsblm = Val(lstdata.ListItems(lstdata.ListItems.Count -
1).SubItems(8))
Else
 qsblm = 0
End If

lstdata.ListItems(lstdata.ListItems.Count).SubItems(8) = _
rs.Fields(7) + qsblm 'qty
lstdata.ListItems(lstdata.ListItems.Count).SubItems(9) = _
rs.Fields(6) 'harga
lstdata.ListItems(lstdata.ListItems.Count).SubItems(10) = _
(rs.Fields(7) + qsblm) * rs.Fields(6) 'tot
rs.MoveNext
Next i
End If
Set rs = Nothing
End Sub

Private Sub baca_jual(xbulan As Integer, xtahun As Integer, kd As

String)
Dim rs As New ADODB.Recordset
Dim xsql As String
Dim i As Integer
Dim qsblm As Integer

xsql = "select * from lapjual where kd_brg='" & kd _

& "' and month(tgl_jual)=" & _
xbulan & " and year(tgl_jual)=" & xtahun & " order by tgl_jual
"
rs.Open xsql, dbcon, adOpenForwardOnly
If rs.RecordCount >= 1 Then
For i = 1 To rs.RecordCount
lstdata.ListItems.Add , , rs.Fields(1) 'tgl_beli

lstdata.ListItems(lstdata.ListItems.Count).SubItems(1) = _
rs.Fields(0) 'faktur
lstdata.ListItems(lstdata.ListItems.Count).SubItems(5) = _
rs.Fields(7) 'qty
lstdata.ListItems(lstdata.ListItems.Count).SubItems(6) = _
rs.Fields(6) 'harga
lstdata.ListItems(lstdata.ListItems.Count).SubItems(7) = _
rs.Fields(8) 'tot
If lstdata.ListItems.Count > 1 Then
qsblm = Val(lstdata.ListItems(lstdata.ListItems.Count -
1).SubItems(8))
Else
qsblm = 0
End If
lstdata.ListItems(lstdata.ListItems.Count).SubItems(8) = _
qsblm - rs.Fields(7) 'qty
lstdata.ListItems(lstdata.ListItems.Count).SubItems(9) = _
rs.Fields(6) 'harga
lstdata.ListItems(lstdata.ListItems.Count).SubItems(10) = _
(qsblm - rs.Fields(7)) * rs.Fields(6) 'tot
rs.MoveNext
 Next i
End If
Set rs = Nothing
End Sub

Private Sub cetak_kartu()

On Error GoTo errCetak
Dim xsql As String
Dim totAkhir As Double
Dim rs As New ADODB.Recordset
Dim app As Application
Dim wbk As Workbook
Dim sheet As Worksheet
Dim n, i As Integer
Set app = Excel.Application
Set wbk = app.Workbooks.Add
Set sheet = wbk.Worksheets(1)

If lstdata.ListItems.Count < 1 Then

MsgBox "Data Kosong !!!", vbInformation, "Info"
Exit Sub
End If

sheet.Range("A1").Font.Size = 16
sheet.Cells(1, 1) = "Kartu Stok Barang"
sheet.Range("A2").Font.Size = 11
sheet.Cells(2, 1) = "Untuk kode barang : " & cmbkd_brg.Text &
""
sheet.Range("A3").Font.Size = 11
sheet.Cells(3, 1) = "Bulan : " & cmbbulan.Text & " Tahun : " &
cmbtahun.Text & ""
sheet.Cells(4, 1) = "Tanggal"
sheet.Cells(4, 2) = "No.Faktur"
sheet.Cells(4, 3) = "Qty"
sheet.Cells(4, 4) = "Harga Beli"
sheet.Cells(4, 5) = "Total Beli"
sheet.Cells(4, 6) = "Qty"
sheet.Cells(4, 7) = "Harga Jual"
sheet.Cells(4, 8) = "Total Jual"
sheet.Cells(4, 9) = "Qty"
sheet.Cells(4, 10) = "Harga"
sheet.Cells(4, 11) = "Total"
sheet.Range("A1:K4").Font.Bold = True
sheet.Range("A4:K4").Borders.LineStyle = xlContinuous
ActiveWindow.DisplayGridlines = False

With lstdata
n = 4
totAkhir = 0
For i = 1 To .ListItems.Count
sheet.Cells(n + i, 1) = .ListItems(i).Text
sheet.Cells(n + i, 2) = .ListItems(i).SubItems(1)
 sheet.Cells(n + i, 3) = .ListItems(i).SubItems(2)
sheet.Cells(n + i, 4) = .ListItems(i).SubItems(3)
sheet.Cells(n + i, 5) = .ListItems(i).SubItems(4)
sheet.Cells(n + i, 6) = .ListItems(i).SubItems(5)
sheet.Cells(n + i, 7) = .ListItems(i).SubItems(6)
sheet.Cells(n + i, 8) = .ListItems(i).SubItems(7)
sheet.Cells(n + i, 9) = .ListItems(i).SubItems(8)
sheet.Cells(n + i, 10) = .ListItems(i).SubItems(9)
sheet.Cells(n + i, 11) = .ListItems(i).SubItems(10)
sheet.Range("A" & n + i & ":K" & n + i).Borders.LineStyle =
xlContinuous
Next i
End With
sheet.Range("A3").EntireColumn.AutoFit
sheet.Range("B3").EntireColumn.AutoFit
sheet.Range("C3").EntireColumn.AutoFit
sheet.Range("D3").EntireColumn.AutoFit
sheet.Range("E3").EntireColumn.AutoFit
sheet.Range("F3").EntireColumn.AutoFit
sheet.Range("G3").EntireColumn.AutoFit
sheet.Range("H3").EntireColumn.AutoFit
sheet.Range("I3").EntireColumn.AutoFit
sheet.Range("J3").EntireColumn.AutoFit
sheet.Range("K3").EntireColumn.AutoFit
Me.CommonDialog1.DialogTitle = "File Name"
Me.CommonDialog1.Filter = "File Excel|*.xls"
Me.CommonDialog1.ShowSave
wbk.SaveAs Me.CommonDialog1.FileName
wbk.Close
Set sheet = Nothing
Set wbk = Nothing
Set app = Nothing
Dim xx As Object
Set xx = CreateObject("Excel.Application")
xx.DisplayAlerts = False
xx.Visible = False
xx.Workbooks.Open Me.CommonDialog1.FileName
xx.Visible = True
Set rs = Nothing
Exit Sub
errCetak:
MsgBox Err.Description, vbCritical, "Warning"
End Sub