Data Toko ala Sang Bocah

Form data pembelian
Option Compare Database

Private Sub Form_Load()
    Me.TxtTanggal1.Value = Date
    Me.TxtTanggal2.Value = Date
    Me.RecordSource = "SELECT * FROM t_beli WHERE tanggal>=#" & Me.TxtTanggal1.Value & "# AND tanggal<=#" & Me.TxtTanggal2.Value & "#"
End Sub

Private Sub TxtFilter_AfterUpdate()
    If Me.TxtFilter.Value <> "" Then
        DoCmd.ApplyFilter , "pembeli like '*" & Me.TxtFilter.Value & "*'"
    Else
        DoCmd.ApplyFilter , "no_nota<>''"
    End If
End Sub

Private Sub TxtTanggal1_AfterUpdate()
    Me.RecordSource = "SELECT * FROM t_jual WHERE tanggal>=#" & Me.TxtTanggal1.Value & "# AND tanggal<=#" & Me.TxtTanggal2.Value & "#"
End Sub

Private Sub TxtTanggal1_BeforeUpdate(Cancel As Integer)
    If Not IsDate(Me.TxtTanggal1.Value) Then Cancel = 1
End Sub

Private Sub TxtTanggal2_AfterUpdate()
    Me.RecordSource = "SELECT * FROM t_jual WHERE tanggal>=#" & Me.TxtTanggal1.Value & "# AND tanggal<=#" & Me.TxtTanggal2.Value & "#"
End Sub

Private Sub TxtTanggal2_BeforeUpdate(Cancel As Integer)
    If Not IsDate(Me.TxtTanggal2.Value) Then Cancel = 1
End Sub


Form Module 1
Option Compare Database

Function BukaForm(strForm As String)
    DoCmd.OpenForm strForm, acNormal
End Function

Function BukaReport(strReport As String)
    DoCmd.OpenReport strReport, acViewReport
End Function

Form Beli Detail
Option Compare Database

Private Sub Form_BeforeInsert(Cancel As Integer)
    Me.no_nota.Value = Form_f_Beli.getNota
End Sub

Private Sub Form_Load()

End Sub

Private Sub kode_AfterUpdate()
    Dim HargaJual As Currency
   
    Dim rsBarang As Recordset
   
    Set rsBarang = CurrentDb.OpenRecordset("SELECT * FROM t_barang WHERE kode='" & Me.kode.Value & "'")
   
    If rsBarang.RecordCount = 0 Then
        MsgBox "Kode barang tidak ditemukan, cek kembali", vbExclamation, "^_^ Not Found"
    Else
        Me.nama.Value = rsBarang!nama
        Me.harga_beli.Value = rsBarang!harga_beli
        Me.jumlah.SetFocus
    End If
   
   
End Sub



Form Beli
Option Compare Database

Private Sub Form_BeforeInsert(Cancel As Integer)
    Me.no_nota.Value = Form_f_Beli.getNota
End Sub

Private Sub Form_Load()

End Sub

Private Sub kode_AfterUpdate()
    Dim HargaJual As Currency
   
    Dim rsBarang As Recordset
   
    Set rsBarang = CurrentDb.OpenRecordset("SELECT * FROM t_barang WHERE kode='" & Me.kode.Value & "'")
   
    If rsBarang.RecordCount = 0 Then
        MsgBox "Kode barang tidak ditemukan, cek kembali", vbExclamation, "^_^ Not Found"
    Else
        Me.nama.Value = rsBarang!nama
        Me.harga_beli.Value = rsBarang!harga_beli
        Me.jumlah.SetFocus
    End If
   
   
End Sub


Form Jual
Option Compare Database
Dim StrNota As String

Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Select Case KeyCode
    Case vbKeyF9
        Simpan
    Case vbKeyEscape
        Batal
    End Select
End Sub

Sub Simpan()
    On Error GoTo SimpanError
    DoCmd.SetWarnings False
    Me.total_harga.Value = Me.TxtTotHarga.Value
    DoCmd.RunCommand acCmdSaveRecord
    'mengurangi stok
    Dim rsDetail As Recordset
    Set rsDetail = CurrentDb.OpenRecordset("SELECT kode,jumlah FROM t_jual_detail WHERE no_nota='" & StrNota & "'")
    If rsDetail.RecordCount > 0 Then
        While Not rsDetail.EOF
            DoCmd.RunSQL "UPDATE t_barang SET stok=stok-" & rsDetail!jumlah & " WHERE kode='" & rsDetail!kode & "'"
            rsDetail.MoveNext
        Wend
    End If
    Set rsDetail = Nothing
    MsgBox "Data telah disimpan, Tekan OK untuk mencetak Nota", vbInformation, "^_^ Saved"
    DoCmd.OpenReport "r_jual", acViewReport, , "no_nota='" & StrNota & "'"
    NewNota
    DoCmd.SetWarnings True
    Exit Sub
