Hai sahabat walker kali ini saya
akan berbagi ilmu bagaimana membuat program pendistribusian bantuan bencana
alam daerah dengan menggunakan visual basic 6.0 dengan menggunakan database
Mysql Wamp dimana koneksi databesnya
menggunakan Odbc .
Langkah-langkah
1. Instal
visual basic 6.0
2. Instal
Mysql Wamp 5.1
3. Koneksi
ODBC nya dengan Odbc 3.51 driver
4. Skin
VB jika ingin tampilannya lebih menarik
Script program untuk menu utama
Sebagai berikut:
Private Sub bantu_Click()
FBantuan.Show
End Sub
Private Sub barang_Click()
FBarang.Show
End Sub
Private Sub bulan_Click()
FLBUlan.Show
End Sub
Private Sub camat_Click()
FCamat.Show
End Sub
Private Sub jamer_Timer()
Dim jamer As Variant
jamer = Now
Label2.Caption = Format(jamer,
"dddd")
Label3.Caption = Format(jamer,
"d")
Label6.Caption = Format(jamer,
"mmmm")
Label4.Caption = Format(jamer,
"yyyy")
Label5.Caption = Format(jamer, "hh :
mm : ss")
End Sub
Private Sub keluar_Click()
If keluar.Caption =
"&Login" Then
Flogin.Show
Else
Unload Me
End
End If
End Sub
Private Sub lurah_Click()
FLurah.Show
End Sub
Private Sub MDIForm_Load()
xx.Visible = False
Dim r As Rect
Explode Me, 1
Call matot
Flogin.Show
End Sub
Sub matot()
XPButton1.Enabled = False
XPButton2.Enabled = False
XPButton3.Enabled = False
XPButton4.Enabled = False
laporan.Visible = False
entri.Visible = False
'xx.Visible = False
bantuan.Visible = False
End Sub
Sub iduik()
XPButton1.Enabled = True
XPButton2.Enabled = True
XPButton3.Enabled = True
XPButton4.Enabled = True
laporan.Visible = True
'xx.Visible = True
entri.Visible = True
bantuan.Visible = True
End Sub
Private Sub Explode(ByRef frm As
Form, ByRef efek As Boolean)
With frm
.Width = 0
.Height = 9000
.Show
If efek Then
For X = 0 To 200000 Step 200
.Move (Screen.Width - .Width) /
2, (Screen.Height - .Height) / 2, X, X
'.Move (Screen.Width - .Width),
(Screen.Height - .Height), x, x
DoEvents
Next
Else
For X = 9000 To 0 Step -1000
.Move (Screen.Width - .Width) /
1, (Screen.Height - .Height) / 2, X, X
'.Move (Screen.Width - .Width),
(Screen.Height - .Height), x, x
DoEvents
Next
End
End If
End With
End Sub
Private Sub
StatusBar1_PanelClick(ByVal Panel As MSComctlLib.Panel)
StatusBar1.Tag = lurah: FLurah.Show
End Sub
Private Sub stok_Click()
Dim A As String
A = InputBox("Masukkan Nama
Administrator", "Konfirmasi")
cr.ReportFileName = App.Path
& "\stok.rpt"
cr.Formulas(1) = "nm =
'" & A & "'"
cr.WindowMinButton = False
cr.WindowShowCancelBtn = True
cr.WindowShowCloseBtn = True
cr.WindowShowPrintBtn = True
cr.WindowShowPrintSetupBtn = True
cr.WindowParentHandle =
MDIForm1.hwnd
cr.WindowState = crptMaximized
cr.RetrieveDataFiles
cr.Action = 28
End Sub
Private Sub tahun_Click()
FLTahun.Show
End Sub
Private Sub Timer1_Timer()
Dim s As String
s = Label1.Caption
s = Mid(s, 2, Len(s) - 1) &
Left(s, 1)
Label1.Caption = s
End Sub
Private Sub XPButton1_Click()
FBarang.Show
End Sub
Private Sub XPButton2_Click()
FCamat.Show
End Sub
Private Sub XPButton3_Click()
FLurah.Show
End Sub
Private Sub XPButton4_Click()
FBantuan.Show
End Sub
Private Sub XPButton5_Click()
About.Show
End Sub
Private Sub xx_Click()
End
End Sub
Selesai the script untuk form
menunya
Sekarang Kita buat program
persiadaan barang untuk di distribusikan:
1. Buat
form baru dengan Nama FBarang.frm
Caption
|
Name
|
Kode Barang
|
Txtkode
|
Nama Barang
|
Txtnama
|
Dtpicker1
|
Dtpicker1
|
Merk
|
Txtmerek
|
Bahan
|
Txtbahan
|
Asal Barang
|
txtasal
|
Jumlah
|
txtjumlah
|
Combo1
|
Cmbsatuan
|
Harga
|
Txtharga
|
Datagrid1
|
Datagrid1
|
Button Tambah
|
cmdtambah
|
Button Simpan
|
Cmdsimpan
|
Button Hapus
|
Cmdhapus
|
Button Keluar
|
Cmdkeluar
|
4. Nah
kalau sudah di disain formnya seperti diatas yah tinggal masukin koding
programnya dibawah ini:
Private Sub cmdhapus_Click()
SqlDelete = " delete from
barang where Kode_barang='" & txtkode.Text & "'"
Conn.Execute SqlDelete, ,
adCmdText
Adodc1.Refresh
DataGrid1.Refresh
MsgBox "Data Telah Di
Hapus"
textclear
Call Form_Load
FBantuan.Refresh
End Sub
Private Sub cmdkeluar_Click()
If cmdkeluar.Caption =
"&Batal" Then
cmdkeluar.Caption = "&Keluar"
Call textdie
Call textclear
Else
Unload Me
End If
End Sub
Sub barrang()
cmbsatuan.AddItem
"Unit"
cmbsatuan.AddItem
"Buah"
cmbsatuan.AddItem
"Pack"
cmbsatuan.AddItem
"Lusin"
cmbsatuan.AddItem
"Kodi"
cmbsatuan.AddItem "Kg"
cmbsatuan.AddItem
"Liter"
cmbsatuan.AddItem
"Paket"
End Sub
Sub textclear()
txtkode.Text = ""
txtnama.Text = ""
txtmerek.Text = ""
txtasal.Text = ""
txtbahan.Text = ""
txtjumlah.Text = ""
cmbsatuan.Text = ""
TxtHarga.Text = ""
End Sub
Sub btndie()
cmdsimpan.Enabled = False
cmdhapus.Enabled = False
End Sub
Sub btnlife()
cmdsimpan.Enabled = True
cmdhapus.Enabled = True
End Sub
Private Sub cmdsimpan_Click()
If txtnama.Text = ""
Then
MsgBox "Nama Masih Kosong"
txtnama.SetFocus
Exit Sub
ElseIf cmdsimpan.Caption =
"&Simpan" Then
SqlInsert = "insert into
barang values('" & txtkode.Text & "','" &
txtnama.Text & "','" & Format(DTPicker1,
"yyyy-mm-dd") & "', '" _
& txtmerek.Text &
"','" & txtbahan.Text & "','" & txtasal.Text
& "','" & txtjumlah.Text & "','" &
cmbsatuan.Text & "','" & TxtHarga.Text & "')"
Conn.Execute SqlInsert, ,
adCmdText
MsgBox "Data Telah
Tersimpan", vbOKOnly + vbQuestion, "Informasi"
Adodc1.Refresh
DataGrid1.Refresh
Call Form_Load
FBarang.Refresh
Call textclear
cmdkeluar.Caption =
"&Keluar"
ElseIf cmdsimpan.Caption =
"&Update" Then
Conn.Execute "update barang
set Kode_barang='" & txtkode.Text & "',Nama_barang='"
& txtnama.Text & "',Tanggal='" & Format(DTPicker1.Value,
"yyyy-mm-dd") & "',Merk='" _
& txtmerek.Text & "',Bahan='" & txtbahan.Text
& "',Asal_barang='" & txtasal.Text &
"',Jumlah='" & txtjumlah.Text & "',Satuan='" &
cmbsatuan.Text & "',Harga='" _
& TxtHarga.Text & "' where
Kode_barang like '" & txtkode.Text & "'"
Set barang = Conn.Execute(" select *
from barang")
Set DataGrid1.DataSource = barang
Adodc1.Refresh
DataGrid1.Refresh
MsgBox "Data telah DI Update"
Call textclear
Call Form_Load
FBarang.Refresh
End If
End Sub
Private Sub cmdtambah_Click()
Call No_Faktur
Call textlife
txtkode.Enabled = False
txtnama.SetFocus
Call btnlife
cmdkeluar.Caption =
"&Batal"
cmdsimpan.Caption =
"&Simpan"
End Sub
Sub textlife()
txtkode.Enabled = True
txtnama.Enabled = True
DTPicker1.Enabled = True
txtmerek.Enabled = True
txtasal.Enabled = True
txtbahan.Enabled = True
txtjumlah.Enabled = True
cmbsatuan.Enabled = True
TxtHarga.Enabled = True
End Sub
Sub textdie()
txtkode.Enabled = False
txtnama.Enabled = False
DTPicker1.Enabled = False
txtmerek.Enabled = False
txtasal.Enabled = False
txtbahan.Enabled = False
txtjumlah.Enabled = False
cmbsatuan.Enabled = False
TxtHarga.Enabled = False
End Sub
Private Sub DataGrid1_Click()
Call textlife
Call btnlife
cmdsimpan.Caption =
"&Update"
txtkode.Text =
DataGrid1.Columns(0).Text
txtnama.Text =
DataGrid1.Columns(1).Text
DTPicker1.Value =
DataGrid1.Columns(2).Text
txtmerek.Text =
DataGrid1.Columns(3).Text
txtasal.Text =
DataGrid1.Columns(5).Text
txtbahan.Text =
DataGrid1.Columns(4).Text
txtjumlah.Text =
DataGrid1.Columns(6).Text
cmbsatuan.Text =
DataGrid1.Columns(7).Text
TxtHarga.Text =
DataGrid1.Columns(8).Text
txtkode.Enabled = False
DataGrid1.SetFocus
cmdkeluar.Caption =
"&Batal"
End Sub
Private Sub Form_Load()
Call Bukadatabase
Call barrang
Call textdie
Call btndie
End Sub
Sub No_Faktur()
On Error Resume Next
Dim Faktur_Tanggal, No_Fak As String
Faktur_Tanggal = "B" +
Format(Date, "ddmm")
Call Bukadatabase
StrSQL = "SELECT * FROM barang WHERE
" _
& " (((barang.Kode_barang)
Like '" & Faktur_Tanggal & "%'))order by
barang.Kode_barang"
Set Rs = Conn.Execute(StrSQL)
If Not Rs.EOF Then
Rs.MoveLast
No_Fak = Rs!Kode_barang
No_Fak = Val(Right(No_Fak, 3))
No_Fak = No_Fak + 1
Faktur_Tanggal = Faktur_Tanggal +
Format(No_Fak, "000")
Faktur_Tanggal = Faktur_Tanggal
txtkode.Text = Faktur_Tanggal
Else
Faktur_Tanggal = Faktur_Tanggal +
"001"
txtkode.Text = Faktur_Tanggal
End If
End Sub
Hmmm selasai Juga untuk form
barangnya.
Keterangan Form Kecamatan:
Caption
|
Name
|
Kode Kecamatan
|
Txtkode
|
Kecamatan
|
Txtcamat
|
Nama Camat
|
Txtnama
|
Alamat
|
Txtalamat
|
Telephone
|
Txttelp
|
Button Tambah
|
Cmdtambah
|
Button Hapus
|
Cmdhapus
|
Button Simpan
|
Cmdsimpan
|
Button Keluar
|
Cmdkeluar
|
Cari kecamatan
|
Txtcaricamat
|
Cari Nama
|
Txtcarinama
|
Datagrid1
|
Datagrid1
|
Script program untuk form
Kecamatan:
Private Sub cmdhapus_Click()
SqlDelete = "delete from
camat where Kode_camat='" & txtkode.Text & "'"
Conn.Execute SqlDelete, ,
adCmdText
MsgBox "Data Telah
Dihapus"
Adodc1.Refresh
DataGrid1.Refresh
cleartext
Call Form_Load
FCamat.Refresh
End Sub
Private Sub cmdkeluar_Click()
If cmdkeluar.Caption =
"&Keluar" Then
Unload Me
Else
Call cleartext
Call Form_Load
FCamat.Refresh
cmdkeluar.Caption = "&Keluar"
End If
End Sub
Private Sub cmdsimpan_Click()
If txtkode.Text = ""
Then
MsgBox "Kode Masih Kosong"
txtkode.SetFocus
ElseIf cmdsimpan.Caption =
"&Simpan" Then
SqlInsert = "insert into
camat values('" & txtkode.Text & "','" &
txtkecamatan.Text & "','" & txtnama.Text &
"','" _
& txtalamat.Text &
"','" & txttelp.Text & "')"
Conn.Execute SqlInsert, ,
adCmdText
MsgBox "Data Telah
Tersimpan", vbOKOnly + vbQuestion, "INFO"
Adodc1.Refresh
DataGrid1.Refresh
Call cleartext
Call Form_Load
FCamat.Refresh
cmdkeluar.Caption =
"&Keluar"
ElseIf cmdsimpan.Caption =
"&Update" Then
Conn.Execute "Update camat set
Kode_camat='" & txtkode.Text & "',Kecamatan='" &
txtkecamatan.Text & "',Nama_camat='" _
& txtnama.Text &
"',Alamat='" & txtalamat.Text & "',No_telp='" &
txttelp.Text & "' where Kode_camat like '" & txtkode.Text
& "'"
Set camat = Conn.Execute("select *
from camat")
Set DataGrid1.DataSource = camat
Adodc1.Refresh
DataGrid1.Refresh
MsgBox "Data Telah Di Update"
cmdsimpan.Caption = "&Simpan"
Call cleartext
Call Form_Load
FCamat.Refresh
cmdkeluar.Caption = "&Keluar"
End If
End Sub
Private Sub cmdtambah_Click()
Call No_Faktur
Call colorlife
Call tblhdup
Call texthidup
cmdkeluar.Caption =
"&Batal"
txtkode.Enabled = False
txtkecamatan.SetFocus
cmdsimpan.Caption =
"&Simpan"
End Sub
Sub No_Faktur()
On Error Resume Next
Dim Faktur_Tanggal, No_Fak As String
Faktur_Tanggal = "C" +
Format(Date, "ddmm")
Call Bukadatabase
StrSQL = "SELECT * FROM camat WHERE
" _
& " (((camat.Kode_camat) Like
'" & Faktur_Tanggal & "%'))order by camat.Kode_camat"
Set Rs = Conn.Execute(StrSQL)
If Not Rs.EOF Then
Rs.MoveLast
No_Fak = Rs!Kode_camat
No_Fak = Val(Right(No_Fak, 3))
No_Fak = No_Fak + 1
Faktur_Tanggal = Faktur_Tanggal +
Format(No_Fak, "000")
Faktur_Tanggal = Faktur_Tanggal
txtkode.Text = Faktur_Tanggal
txtnama.SetFocus
Else
Faktur_Tanggal = Faktur_Tanggal +
"001"
txtkode.Text = Faktur_Tanggal
txtnama.SetFocus
End If
End Sub
Private Sub DataGrid1_Click()
Call texthidup
Call colorlife
Call tblhdup
cmdsimpan.Caption =
"&Update"
txtkode.Text =
DataGrid1.Columns(0).Text
txtkecamatan.Text =
DataGrid1.Columns(1).Text
txtnama.Text =
DataGrid1.Columns(2).Text
txtalamat.Text =
DataGrid1.Columns(3).Text
txttelp.Text =
DataGrid1.Columns(4).Text
txtkode.Enabled = False
txtkecamatan.SetFocus
cmdkeluar.Caption =
"&Batal"
End Sub
Private Sub Form_Load()
Call colordie
Call textmati
Call Bukadatabase
Call tblmati
End Sub
Sub textmati()
txtkode.Enabled = False
txtkecamatan.Enabled = False
txtnama.Enabled = False
txtalamat.Enabled = False
txttelp.Enabled = False
End Sub
Sub texthidup()
txtkode.Enabled = True
txtkecamatan.Enabled = True
txtnama.Enabled = True
txtalamat.Enabled = True
txttelp.Enabled = True
End Sub
Sub tblmati()
cmdhapus.Enabled = False
cmdsimpan.Enabled = False
End Sub
Sub tblhdup()
cmdsimpan.Enabled = True
cmdhapus.Enabled = True
End Sub
Sub cleartext()
txtkode.Text = ""
txtkecamatan.Text = ""
txtnama.Text = ""
txtalamat.Text = ""
txttelp.Text = ""
End Sub
Sub colordie()
txtkode.BackColor = vbGreen
txtkecamatan.BackColor = vbGreen
txtnama.BackColor = vbGreen
txtalamat.BackColor = vbGreen
txttelp.BackColor = vbGreen
End Sub
Sub colorlife()
txtkode.BackColor = vbWhite
txtkecamatan.BackColor = vbWhite
txtnama.BackColor = vbWhite
txtalamat.BackColor = vbWhite
txttelp.BackColor = vbWhite
End Sub
Private Sub txtcarikode_Change()
Set camat = Conn.Execute("
SELECT * FROM camat WHERE Kecamatan LIKE '" & txtcarikode.Text &
"%'")
Set DataGrid1.DataSource = camat
End Sub
Private Sub txtcarinama_Change()
Set camat = Conn.Execute("
SELECT * FROM camat WHERE Nama_camat LIKE '" & txtcarinama.Text &
"%'")
Set DataGrid1.DataSource = camat
End Sub
Akhirnya selasai form kecamatan,,
dan berjuangan belum berakhir, kita masih ada form Kelurahan dan form
distribusinya.
Lanjuk ke form Kelurahannya
sobat:
Nee tampilan Disain nya:
Keterangannya sama sama form
camat pada sebelumnya sobat tinggal ubah namenya Camat dengan kelurahan, ok???
Seep.
Script programnya sebagai
berikut:
Dim kddiv, kecamatan As String
Private Sub cmbcamat_Click()
kddiv = ""
Set Rs = Conn.Execute("SELECT * FROM
" _
& " camat WHERE
Kecamatan='" & cmbcamat.Text & "'")
With Rs
If .EOF And .BOF Then
Exit Sub
Else
kddiv = Rs!kecamatan
txtcamat.Text = Rs!Nama_camat
End If
End With
End Sub
Private Sub cmbcamat_DropDown()
Set Rs = Conn.Execute("SELECT * FROM " _
& " camat ORDER BY
kecamatan")
If Not Rs.BOF Then
While Not Rs.EOF
cmbcamat.AddItem Rs!kecamatan
Rs.MoveNext
Wend
End If
End Sub
Private Sub cmdhapus_Click()
SqlDelete = "delete from
lurah where Kode_lurah='" & txtkode.Text & "'"
Conn.Execute SqlDelete, ,
adCmdText
MsgBox "Data Telah
Dihapus"
Adodc1.Refresh
DataGrid1.Refresh
cleartext
Call Form_Load
FLurah.Refresh
End Sub
Private Sub cmdkeluar_Click()
If cmdkeluar.Caption =
"&Keluar" Then
Unload Me
Else
Call cleartext
Call Form_Load
FLurah.Refresh
cmdkeluar.Caption = "&Keluar"
End If
End Sub
Private Sub cmdsimpan_Click()
If txtkode.Text = ""
Then
MsgBox "Kode Masih Kosong"
txtkode.SetFocus
ElseIf cmdsimpan.Caption =
"&Simpan" Then
SqlInsert = "insert into
lurah values('" & txtkode.Text & "','" &
txtkecamatan.Text & "','" & txtnama.Text &
"','" _
& txtalamat.Text &
"','" & txttelp.Text & "','" & cmbcamat.Text
& "','" & txtcamat.Text & "')"
Conn.Execute SqlInsert, ,
adCmdText
MsgBox "Data Telah
Tersimpan", vbOKOnly + vbQuestion, "INFO"
Adodc1.Refresh
DataGrid1.Refresh
Call cleartext
Call Form_Load
FLurah.Refresh
cmdkeluar.Caption =
"&Keluar"
ElseIf cmdsimpan.Caption =
"&Update" Then
Conn.Execute "Update lurah set
Kode_lurah='" & txtkode.Text & "',Kelurahan='" &
txtkecamatan.Text & "',Nama_lurah='" _
& txtnama.Text &
"',Alamat='" & txtalamat.Text & "',No_telp='" &
txttelp.Text & "',Kode_camat='" & cmbcamat.Text &
"','" & txtcamat.Text & "' where Kode_lurah like '"
& txtkode.Text & "'"
Set lurah = Conn.Execute("select *
from lurah")
Set DataGrid1.DataSource = lurah
Adodc1.Refresh
DataGrid1.Refresh
MsgBox "Data Telah Di Update"
cmdsimpan.Caption = "&Simpan"
Call cleartext
Call Form_Load
FLurah.Refresh
cmdkeluar.Caption = "&Keluar"
End If
End Sub
Private Sub cmdtambah_Click()
Call No_Faktur
Call colorlife
Call tblhdup
Call texthidup
cmdkeluar.Caption =
"&Batal"
txtkode.Enabled = False
txtkecamatan.SetFocus
cmdsimpan.Caption =
"&Simpan"
End Sub
Sub No_Faktur()
On Error Resume Next
Dim Faktur_Tanggal, No_Fak As String
Faktur_Tanggal = "KL" +
Format(Date, "ddmm")
Call Bukadatabase
StrSQL = "SELECT * FROM lurah WHERE
" _
& " (((lurah.Kode_lurah) Like
'" & Faktur_Tanggal & "%'))order by lurah.Kode_lurah"
Set Rs = Conn.Execute(StrSQL)
If Not Rs.EOF Then
Rs.MoveLast
No_Fak = Rs!Kode_lurah
No_Fak = Val(Right(No_Fak, 3))
No_Fak = No_Fak + 1
Faktur_Tanggal = Faktur_Tanggal +
Format(No_Fak, "000")
Faktur_Tanggal = Faktur_Tanggal
txtkode.Text = Faktur_Tanggal
txtnama.SetFocus
Else
Faktur_Tanggal = Faktur_Tanggal +
"001"
txtkode.Text = Faktur_Tanggal
txtnama.SetFocus
End If
End Sub
Private Sub DataGrid1_Click()
Call texthidup
Call colorlife
Call tblhdup
cmdsimpan.Caption =
"&Update"
txtkode.Text =
DataGrid1.Columns(0).Text
txtkecamatan.Text =
DataGrid1.Columns(1).Text
txtnama.Text =
DataGrid1.Columns(2).Text
txtalamat.Text = DataGrid1.Columns(3).Text
txttelp.Text =
DataGrid1.Columns(4).Text
txtkode.Enabled = False
txtkecamatan.SetFocus
cmdkeluar.Caption =
"&Batal"
End Sub
Private Sub Form_Load()
Call colordie
Call textmati
Call Bukadatabase
Call tblmati
End Sub
Sub textmati()
txtkode.Enabled = False
txtkecamatan.Enabled = False
txtnama.Enabled = False
txtalamat.Enabled = False
txttelp.Enabled = False
End Sub
Sub texthidup()
txtkode.Enabled = True
txtkecamatan.Enabled = True
txtnama.Enabled = True
txtalamat.Enabled = True
txttelp.Enabled = True
End Sub
Sub tblmati()
cmdhapus.Enabled = False
cmdsimpan.Enabled = False
End Sub
Sub tblhdup()
cmdsimpan.Enabled = True
cmdhapus.Enabled = True
End Sub
Sub cleartext()
txtkode.Text = ""
txtkecamatan.Text = ""
txtnama.Text = ""
txtalamat.Text = ""
txttelp.Text = ""
cmbcamat.Text = ""
txtcamat = ""
End Sub
Sub colordie()
txtkode.BackColor = vbGrayText
txtkecamatan.BackColor =
vbGrayText
txtnama.BackColor = vbGrayText
txtalamat.BackColor = vbGrayText
txttelp.BackColor = vbGrayText
cmbcamat.BackColor = vbGrayText
txtcamat.BackColor = vbGrayText
End Sub
Sub colorlife()
txtkode.BackColor = vbWhite
txtkecamatan.BackColor = vbWhite
txtnama.BackColor = vbWhite
txtalamat.BackColor = vbWhite
txttelp.BackColor = vbWhite
cmbcamat.BackColor = vbGrayText
txtcamat.BackColor = vbGrayText
End Sub
Selesai. Tinggal form
distribusinya.
Disain formya sebagai berikut
Script program Form
Bantuan/Distribusi:
Dim kddiv, kecamatan As String
Dim awal, akhir As Integer
Sub No_Faktur()
On Error Resume Next
Dim Faktur_Tanggal, No_Fak As String
Faktur_Tanggal = "TR" +
Format(Date, "ddmmyy")
'Call Bukadatabase
StrSQL = "SELECT * FROM transaksi
WHERE " _
& " (((transaksi.Nota) Like
'" & Faktur_Tanggal & "%'))order by transaksi.Nota"
Set Rs = Conn.Execute(StrSQL)
If Not Rs.EOF Then
Rs.MoveLast
No_Fak = Rs!nota
No_Fak = Val(Right(No_Fak, 3))
No_Fak = No_Fak + 1
' Adodc1.ConnectionString = StrConnect
' Adodc1.RecordSource = StrSQL
'
Adodc1.Refresh
Faktur_Tanggal = Faktur_Tanggal +
Format(No_Fak, "000")
Faktur_Tanggal = Faktur_Tanggal
TxtNoFaktur.Text = Faktur_Tanggal
Else
Faktur_Tanggal = Faktur_Tanggal +
"001"
TxtNoFaktur.Text = Faktur_Tanggal
End If
End Sub
Private Sub Command1_Click()
Set Rs = New ADODB.Recordset
Rs.Open "select * from
pemesanan where notapesan= '" & TxtNoFaktur & "'", Conn,
adOpenDynamic, adLockOptimistic
If Not Rs.EOF Then
DTPicker1.Value = Rs.Fields(1)
kdsup = Rs.Fields(2)
Rs.MoveNext
End If
Set Rs = New ADODB.Recordset
Rs.Open "select * from
supplier where kdsup = '" & kdsup & "'", Conn,
adOpenDynamic, adLockOptimistic
If Not Rs.EOF Then
cmbcamat = Rs.Fields(1)
txtnama = Rs.Fields(2)
Rs.MoveNext
End If
Set Rs = New ADODB.Recordset
Rs.Open "SELECT rincipesan.*,barang.*
FROM rincipesan,barang where
barang.kdbrg = rincipesan.kdbrg and notapesan = '" & TxtNoFaktur &
"'", _
Conn, adOpenDynamic,
adLockBatchOptimistic
Listpemb.ListItems.Clear
While Not Rs.EOF
Set View = Listpemb.ListItems.Add
View.Text = Rs.Fields(1)
View.SubItems(1) = Rs!nmbrg
View.SubItems(2) = Rs!hrg
View.SubItems(3) = Rs!qty
View.SubItems(4) = Rs!qty * Rs!hrg
Rs.MoveNext
Wend
End Sub
Private Sub Combo1_Click()
kddiv = ""
Set Rs = Conn.Execute("SELECT * FROM
" _
& " camat WHERE
Kecamatan='" & Combo1.Text & "'")
With Rs
If .EOF And .BOF Then
Exit Sub
Else
Combo1.Text = Rs!kecamatan
Text1.Text = Rs!Nama_camat
End With
End Sub
Private Sub Combo1_DropDown()
Set Rs =
Conn.Execute("SELECT * FROM " _
& " camat ORDER BY
Kecamatan")
If Not Rs.BOF Then
While Not Rs.EOF
Combo1.AddItem Rs!kecamatan
Rs.MoveNext
Wend
End If
End Sub
Private Sub cmblurah_Click()
kddiv = ""
Set Rs = Conn.Execute("SELECT * FROM
" _
& " lurah WHERE
Kelurahan='" & cmblurah.Text & "'")
With Rs
If .EOF And .BOF Then
Exit Sub
Else
kddiv = Rs!Kelurahan
txtlurah.Text = Rs!Nama_lurah
End If
End With
End Sub
Private Sub cmblurah_DropDown()
Set Rs = Conn.Execute("SELECT * FROM
" _
& " lurah ORDER BY
Kelurahan")
If Not Rs.BOF Then
While Not Rs.EOF
cmblurah.AddItem Rs!Kelurahan
Rs.MoveNext
Wend
End If
End Sub
Private Sub DataGrid1_Click()
On Error Resume Next
TxtNoFaktur.Text =
DataGrid1.Columns(0).Text
TxtNoFaktur.Enabled = False
End Sub
Private Sub Listpemb_DblClick()
On Error Resume Next
Pesan = MsgBox("Barang ini
akan dihapus dari daftar..??", vbQuestion + vbYesNo, "Yakin")
If Pesan = vbYes Then
' TxtTotBeli.Text = Val(TxtTotBeli.Text) - Val(Listpemb.ListItems.Item(Listpemb.SelectedItem.Index).SubItems(4))
Listpemb.ListItems.Remove
(Listpemb.SelectedItem.Index)
TxtTotBeli.Text = ""
txtbilang = ""
End If
End Sub
Private Sub TbKeluar_Click()
If TbKeluar.Caption = "&Keluar"
Then
Unload Me
Else
FormNormal
txtbilang = ""
End If
End Sub
Private Sub TbMasuk_Click()
If TxtStok.Text - 0 <=
TxtBanyak.Text Then
MsgBox "barang tidak memadai"
Exit Sub
ElseIf TxtHarga = "" Then
MsgBox "Harga masih kosong!",
_
vbInformation + vbOKOnly,
"Information"
TxtHarga.SetFocus
ElseIf TxtBanyak = "" Then
MsgBox "Jumlah Masih Kosong", _
vbInformation + vbOKOnly,
"Information"
TxtBanyak.SetFocus
Else
Set View =
Listpemb.ListItems.Add(, , Text3.Text)
View.SubItems(1) = CmbBrg.Text
View.SubItems(2) = TxtHarga.Text
View.SubItems(3) = TxtBanyak.Text
View.SubItems(4) = TxtTotHarga.Text
TxtTotBeli.Text = Val(TxtTotBeli.Text)
+ Val(TxtTotHarga.Text)
txtbilang =
TerbilangBulat(TxtTotBeli.Text)
CmbBrg.Clear
TxtStok = ""
TxtHarga.Text = ""
TxtBanyak.Text = ""
TxtTotHarga.Text = ""
End If
End Sub
Private Sub TbSimpan_Click()
awal = 0
akhir = 0
If cmbcamat.ListIndex = -1 Then
MsgBox "Kecamatan Masih
Kosong!", _
vbInformation + vbOKOnly,
"Information"
cmbcamat.SetFocus
ElseIf cmblurah.ListIndex = -1 Then
MsgBox "Kelurahan Masih
Kosong!", _
vbInformation + vbOKOnly,
"Information"
cmblurah.SetFocus
ElseIf Listpemb.ListItems.Count = 0 Then
MsgBox "Data Barang nya Gak ada",
_
vbInformation + vbOKOnly,
"Information"
CmbBrg.SetFocus
Else
SqlInsert = ""
SqlInsert = "INSERT INTO
transaksi" _
& " VALUES('" &
TxtNoFaktur.Text & "','" _
& Format(DTPicker1.Value,
"yyyy-mm-dd") & "','" _
& cmbcamat.Text &
"','" & txtnama.Text & "','" & cmblurah.Text
& "','" & txtlurah.Text & "')"
Conn.Execute SqlInsert, ,
adCmdText
For i = 1 To Listpemb.ListItems.Count
SqlInsert = ""
SqlInsert = "INSERT INTO
rincitrans" _
&
"(Nota,tgl,Kecamatan,Kelurahan,Kode_barang,Nama_barang,qty,total_harga)"
_
& "VALUES ('"
& TxtNoFaktur.Text & "','" & Format(DTPicker1.Value,
"yyyy-mm-dd") & "','" & cmbcamat.Text &
"','" & cmblurah.Text & "','" _
& Listpemb.ListItems.Item(i).Text
& "','" _
&
Listpemb.ListItems.Item(i).SubItems(1) & "','" _
&
Listpemb.ListItems.Item(i).SubItems(3) & "','" _
&
Listpemb.ListItems.Item(i).SubItems(4) & "')"
Conn.Execute SqlInsert, , adCmdText
SqlUpdate = ""
SqlUpdate = "update
Barang set Jumlah = Jumlah - " &
Val(Listpemb.ListItems.Item(i).SubItems(3)) & " where Kode_barang =
'" & Listpemb.ListItems.Item(i).Text & "'"
Conn.Execute SqlUpdate, ,
adCmdText
Next i
Adodc3.Refresh
DataGrid1.Refresh
MsgBox "Data telah tersimpan
dalam database !", _
vbOKOnly + vbInformation, "Konfirmasi"
FBukti.Show
FBukti.Text3.Text = txtbilang
FBukti.Text1.Text =
TxtNoFaktur.Text
FBukti.Text2.SetFocus
FormNormal
End If
End Sub
Private Sub TbTambah_Click()
'TxtTglFaktur.Text = Format(Date,
"dd/MM/yyyy")
Call No_Faktur
FormKondisi (True)
TbTambah.Enabled = False
TbKeluar.Caption = "&Batal"
TbSimpan.Enabled = True
TbMasuk.Enabled = True
'DTPicker1.Enabled = False
TxtNoFaktur.Enabled = False
cmbcamat.SetFocus
baris = 1
txtbilang = ""
End Sub
Private Sub Form_Load()
Call Bukadatabase
Call AturListView(Listpemb, "Kode Barang", 15, "Nama
Barang", 30, _
"Harga", 20, "Jumlah",
20, "Total", 20)
Call Bukadatabase
Move (Screen.Width - Width) / 2, _
(Screen.Height - Height) / 3
FormKondisi (False)
TbSimpan.Enabled = False
TbMasuk.Enabled = False
DTPicker1.Value = Now
End Sub
Sub FormKondisi(KForm As Boolean)
'TxtNoFaktur.Enabled = KForm
DTPicker1.Enabled = KForm
cmbcamat.Enabled = KForm
txtnama.Enabled = KForm
CmbBrg.Enabled = KForm
cmblurah.Enabled = KForm
TxtStok.Enabled = KForm
TxtHarga.Enabled = KForm
TxtBanyak.Enabled = KForm
TxtTotHarga.Enabled = KForm
TxtTotBeli.Enabled = KForm
End Sub
Sub FormNormal()
FormKosong
FormKondisi (False)
TbSimpan.Enabled = False
TbKeluar.Caption = "&Keluar"
TbTambah.Enabled = True
TbSimpan.Caption = "Simpan"
TbMasuk.Enabled = False
End Sub
Sub FormKosong()
'TxtNoFaktur.Text = ""
cmbcamat.ListIndex = -1
txtnama.Text = ""
CmbBrg.ListIndex = -1
TxtStok.Text = ""
TxtHarga.Text = ""
TxtBanyak.Text = ""
TxtTotHarga.Text = ""
TxtTotBeli.Text = ""
Listpemb.ListItems.Clear
baris = 1
cmblurah.Text = ""
txtlurah.Text = ""
End Sub
Public Sub AturListView(LSV As
ListView, ParamArray lstview())
Dim i, lebar
LSV.View = lvwReport
lebar = LSV.Width - 80
With
LSV.ColumnHeaders
.Clear
For i = 0 To UBound(lstview) - 1 Step 2
.Add , , lstview(i), (lstview(i + 1) *
lebar) / 100
Next i
End With
End Sub
Private Sub cmbcamat_Click()
kddiv = ""
Set Rs = Conn.Execute("SELECT * FROM
" _
& " camat WHERE
Kecamatan='" & cmbcamat.Text & "'")
With Rs
If .EOF And .BOF Then
Exit Sub
Else
kddiv = Rs!kecamatan
txtnama.Text = Rs!Nama_camat
End If
End With
End Sub
Private Sub cmbcamat_DropDown()
cmbcamat.Clear
Set Rs = Conn.Execute("SELECT * FROM
" _
& " camat ORDER BY
Nama_camat")
If Not Rs.BOF Then
While Not Rs.EOF
cmbcamat.AddItem Rs!kecamatan
Rs.MoveNext
Wend
End If
End Sub
Private Sub CmbBrg_Click()
kdbrg = ""
Set Rs = Conn.Execute("SELECT * FROM
" _
& " barang WHERE
Nama_barang='" & CmbBrg.Text & "'")
With Rs
If .EOF And .BOF Then
Exit Sub
Else
Text3.Text = Rs!Kode_barang
TxtStok.Text = Rs!Jumlah
TxtHarga.Text = Rs!Harga
TxtBanyak.SetFocus
End If
End With
End Sub
Private Sub CmbBrg_DropDown()
CmbBrg.Clear
Set Rs = Conn.Execute("SELECT * FROM
" _
& " barang ORDER BY
Kode_barang")
If Not Rs.BOF Then
While Not Rs.EOF
CmbBrg.AddItem Rs!Nama_barang
Rs.MoveNext
txtbilang = ""
Wend
End If
End Sub
Private Sub Text1_Change()
'Text2.Text = Val(Text5.Text) -
Val(Text1.Text)
End Sub
Private Sub Text4_Change()
Text5.Text = Val(TxtTotBeli.Text)
- ((Val(Text4.Text) / 100) * Val(TxtTotBeli.Text))
End Sub
Private Sub TxtBanyak_Change()
On Error Resume Next
If TxtBanyak.Text = "" Or
TxtHarga.Text = "" Then
TxtTotHarga.Text = "0"
Exit Sub
Else
TxtTotHarga.Text = TxtBanyak.Text *
TxtHarga.Text
End If
End Sub
Public Function
TerbilangBulat(strAngka As String, _
Optional MataUang As String =
"Rupiah") As String
Dim strJmlHuruf$, intPecahan As Integer
Dim strPecahan$, Urai$, Bil1$, strTot$, Bil2$
Dim X As Integer, y As Integer, z As Integer
On Error GoTo Pesan
Dim strValid As String, huruf As String * 1
Dim i As Integer
'Periksa setiap karakter yg diketikkan ke kotak UserID
strValid = "1234567890"
For i% = 1 To Len(strAngka)
huruf = Chr(Asc(Mid(strAngka, i%, 1)))
If InStr(strValid, huruf) = 0 Then
Set AngkaTerbilang = Nothing
MsgBox "Harus karakter
angka!", _
vbCritical, "Karakter Tidak
Valid"
Exit Function
End If
Next i%
If strAngka = "" Then Exit Function
If Len(Trim(strAngka)) > 15 Then GoTo Pesan
strJmlHuruf = LTrim(strAngka)
'intPecahan = Val(Right(Mid(strAngka, 15, 2), 2))
If (intPecahan = 0) Then
strPecahan = ""
Else
'strPecahan = LTrim(Str(intPecahan)) +
"/100 "
strPecahan = ""
End If
X = 0
y = 0
Urai = ""
While (X < Len(strJmlHuruf))
X = X + 1
strTot = Mid(strJmlHuruf, X, 1)
y = y + Val(strTot)
z = Len(strJmlHuruf) - X + 1
Select Case Val(strTot)
Case 1
If (z = 1 Or z = 7 Or z = 10 Or z = 13)
Then
Bil1 = "Satu "
ElseIf (z = 4) Then
If (X = 1) Then
Bil1 = "Se"
Else
Bil1 = "Satu "
End If
ElseIf (z = 2 Or z = 5 Or z = 8 Or z =
11 Or z = 14) Then
X = X + 1
strTot = Mid(strJmlHuruf, X, 1)
z = Len(strJmlHuruf) - X + 1
Bil2 = ""
Select Case Val(strTot)
Case 0: Bil1 = "Sepuluh "
Case 1: Bil1 = "Sebelas "
Case 2: Bil1 = "Dua Belas "
Case 3: Bil1 = "Tiga Belas "
Case 4: Bil1 = "Empat Belas "
Case 5: Bil1 = "Lima Belas "
Case 6: Bil1 = "Enam Belas "
Case 7: Bil1 = "Tujuh Belas "
Case 8: Bil1 = "Delapan Belas "
Case 9: Bil1 = "Sembilan Belas "
End Select
Else
Bil1 = "Se"
End If
Case 2:
Bil1 = "Dua "
Case 3:
Bil1 = "Tiga "
Case 4:
Bil1 = "Empat "
Case 5:
Bil1 = "Lima "
Case 6:
Bil1 = "Enam "
Case 7:
Bil1 = "Tujuh "
Case 8:
Bil1 = "Delapan "
Case 9:
Bil1 = "Sembilan "
Case Else
Bil1 = ""
End Select
If (Val(strTot) > 0) Then
If (z = 2 Or z = 5 Or z = 8 Or z = 11
Or z = 14) Then
Bil2 = "Puluh "
ElseIf (z = 3 Or z = 6 Or z = 9 Or z =
12 Or z = 15) Then
Bil2 = "Ratus "
Else
Bil2 = ""
End If
Else
Bil2 = ""
End If
If (y > 0) Then
Select Case z
Case 4: Bil2 = Bil2 + "Ribu "
y = 0
Case 7: Bil2 = Bil2 + "Juta "
y = 0
Case 10: Bil2 = Bil2 + "Milyar "
y = 0
Case 13: Bil2 = Bil2 + "Trilyun "
y = 0
End Select
End If
Urai = Urai + Bil1 + Bil2
Wend
Urai = Urai + strPecahan
TerbilangBulat = (Urai & MataUang)
Exit Function
Pesan:
TerbilangBulat = "(maksimal 15 digit)"
End Function
Private Sub txtcari_Change()
Set transaksi =
Conn.Execute(" SELECT * FROM transaksi WHERE nota LIKE '" &
txtcari.Text & "%'")
Set DataGrid1.DataSource = transaksi
End Sub
Private Sub XPButton1_Click()
SQL = "delete from transaksi
where nota='" & TxtNoFaktur.Text & "'"
Conn.Execute SQL
Adodc3.Refresh
DataGrid1.Refresh
Call Form_Load
FBantuan.Refresh
SQL = "delete from
rincitrans where nota='" & TxtNoFaktur.Text & "'"
Conn.Execute SQL
MsgBox "Data Telah di
Hapus"
Adodc3.Refresh
DataGrid1.Refresh
FBantuan.Refresh
End Sub
Hahaahahahhhaa
selasaiiiiiiiiiiiiiiiiiiiiiiiii..
Uppppssssss sori sob ada yang
ketiggalan ne, Modul program blum dibuat,, yah tinggal kita tambahkan saja satu
buah modul dengan nama modul1.
Ini Scriptnya:
Option Explicit
Public Conn As New
ADODB.Connection
Public Rs As ADODB.Recordset
Public StrConnect As String
Public SqlInsert As String
Public SqlUpdate As String
Public SqlDelete As String
Public SQL As String
Public View As ListItem
Public i As Byte
Public Sub Bukadatabase()
Set Conn = New ADODB.Connection
Conn.CursorLocation = adUseClient
StrConnect =
"Provider=MSDASQL.1;Persist Security Info=False;Data Source=dsnbpbd"
If Conn.State = adStateOpen Then
Set Conn = New ADODB.Connection
Conn.Open StrConnect
Conn.Close
Else
Conn.Open StrConnect
Exit Sub
End If
End Sub
Finish…. Semoga bermanfaat..
Leave massage Bro