LISTING PROGRAM. 1. Listing Flash Pembuka. Private Sub Timer1_Timer() ProgressBar1.Value = ProgressBar1.Value + 4. If ProgressBar1

1

LISTING PROGRAM

1. Listing Flash Pembuka.

Private Sub Timer1_Timer() ProgressBar1.Value = ProgressBar1.Value + 4 If ProgressBar1.Value = 100 Then TA.Show Unload Me End If End Sub

2. tugas_akhir.frm

Private Sub nabout_Click() About.Show End Sub

Private Sub nadmin_Click()

Universitas Sumatera Utara

2

Admin.Show TA.Hide End Sub

Private Sub nexit_Click() exit1.Show End Sub

Private Sub ngizi_Click() gizi.Show End Sub

Private Sub npms_Click() Software.Show End Sub

3. Form2.frm

Private Sub cmdhasil_Click() Dim bulan As String Dim tanggal As Single bulan = cmbbln tanggal = cmbtgl hasil = Val(cmbtgl.Text + 14)


3

If bulan = 2 Then If tanggal < 17 Then MsgBox hasil Else MsgBox hasil - 28 End If

ElseIf bulan = 4 Then If tanggal < 17 Then MsgBox hasil Else MsgBox hasil - 30 End If


ElseIf bulan = 9 Then If tanggal < 17 Then MsgBox hasil Else


4

MsgBox hasil - 30 End If


ElseIf bulan = 1 Or 3 Or 5 Or 7 Or 8 Or 10 Or 12 Then If tanggal < 17 Then MsgBox hasil Else MsgBox hasil - 31 End If

Else MsgBox hasil - 30

End If

End Sub


5

Private Sub Form_Load() TA.Hide Dim I As Integer For I = 1 To 12 cmbbln.AddItem I Next

For I = 1 To 31 cmbtgl.AddItem I Next End Sub

Private Sub Form_Unload(Cancel As Integer) TA.Visible = True End Sub


Private Sub nadmin_Click() Admin.Show End Sub

Private Sub nexit_Click()


6

exit1.Show End Sub



4. gizi.frm

Private Sub cmdreset_Click() txtBB.Text = "" Text1.Text = "" txtumur.Text = "" txtBB.SetFocus End Sub

Private Sub cmdsearch1_Click() Dim I As String Dim A As String Dim X As String


7

I = InputBox("Silahkan Masukkan Nama", "Search") A = "nama_makanan = '" & I & "'" Adodc1.Recordset.Find A If Adodc1.Recordset.EOF Then X = MsgBox("Data Not Found!", vbOKOnly, "Pencarian Nama Makanan!") Adodc1.Recordset.MoveFirst End If End Sub

Private Sub cmdsubmit_Click() Dim pria As Single Dim wanita As Single Dim tiber As Single Dim oring As Single Dim ose As Single Dim oin As Single Dim apro As Single pria = Option2 wanita = Option3 tiber = opt1 oring = opt2 ose = opt3 oin = opt4(0) apro = opt5


8

If pria Then If tiber Then

hasil = Val((660 + (txtBB.Text * 13.7) + (Text1.Text * 5) - (txtumur.Text * 6.8)) * 1.2) MsgBox hasil

ElseIf oring Then


ElseIf ose Then


ElseIf oin Then



9

Else

hasil = Val((660 + (txtBB.Text * 13.7) + (Text1.Text * 5) - (txtumur.Text * 6.8)) * 1.9) MsgBox hasil End If

Else

If tiber Then

hasil = Val((655 + (txtBB.Text * 9.6) + (Text1.Text * 1.8) - (txtumur.Text * 4.7)) * 1.2) MsgBox hasil

ElseIf oring Then


ElseIf ose Then

hasil = Val((655 + (txtBB.Text * 9.6) + (Text1.Text * 1.8) - (txtumur.Text * 4.7)) * 1.55)


10

MsgBox hasil

ElseIf oin Then


Else hasil = Val((655 + (txtBB.Text * 9.6) + (Text1.Text * 1.8) - (txtumur.Text * 4.7)) * 1.9) MsgBox hasil End If End If End Sub

Private Sub Form_Load() TA.Hide End Sub


Private Sub nabout_Click()


11

About.Show End Sub Private Sub nadmin_Click() Admin.Show End Sub



5. Admin.frm

Private Sub admin1_DragDrop(Source As Control, X As Single, Y As Single) End Sub

Private Sub cmdreset_Click() txtusername.Text = "" txtpassword.Text = "" txtusername.SetFocus


12

End Sub

Private Sub Form_Load() Call BukaDb TA.Hide End Sub

Private Sub cmdsubmit_Click() If txtusername.Text = "" Then MsgBox " Masukkan Username Anda!!", vbExclamation, "Alert" txtusername.SetFocus Exit Sub End If

If txtpassword.Text = "" Then MsgBox "Masukkan Password Anda !!", vbExclamation, "Alert" txtpassword.SetFocus Exit Sub End If

Dim strSQL2 As String Dim RSuser As ADODB.Recordset Dim intCounter2 As Integer


13

strSQL2 = "Select* from admin where nama = '" & txtusername & "' AND password = '" & txtpassword & "'" Set rcs = conn.Execute(strSQL2) With rcs If Not .EOF Then MsgBox "Login sukses", vbExclamation, "Alert" isiadmin.Show Else: MsgBox "Gagal Login!!", vbExclamation, "Alert" txtusername.SetFocus End If End With

txtusername.Text = "" txtpassword.Text = "" Admin.Hide End Sub


Private Sub ListView1_BeforeLabelEdit(Cancel As Integer) End Sub

Private Sub nabout_Click()


14

About.Show End Sub




6. form_kania.frm


Private Sub cmddelete_Click() Dim delete As String