SimpanError:
    MsgBox "Terjadi kesalahan waktu menyimpan", vbCritical, "^_^ Error"
End Sub

Sub Batal()
    On Error GoTo BatalError
    If MsgBox("Nota ini belum disimpan, apakah mau dihapus??", vbQuestion + vbOKCancel, "^_^ Quit") = vbOK Then
        DoCmd.SetWarnings False
        DoCmd.RunSQL "DELETE FROM t_jual WHERE no_nota='" & Me.no_nota.Value & "'"
        DoCmd.SetWarnings True
        DoCmd.Close acForm, "f_jual", acSaveYes
    End If
    Exit Sub
BatalError:
    MsgBox "Dibatalkan", vbExclamation, "^_^ Canceled"
End Sub

Private Sub Form_Load()
    NewNota
    Me.tanggal.Value = Date
End Sub

Sub NewNota()
    On Error Resume Next
    DoCmd.GoToRecord , , acNewRec
    Dim rsJual As Recordset
    Set rsJual = CurrentDb.OpenRecordset("SELECT no_nota FROM t_jual WHERE tanggal=#" & Date & "# ORDER BY no_nota")
    If rsJual.RecordCount = 0 Then
        StrNota = "TJ" & Format(Date, "yyyyMMdd") & "001"
    Else
        rsJual.MoveLast
        StrNota = "TJ" & Format(Date, "yyyyMMdd") & Right("00" & Trim(Str(Val(Right(rsJual!no_nota, 3)) + 1)), 3)
    End If
    Me.no_nota.Value = StrNota
End Sub

Function getNota() As String
    getNota = StrNota
End Function

Private Sub FormHeader_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Me.Label18.SpecialEffect = 4 Then
        Me.Label18.BorderStyle = 0
        Me.Label18.BorderWidth = 0
        Me.Label18.SpecialEffect = 0
    End If
    If Me.LblTutup.SpecialEffect = 4 Then
        Me.LblTutup.BorderStyle = 0
        Me.LblTutup.BorderWidth = 0
        Me.LblTutup.SpecialEffect = 0
    End If
End Sub

Private Sub Label18_Click()
    Form_KeyDown vbKeyF9, 0
End Sub

Private Sub Label18_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Me.Label18.SpecialEffect <> 4 Then
        Me.Label18.BorderStyle = 1
        Me.Label18.BorderWidth = 2
        Me.Label18.SpecialEffect = 4
    End If
End Sub

Private Sub LblTutup_Click()
    Form_KeyDown vbKeyEscape, 0
End Sub

Private Sub LblTutup_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Me.LblTutup.SpecialEffect <> 4 Then
        Me.LblTutup.BorderStyle = 1
        Me.LblTutup.BorderWidth = 2
        Me.LblTutup.SpecialEffect = 4
    End If
End Sub

Private Sub Text12_AfterUpdate()
    If Me.Text12.Value >= Me.TxtTotHarga.Value Then
        Me.Label14.Caption = "Kembalian : "
        Me.Text13.BackColor = vbWhite
        Me.Text13.Value = Me.Text12.Value - Me.TxtTotHarga.Value
        Me.total_bayar.Value = Me.TxtTotHarga.Value
    Else
        Me.Label14.Caption = "Kekurangan : "
        Me.Text13.BackColor = vbRed
        Me.Text13.Value = Me.TxtTotHarga.Value - Me.Text12.Value
        Me.total_bayar.Value = Me.Text12.Value
    End If
End Sub

Read More

Luas Persegi Panjang ala Sang Bocah

Option Compare Database

Private Sub CmdClose_Click()
DoCmd.Save
DoCmd.Close
End Sub

Private Sub CmdHapus_Click()
TxtPanjang = ""
TxtLebar = ""
TxtLuas = ""
TxtPanjang.SetFocus
End Sub

Private Sub CmdHitung_Click()
Dim P, L, S As Integer
P = TxtPanjang
L = TxtLebar
TxtLuas = S
TxtPanjang = P
TxtLebar = L
TxtLuas = P * L
End Sub

Read More

Luas Segitiga ala Sang Bocah

Option Compare Database

Private Sub CboAlas_Change()
  LblAlas.Caption = CoboAlas
End Sub

