Program Aplikasi Pendistribusian Bantuan Bencana Dengan VB 6 Databes Mysql

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

Berikut adalah screenshot Menu utamanya:

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

2.       Desain Program seperti dibawah:

3.       Keterangan:

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.

Selanjutnya kita buat form untuk kecamatan dengan Nama Form FKecamatan.

Desain Fornya Sebagai berikut:

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 If

    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

Baca Selengkapnya → Program Aplikasi Pendistribusian Bantuan Bencana Dengan VB 6 Databes Mysql