15

tanya = MsgBox("Are you sure to delete this data? : " & txtmakanan.Text & " ?", vbQuestion + vbYesNo, " Delete confirm")

If tanya = vbYes Then delete = "Delete from daftar_makanan Where nama_makanan ='" & txtmakanan.Text & "'" conn.Execute (delete) txtno.Text = "" txtmakanan.Text = "" txtkdrgizi.Text = "" Text1.Text = "" txtgol.Text = "" MsgBox "Data telah berhasil dihapus! ", vbExclamation, "Alert" Adodc1.Refresh Else Exit Sub End If End Sub

Private Sub cmdinsert_Click() txtno.Text = "" txtmakanan.Text = "" txtkdrgizi.Text = ""


16

Text1.Text = "" txtgol.Text = "" txtno.Locked = False txtmakanan.Locked = False txtkdrgizi.Locked = False Text1.Locked = False txtgol.Locked = False txtno.SetFocus cmdinsert.Enabled = False cmdsave.Enabled = True End Sub

Private Sub cmdlogout_Click() TA.Show isiadmin.Hide End Sub

Private Sub cmdsave_Click() Dim strSQL As String Dim RSuser As ADODB.Recordset

If txtno.Text = "" Then MsgBox "Masukkan No. ", vbExclamation, "Alert" Exit Sub End If


17

If txtmakanan.Text = "" Then MsgBox "Masukkan Nama Makanan.", vbExclamation, "Alert" Exit Sub End If

If txtkdrgizi.Text = "" Then MsgBox " Masukkan Kadar Gizi.", vbExclamation, "Alert" Exit Sub End If

If Text1.Text = "" Then MsgBox " Masukkan Jumlah Kalori.", vbExclamation, "Alert" Exit Sub End If

If txtgol.Text = "" Then MsgBox " Masukkan Berat.", vbExclamation, "Alert" Exit Sub End If

strSQL = "insert into daftar_makanan Values( '" & txtno.Text & "', '" & txtmakanan.Text & "','" & txtkdrgizi.Text & "','" & Text1.Text & "','" & txtgol.Text & "')" conn.Execute (strSQL)


18

txtno.Text = "" txtmakanan.Text = "" txtkdrgizi.Text = "" Text1.Text = "" txtgol.Text = "" MsgBox "Data Berhasil Disimpan Pada Database!!", vbExclamation, "Alert" txtno.Locked = True txtmakanan.Locked = True txtkdrgizi.Locked = True Text1.Locked = True txtgol.Locked = True

cmdinsert.Enabled = True cmdsave.Enabled = False Adodc1.Refresh End Sub

Private Sub cmdsearch_Click() Dim I As String Dim A As String Dim X As String I = InputBox("Silahkan Masukkan Nama", "Search") X = "select * from daftar_makanan where nama_makanan='" & I & "'"


19

Set rcs = conn.Execute(X) If Not rcs.EOF Then txtno.Text = rcs(0) txtmakanan.Text = rcs(1) txtkdrgizi.Text = rcs(2) Text1.Text = rcs(3) txtgol.Text = rcs(4) Else MsgBox "Data Not Found ", vbCritical, "Pesan" End If End Sub

Private Sub cmdupdate_Click() Dim strUpdate As String strUpdate = "Update daftar_makanan Set No = '" & txtno.Text & "' ,nama_makanan = '" & txtmakanan.Text & "', kandungan_gizi = '" & txtkdrgizi.Text & "', jumlah_kalori = '" & Text1.Text & "', Berat = '" & txtgol.Text & "' where nama_makanan = '" & txtmakanan.Text & "'" conn.Execute (strUpdate) txtno.Text = "" txtmakanan.Text = "" txtkdrgizi.Text = "" Text1.Text = ""


20

txtgol.Text = "" Adodc1.Refresh Exit Sub MsgBox " Data Berhasil di Update. ", vbExclamation, "Alert" Adodc1.Refresh cmdupdate.Enabled = False txtno.Locked = True txtmakanan.Locked = True txtkdrgizi.Locked = True Text1.Locked = True txtgol.Locked = True End Sub

Private Sub Form_Load() Call BukaDb Admin.Hide Me.Caption = App.Title End Sub


Private Sub nexit_Click()


21

exit1.Show End Sub



7. About.frm

Private Sub cmdok_Click() TA.Show End Sub

Private Sub Form_Load() TA.Hide End Sub



22

Private Sub nadmin_Click() Admin.Show End Sub




8. Module

Option Explicit Public nama, id As String Public conn As ADODB.Connection Public SqlSimpan, sql As String Public rcs As ADODB.Recordset


23

' Prosedur untuk koneksi ke Server MySQL Sub BukaDb() Set conn = New ADODB.Connection conn.ConnectionString = "" _ & "DRIVER={MySQL ODBC 3.51 Driver};" _ & "SERVER=localhost;" _ & "DATABASE=proyek_ta;" _ & "UID=root;" _ & "PWD=;" _ & "OPTION=" ' Melewatkan apabila ada error On Error Resume Next ' Membuka Koneksi dengan melihat status If conn.State = adStateOpen Then conn.Close Set conn = New ADODB.Connection conn.Open Else conn.Open End If 'Periksa koneksi apakah sudah berhasil If Err.Number <> 0 Then MsgBox "Gagal Membuka database", vbOKOnly, "Kesalahan" End


24

Else MsgBox "Koneksi Databaes Berhasil", vbOKOnly, "PESAN" 'PenjualanDb'Sukses..!!", _ vbInformation , "Pesan" End If End Sub


LISTING PROGRAM. 1. Listing Flash Pembuka. Private Sub Timer1_Timer() ProgressBar1.Value = ProgressBar1.Value + 4. If ProgressBar1

Recommend Documents