Private Sub CboTinggi_Change()
  LblTinggi.Caption = CboTinggi
End Sub

Private Sub CmdHapus_Click()
  CboAlas = ""
  CboTinggi = ""
  TxtHasil = ""
  LblAlas.Caption = "Isi Alas"
  LblTinggi.Caption = "Isi Tinggi"
  CboAlas.SetFocus
End Sub

Private Sub CmdHitung_Click()
  If CboAlas = "" Or CboTinggi = "" Then
    MsgBox ("Isi nilai Alas dan Tinggi")
   Else
    Alas = CboAlas
    Tinggi = CboTinggi
    Hasil = (Alas * Tinggi) / 2
    TxtHasil = Hasil
  End If
End Sub

Private Sub CmdKeluar_Click()
  DoCmd.Save
  DoCmd.Close
End Sub

Private Sub Form_Load()
  Dim i As Integer
   CboAlas = ""
   CboTinggi = ""
   TxtHasil = ""
   For i = 1 To 20
     CboAlas.AddItem i
     CboTinggi.AddItem i
    Next i
End Sub

Read More

Luas Trapesium ala Sang Bocah

Private Sub CmdHapus_Click()
TxtSejajar = ""
TxtTinggi = ""
TxtHasil = ""
TxtSejajar.SetFocus

End Sub

Private Sub CmdHitung_Click()
Dim S, t, H As Integer
S = TxtSejajar
t = TxtTinggi
H = TxtSejajar * TxtTinggi / 2
TxtSejajar = S
TxtTinggi = t
TxtHasil = H
End Sub

Private Sub CmdKeluar_Click()
DoCmd.Save
DoCmd.Close

End Sub

Read More

Konversi Suhu ala Sang Bocah

Private Sub CmdHapus_Click()
TxtCelcius = ""
TxtFahranheit = ""
TxtKelvin = ""
TxtReamur = ""
End Sub

Private Sub CmdHitung_Click()
Dim C, R, F, K As Integer
C = TxtCelcius
R = (4 / 5 * C)
F = (9 / 5 * C) + 32
K = (C + 273)
TxtReamur = R
TxtFahranheit = F
TxtKelvin = K
End Sub

Private Sub CmdKeluar_Click()
DoCmd.Save
DoCmd.Close
End Sub

Read More

Cari Kuadrat ala Sang Bocah

Private Sub Form_Load()
CmdPassword.Caption = "Edit Data" 'Posisi caption tombol pertama kali

Me.AllowEdits = False 'Form tidak dapat di edit
End Sub

Private Sub CmdPassword_Click()
Dim Password As String
Password = "user" ' Isi variable password

If CmdPassword.Caption = "Hasil" Then 'Menguji caption tombol
   Me.AllowEdits = False
   CmdPassword.Caption = "Edit Data" 'Mengembalikan caption semula
   TxtHasilKuadrat = Val(TxtKuadrat ^ 2)
   Else
   If InputBox("Maukkan Password Anda : ", "Password") = "user" Then
   Me.AllowEdits = True 'Form dapat di edit
   TxtKuadrat = ""
   TxtHasilKuadrat = ""
 
   CmdPassword.Caption = "Hasil" 'Mengubah Caption tombol menjadi tombol hasil
   Else
   MsgBox ("Password Anda Salah") 'Menampilkan Message Box
   End If
   End If
 
   End Sub
Private Sub CmdKeluar_Click()
DoCmd.Close
End Sub

Read More

Kalkulator ala Sang Bocah

Private Sub CmdBagi_Click()
Bil1 = Val(TxtBil1)
Bil2 = Val(TxtBil2)
Hasil = Bil1 / Bil2
TxtHasil = Hasil
End Sub

Private Sub CmdHapus_Click()
TxtBil1 = ""
TxtBil2 = ""
TxtHasil = ""
TxtBil1.SetFocus
End Sub

Private Sub CmdKali_Click()
Bil1 = Val(TxtBil1)
Bil2 = Val(TxtBil2)
Hasil = Bil1 * Bil2
TxtHasil = Hasil
End Sub

Private Sub CmdKeluar_Click()
DoCmd.Save
DoCmd.Close
End Sub

Private Sub CmdKurang_Click()
Bil1 = Val(TxtBil1)
Bil2 = Val(TxtBil2)
Hasil = Bil1 - Bil2
TxtHasil = Hasil
End Sub

Private Sub CmdTambah_Click()
Bil1 = Val(TxtBil1)
Bil2 = Val(TxtBil2)
Hasil = Val(Bil1) + Val(Bil2)
TxtHasil = Hasil
End Sub

Read More