|
|
Metode dan Algoritma | Program Vb 6.0 . Anda bisa melakukan konsultasi tentang Program Vb 6.0 melalui form di samping kanan !!!
Gerak Animasi :
Dim xchange As Integer
Dim ychange As Integer
-----------------------------------------------------------------------------------
Private Sub Form_Load()
xchange = 100
ychange = 100
End Sub
-----------------------------------------------------------------------------------
Private Sub Form_Unload(Cancel As Integer)
Timer1.Enabled = False
End
End Sub
-----------------------------------------------------------------------------------
Private Sub stop_Click()
Unload Me
End Sub
-----------------------------------------------------------------------------------
Private Sub Timer1_Timer()
Image1.Left = Image1.Left + xchange
Image1.Top = Image1.Top + ychange
If Image1.Left > Me.ScaleWidth Then xchange = xchange * -1
If Image1.Left < 0 Then xchange = xchange * -1
If Image1.Top > Me.ScaleHeight Then ychange = ychange * -1
If Image1.Top < 0 Then ychange = ychange * -1
End Sub
-----------------------------------------------------------------------------------
Buat Kode :
Private Sub Form_Load()
pass.Text = ""
pass.PasswordChar = "*"
End Sub
-----------------------------------------------------------------------------------
Private Sub Proses_Click(Index As Integer)
Select Case Index
Case 0
If pass.Text = "240787" Then
Me.Hide
menu.Show
Else
MsgBox "Siapa Kamu"
End If
Case 1
End
End Select
End Sub
-----------------------------------------------------------------------------------
Buat Listview & Penjualan :
Dim ROB As ListItem
-----------------------------------------------------------------------------------
Sub buat_tabel()
ListView1.ColumnHeaders.Add , , "Kode", 600
ListView1.ColumnHeaders.Add , , "Nama", 1500
ListView1.ColumnHeaders.Add , , "Pesawat", 1000
ListView1.ColumnHeaders.Add , , "Tujuan", 1500
ListView1.ColumnHeaders.Add , , "Tiket", 900
ListView1.ColumnHeaders.Add , , "Beli", 500
ListView1.ColumnHeaders.Add , , "Harga", 900
ListView1.ColumnHeaders.Add , , "Discount", 800
ListView1.ColumnHeaders.Add , , "Total", 900
ListView1.GridLines = True
ListView1.View = lvwReport
End Sub
-----------------------------------------------------------------------------------
Sub masukkan()
Set ROB = ListView1.ListItems.Add(, , kode.Text)
ROB.SubItems(1) = nama.Text
ROB.SubItems(2) = jpes.Text
ROB.SubItems(3) = tuj.Text
ROB.SubItems(4) = har.Text
ROB.SubItems(5) = jbeli.Text
ROB.SubItems(6) = hjual.Text
ROB.SubItems(7) = dis.Text
ROB.SubItems(8) = tbayar.Text
End Sub
-----------------------------------------------------------------------------------
Sub hapus()
kode.Text = ""
nama.Text = ""
jpes.Text = ""
tuj.Text = ""
har.Text = ""
jbeli.Text = ""
hjual.Text = ""
dis.Text = ""
tbayar.Text = ""
End Sub
-----------------------------------------------------------------------------------
Private Sub cmdproses_Click(Index As Integer)
Select Case Index
Case 0
hjual.Text = Val(har.Text) * Val(jbeli.Text)
If jbeli.Text >= 3 Then
dis.Text = 0.02 * Val(hjual.Text)
End If
tbayar.Text = Val(hjual.Text) + Val(dis.Text)
Call masukkan
Case 1
Call hapus
Case 2
Unload Me
End Select
End Sub
-----------------------------------------------------------------------------------
Private Sub Form_Load()
kode.AddItem "001"
kode.AddItem "002"
kode.AddItem "003"
jpes.AddItem "Garuda"
jpes.AddItem "Lion Air"
jpes.AddItem "Air Asia"
tuj.AddItem "Medan - Padang"
tuj.AddItem "Medan - Jakarta"
tuj.AddItem "Medan - Bali"
Call hapus
Call buat_tabel
End Sub
-----------------------------------------------------------------------------------
Private Sub jpes_Click()
tuj_Click
End Sub
-----------------------------------------------------------------------------------
Private Sub kode_Click()
Select Case kode.Text
Case "001"
nama.Text = "Robi Sahputra"
Case "002"
nama.Text = "Budi Sudarsono"
Case "003"
nama.Text = "Charis Yulianto"
End Select
End Sub
-----------------------------------------------------------------------------------
Private Sub tuj_Click()
Select Case jpes.Text
Case "Garuda"
Select Case tuj.Text
Case "Medan - Padang"
har.Text = 500000
Case "Medan - Jakarta"
har.Text = 850000
Case "Medan - Bali"
har.Text = 1500000
End Select
Case "Lion Air"
Select Case tuj.Text
Case "Medan - Padang"
har.Text = 450000
Case "Medan - Jakarta"
har.Text = 800000
Case "Medan - Bali"
har.Text = 1300000
End Select
Case "Air Asia"
Select Case tuj.Text
Case "Medan - Padang"
har.Text = 400000
Case "Medan - Jakarta"
har.Text = 750000
Case "Medan - Bali"
har.Text = 1000000
End Select
End Select
End Sub
-----------------------------------------------------------------------------------
Buat Database :
Sub Hapus()
kode.Text = ""
nama.Text = ""
satuan.Text = ""
harga.Text = ""
jumlah.Text = ""
End Sub
-----------------------------------------------------------------------------------
Private Sub cmdbaru_Click()
Call Hapus
Adodc1.Recordset.AddNew
kode.SetFocus
End Sub
-----------------------------------------------------------------------------------
Private Sub Cmdhapus_Click()
Adodc1.Recordset.Delete
Call Command4_Click
End Sub
-----------------------------------------------------------------------------------
Private Sub cmdkeluar_Click()
Unload Me
End Sub
-----------------------------------------------------------------------------------
Private Sub Cmdsimpan_Click()
Adodc1.Recordset!kode = kode.Text
Adodc1.Recordset!nama = nama.Text
Adodc1.Recordset!satuan = satuan.Text
Adodc1.Recordset!jumlah = jumlah.Text
Adodc1.Recordset.Update
Call Command4_Click
End Sub
-----------------------------------------------------------------------------------
Private Sub Command1_Click()
Adodc1.Recordset.MoveFirst
ShowDB
End Sub
-----------------------------------------------------------------------------------
Private Sub Command2_Click()
Adodc1.Recordset.MoveNext
ShowDB
End Sub
-----------------------------------------------------------------------------------
Private Sub Command3_Click()
Adodc1.Recordset.MovePrevious
ShowDB
End Sub
-----------------------------------------------------------------------------------
Private Sub Command4_Click()
Adodc1.Recordset.MoveLast
ShowDB
End Sub
-----------------------------------------------------------------------------------
Sub ShowDB()
On Error Resume Next
kode.Text = Adodc1.Recordset!kode
nama.Text = Adodc1.Recordset!nama
satuan.Text = Adodc1.Recordset!satuan
harga.Text = Adodc1.Recordset!harga
jumlah.Text = Adodc1.Recordset!jumlah
End Sub
-----------------------------------------------------------------------------------
Buat Database
Program Module :
Global ConJual As New ADODB.Connection
-----------------------------------------------------------------------------------
Public Sub BUKA_DATABASE()
Set ConJual = New ADODB.Connection
ConJual.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Persist Security Info=False;Data Source=" & App.Path & _
"\Penjualan.mdb;Mode = readwrite"
ConJual.Open
End Sub
-----------------------------------------------------------------------------------
Program Database Dengan Listview
dengan Bantuan Module :
Dim saya As ADODB.Recordset
Private Sub Form_Load()
BUKA_DATABASE
List
batal
End Sub
========================================================================================================
Private Sub Cmdsimpan_Click()
If Len(Trim(Me.txtkodecus.Text)) <> 0 Then
strsql = "Insert Into Customer" _
& "([kodeCus],[nama],[alamat],[kota],[telp_fax]) " _
& "VALUES ('" & txtkodecus & "', '" & txtnama & "', '" & txtalamat & "','" & txtkota & "','" & txttelp & "')"
ConJual.Execute strsql, , adCmdText
Call List
batal
Exit Sub
Else
MsgBox "Text Isian Ada Yang Kosong Silakan Periksa!", vbInformation, "Data Kosong"
Exit Sub
End If
End Sub
========================================================================================================
Private Sub ccedit_Click()
strsql = "Update Customer " & _
"Set [nama] = '" & txtnama & " ', " & _
"[alamat] = '" & txtalamat.Text & "', " & _
"[kota] = '" & txtkota.Text & "', " & _
"[telp_fax] = '" & txttelp.Text & " ' " & _
"Where [kodecus] = '" & txtkodecus.Text & "'"
ConJual.Execute strsql, , adCmdText
List
batal
End Sub
========================================================================================================
Private Sub Cmdedit_Click()
If txtkodecus.Text <> "" Then
Set saya = New ADODB.Recordset
strsql = "select * from Customer Where [kodeCus] = '" & Trim(txtkodecus.Text) & "'"
saya.Open strsql, ConJual, adOpenDynamic, adLockOptimistic, adCmdText
If Not saya.EOF Then
yamin
txtkodecus.Enabled = FASLE: txtnama.Enabled = True: txtalamat.Enabled = True: txtkota.Enabled = True: txttelp.Enabled = True
Cmdedit.Enabled = False
ccedit.Visible = True
cmdhapus.Enabled = False
Exit Sub
End If
End If
MsgBox ("Pilih Data Yang Mau DI Edit")
End Sub
========================================================================================================
Private Sub cmdhapus_Click()
If txtkodecus.Text <> "" Then
Dim X As String
X = MsgBox("Apakah Anda yakin mau menghapus ?", vbYesNo)
If X = 6 Then
strsql = "Delete From [Customer] " _
& "Where [kodeCus] = '" & txtkodecus.Text & "'"
ConJual.Execute strsql, , adCmdText
batal
List
End If
batal
Exit Sub
End If
MsgBox ("Data Tidak DItemukan")
Exit Sub
End Sub
========================================================================================================
Private Sub CMDKELUAR_Click()
Unload Me
End Sub
========================================================================================================
Private Sub List()
Dim L As ListItem
lv2.ListItems.Clear
Set saya = New ADODB.Recordset
saya.Open "SELECT * FROM Customer", ConJual, adOpenDynamic, adLockOptimistic
Do While Not saya.EOF
Set L = lv2.ListItems.Add(, , saya.Fields(0))
L.SubItems(1) = saya.Fields![Nama]
L.SubItems(2) = saya.Fields![alamat]
L.SubItems(3) = saya.Fields![KOTA]
L.SubItems(4) = saya.Fields![telp_fax]
saya.MoveNext
Loop
End Sub
========================================================================================================
Private Sub lv2_DblClick()
If lv2.ListItems.Count <> 0 Then
txtkodecus.Text = lv2.ListItems.Item(lv2.SelectedItem.Index).Text
If txtnama.Text <> "" Then
Cmdedit.Enabled = True
cmdhapus.Enabled = True
End If
End If
End Sub
========================================================================================================
Private Sub yamin()
With saya
txtkodecus = ![kodecus]
txtnama = ![Nama]
txtalamat = ![alamat]
txtkota = ![KOTA]
txttelp = ![telp_fax]
End With
End Sub
========================================================================================================
Private Sub txtkodeCus_Change()
Set saya = New ADODB.Recordset
strsql = "select * from Customer Where [kodeCus] = '" & Trim(txtkodecus.Text) & "'"
saya.Open strsql, ConJual, adOpenDynamic, adLockOptimistic, adCmdText
If Not saya.EOF Then
yamin
Exit Sub
End If
End Sub
========================================================================================================
Private Sub txtKodecus_KeyPress(KeyAscii As Integer)
Dim strsql As String
If KeyAscii = 13 Then
If Len(Trim(Me.txtkodecus.Text)) = 0 Then
MsgBox "kodeCus tdk boleh kosong!", vbInformation, "Data Kosong"
txtkodecus.SetFocus
Exit Sub
End If
If Len(Trim(Me.txtkodecus.Text)) < 8 Then
MsgBox "kodeCus Customer tdk boleh Kurang dari 8!", vbInformation, "Data Kosong"
txtkodecus.SetFocus
Exit Sub
End If
Set saya = New ADODB.Recordset
strsql = "select * from [Customer] Where [kodeCus] = '" & Trim(txtkodecus.Text) & "'"
saya.Open strsql, ConJual, adOpenDynamic, adLockOptimistic, adCmdText
If Not saya.EOF Then
Dim X As String
X = MsgBox("kode Customer Sudah Ada, data mau diedit/dihapus ?", vbYesNo)
If X = 6 Then
Cmdedit.Enabled = True
cmdhapus.Enabled = True
Exit Sub
End If
batal
Exit Sub
End If
txtnama.Enabled = True
txtnama.SetFocus
End If
End Sub
========================================================================================================
Private Sub txtnama_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then
If Len(Trim(Me.txtnama.Text)) <> 0 Then
txtalamat.Enabled = True
txtalamat.SetFocus
Else
MsgBox "Data tidak boleh kosong!", vbInformation, "Data Kosong"
Exit Sub
End If
End If
IsiDataText2
If InStr(IsiText, Chr(KeyAscii)) = 0 And KeyAscii <> vbKeyBack And KeyAscii <> vbKeyDelete And KeyAscii <> vbKeySpace Then
KeyAscii = 0
End If
End Sub
========================================================================================================
Private Sub txtalamat_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then
If Len(Trim(Me.txtalamat.Text)) <> 0 Then
txtkota.Enabled = True
txtkota.SetFocus
End If
End If
End Sub
========================================================================================================
Private Sub txtkota_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(UCase(Chr(KeyAscii)))
If KeyAscii = 13 Then
If Len(Trim(Me.txtkota.Text)) <> 0 Then
txttelp.Enabled = True
txttelp.SetFocus
End If
End If
IsiDataText2
If InStr(IsiText, Chr(KeyAscii)) = 0 And KeyAscii <> vbKeyBack And KeyAscii <> vbKeyDelete And KeyAscii <> vbKeySpace Then
KeyAscii = 0
End If
End Sub
========================================================================================================
Private Sub txttelp_KeyPress(KeyAscii As Integer)
On Error Resume Next
If KeyAscii = 13 Then
If Len(Trim(Me.txttelp.Text)) <> 0 Then
Cmdsimpan.Enabled = True
Cmdsimpan.SetFocus
End If
End If
IsiDataText1
If InStr(IsiText, Chr(KeyAscii)) = 0 And KeyAscii <> vbKeyBack And KeyAscii <> vbKeyDelete And KeyAscii <> vbKeySpace Then
KeyAscii = 0
End If
End Sub
========================================================================================================
Private Sub Cmdbatal_Click()
batal
End Sub
========================================================================================================
Private Sub batal()
lv2.Enabled = True
Cmdsimpan.Enabled = False
Cmdedit.Enabled = False
ccedit.Visible = False
cmdhapus.Enabled = False
txtkodecus = "": txtnama = "": txtalamat = "": txtkota = "": txttelp = ""
txtkodecus.Enabled = True: txtnama.Enabled = False: txtalamat.Enabled = False: txtkota.Enabled = False: txttelp.Enabled = False
End Sub
================================================================================
pENJUALAN
==============================================================================
Dim strsql, AA As String
Dim rsPelanggan As ADODB.Recordset
Dim rsBarang As ADODB.Recordset
================================================================
Private Sub Cmdbatal_Click()
Command1.Visible = False
cmdtambah.Enabled = True
List
Cmdsimpan.Enabled = False
NOAKTIF
Nama = ""
barang = ""
txttgl_pmsn = ""
Bersih
End Sub
=============================================================
Public Sub Bersih()
Dim X As Control
For Each X In Controls
If TypeOf X Is TextBox Then
X.Text = ""
End If
Next
End Sub
===============================================================
Public Sub AKTIF()
Dim X As Control
For Each X In Controls
If TypeOf X Is TextBox Then
X.Enabled = True
End If
Next
End Sub
===============================================================
Public Sub NOAKTIF()
Dim X As Control
For Each X In Controls
If TypeOf X Is TextBox Then
X.Enabled = False
End If
Next
End Sub
================================================================
Private Sub labe()
Nama.Caption = ""
barang.Caption = ""
txttgl_pmsn.Caption = ""
End Sub
==================================================================
Private Sub Cmdsimpan_Click()
Dim Syarat As String
Dim rec As String
Dim nilai, nilai1 As Integer
rec = lv.ListItems.Count
If rec = 0 Then Exit Sub
For i = 1 To rec
Syarat = lv.ListItems(i)
strsql = "Insert Into Penjualan " _
& "([nofaktur],[tanggal],[jenis_bayar],[Kodecus],[kodebrg],[qty]) " _
& "VALUES ('" & txtNofaktur.Text & "', '" & txttgl_pmsn & "', '" & AA & "', '" & txtkodecus.Text & "', '" & lv.ListItems(i) & "', '" & lv.ListItems.Item(i).SubItems(2) & "')"
ConJual.Execute strsql, , adCmdText
Set rsBarang = New ADODB.Recordset
strsql = "select * from BARANG Where [kodebrg] = '" & Syarat & "'"
rsBarang.Open strsql, ConJual, adOpenDynamic, adLockOptimistic, adCmdText
With rsBarang
If Not .EOF Then
nilai = ![stok]
End If
End With
nilai1 = nilai - Val(lv.ListItems.Item(i).SubItems(2))
Dim strSQL1 As String
strSQL1 = "Update BARANG " & _
"Set [stok] = '" & nilai1 & "' " & _
"Where [kodebrg] = '" & lv.ListItems(i) & "'"
ConJual.Execute strSQL1, , adCmdText
Next i
lv.ListItems.Clear
Bersih
labe
NOAKTIF
List
Command1.Visible = False
End Sub
===================================================================
Private Sub cmdtambah_Click()
txtNofaktur.Enabled = True
txtNofaktur.SetFocus
cmdtambah.Enabled = False
Cmdsimpan.Enabled = True
lv.ListItems.Clear
Command1.Visible = True
End Sub
=======================================================================
Private Sub Form_Load()
BUKA_DATABASE
Tgl.Caption = "" & Format(Date, "dd-mm-yyyy")
List
End Sub
=======================================================================
Private Sub CMDKELUAR_Click()
Unload Me
End Sub
========================================================================
Private Sub nama_Change()
txtkdbrg.Enabled = True
txtkdbrg.SetFocus
End Sub
=====================================================================
Private Sub List()
Dim L As ListItem
lv.ListItems.Clear
Set saya = New ADODB.Recordset
saya.Open "SELECT * FROM Penjualan", ConJual, adOpenDynamic, adLockOptimistic
Do While Not saya.EOF
Set L = lv.ListItems.Add(, , saya.Fields(0))
L.SubItems(1) = saya.Fields![tanggal]
L.SubItems(2) = saya.Fields![kodecus]
L.SubItems(3) = saya.Fields![kodebrg]
L.SubItems(4) = saya.Fields![qty]
' L.SubItems(5) = saya.Fields![jumlah]
' L.SubItems(6) = saya.Fields![JEnis_bayar]
saya.MoveNext
Loop
End Sub
======================================================================
Private Sub Option1_Click()
AA = "Tunai"
End Sub
===========================================================================
Private Sub Option2_Click()
AA = "kredit"
End Sub
======================================================================
Private Sub txtkdbrg_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Dim rec As String
rec = lv.ListItems.Count
If rec <> 0 Then
For i = 1 To rec
Syarat = lv.ListItems(i)
If txtkdbrg.Text = lv.ListItems(i) Then
MsgBox ("Kode ini udah ada")
Exit Sub
End If
Next i
End If
strsql = "Select * from Barang where kodebrg= '" & txtkdbrg.Text & "'"
Set saya = New ADODB.Recordset
saya.Open strsql, ConJual, adOpenDynamic, adLockOptimistic
If Not saya.EOF Then
barang = saya!Nama
Harga = saya!Harga
txtJlh_barang.Enabled = True
txtJlh_barang.SetFocus
Exit Sub
Else
MsgBox ("Data Tidak Ada !")
End If
End If
End Sub
========================================================================
Private Sub txtjlh_barang_KeyPress(KeyAscii As Integer)
Dim nilai As Integer
If KeyAscii = 13 Then
Set rsBarang = New ADODB.Recordset
strsql = "select * from barang Where [kodebrg] = '" & Trim(txtkdbrg.Text) & "'"
rsBarang.Open strsql, ConJual, adOpenDynamic, adLockOptimistic, adCmdText
With rsBarang
If Not .EOF Then
nilai = ![stok]
End If
End With
If nilai <= 0 Or nilai < txtJlh_barang.Text Then
pilih = MsgBox("Stok Barang tidak Mencukupi ", 32, "Pesan")
txtJlh_barang = ""
Exit Sub
End If
Dim rec As String
rec = lv.ListItems.Count
If rec <> 0 Then
For i = 1 To rec
If txtkdbrg.Text = lv.ListItems(i) Then
MsgBox ("Kode ini udah ada")
Exit Sub
End If
Next i
End If
Set Item = lv.ListItems.Add(, , txtkdbrg)
Item.SubItems(1) = barang
Item.SubItems(2) = txtJlh_barang
Item.SubItems(3) = jumlah
Dim X As String
X = MsgBox("Apakah Ada barang lagi?", vbYesNo + 31)
If X = 6 Then
txtkdbrg.SetFocus
txtkdbrg = ""
txtJlh_barang = ""
barang.Caption = ""
Harga = ""
jumlah = ""
End If
txtkdbrg = ""
txtJlh_barang = ""
barang.Caption = ""
End If
End Sub
===============================================================
Private Sub txtJlh_barang_Change()
jumlah = Val(txtJlh_barang) * Val(Harga)
End Sub
===============================================================
Private Sub txtnofaktur_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Set rsPenjualan = New ADODB.Recordset
strsql = "select * from Penjualan Where [nofaktur] = '" & Trim(txtNofaktur.Text) & "'"
rsPenjualan.Open strsql, ConJual, adOpenDynamic, adLockOptimistic, adCmdText
If Not rsPenjualan.EOF Then
MsgBox ("No Penjualan ini Sudah Ada")
Exit Sub
End If
txtNofaktur.Enabled = False
txttgl_pmsn.Caption = "" & Format(Date, "dd-mm-yyyy")
txtkodecus.Enabled = True
txtkodecus.SetFocus
End If
End Sub
==============================================================================
Private Sub txtKodecus_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
strsql = "Select * from customer where Kodecus= '" & txtkodecus.Text & "'"
Set saya = New ADODB.Recordset
saya.Open strsql, ConJual, adOpenDynamic, adLockOptimistic
If Not saya.EOF Then
Nama = saya!Nama
Exit Sub
Else
MsgBox ("Data Tidak Ada !")
End If
End If
End Sub
ActionScript AS3 ASP.NET AJAX C / C++ C# Clipper COBOL ColdFusion DataFlex Delphi Emacs Lisp Fortran FoxPro Java J2ME JavaScript JScript Lingo MATLAB Perl PHP PostScript Python SQL VBScript Visual Basic 6.0 Visual Basic .NET Flash MySQL Oracle Android
Related Post :
Anda sedang membaca artikel tentang
Program Vb 6.0, Semoga artikel tentang Program Vb 6.0 ini sangat bermanfaat bagi teman-teman semua, jangan lupa untuk mengunjungi lagi melalui link
Program Vb 6.0.
