Posted by: Hartoto | 09/23/2008

PROYEK DATABASE SMADA BAGIAN II

Akhirnya kita sampai juga pada bagian ini, bagian inti dari database yang akan kita buat. Bagi yang sudah beli puyer cap 19, kini saaatnya membuktikan khasiatnya. Bagi yang belum, tolong segera tinggalkan komputer anda an bergegaslah ke apotek-apotek terdekat (ingat saudara janga membeli oabat di warung-awas obat palsu J)

Jika semua telah dirasa cukup, baiklah mari kita lanjutkan proyek kita ini…

Sebelumnya saya meminta maaf pada anda yang membaca artikel ini, bukan maksud saya untuk menggurui anda, tidak ada yang patut saya pamerkan, apalagi hanya program kecil seperti ini, sangat tidak rasional. Saya hanya ingin berbagi kepada anda. Sebagian dari anda mungkin menganggap listing program dibawah ini sangat rancu dan berbelit-belit. Itu harapan saya,kanda-kanda yang memiliki ilmu lebih tolong dibagikan pada adindamu ini, saran dan kritik sangat saya harapkan dan saya akan berguru kepada anda. Maklum saya tidak memiliki guru resmi. Hanya help di Macro Office Word saja referensi saya, sangat terbatas.

OK, kita lanjut saja . Tak Usahlah Kita Banyak Cakap. Berikut ini listing program database SMADA yang sementara kita buat…

MASTER DATABASE

‘=====================================================| CUT HERE

‘====================| MODUL [Start_Up] |====================

Option Explicit

‘konstatanta untuk meminimize program yang jalan dan menampilkan desktop

Declare Sub keybd_event Lib “user32” (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)

Public Const VK_LWIN = &H5B

Public Const KEYEVENTF_KEYUP = &H2

‘untuk tampilan form paling atas

Public Declare Function SetWindowPos Lib “user32” (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, Y, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long

Public Const HWND_TOPMOST = -1

Public Const SWP_NOMOVE = &H2

Public Const SWP_NOSIZE = &H1

Public Const TOPMOST_FLAGS = SWP_NOMOVE Or SWP_NOSIZE

‘untuk kopi dan delete file

Public Declare Function CopyFile Lib “kernel32” Alias “CopyFileA” (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailifExists As Long) As Long

Public Declare Function DeleteFile Lib “kernel32” Alias “DeleteFileA” (ByVal lpFileName As String) As Long

‘untuk deklarasi variabel

Public Const FlagSplash As Boolean = True

Public grup As String

Public pernah_login As Boolean

Public login_sukses As Boolean

‘====================| CLASS MODUL [clsfrmtop] |====================

Sub Main()

On Error Resume Next

Dim ShowAtStartup As Long

Dim Start As Variant

Dim i As Integer

Start = Timer

If FlagSplash Then

With frmSplash

.Show

For i = 0 To .LabRan.Count – 1

.LabRan(i).Visible = True

Next i

Do While Timer <= Start + 7 + 1

DoEvents

For i = 0 To .LabRan.Count – 1

.LabRan(i).Caption = Int(Rnd * 100000000#)

Next i

Loop

End With

End If

Unload frmSplash

frmLogin.Show

End Sub

‘====================| frmMain |====================

‘untuk mendeklarasikan variabel ang akan digunakan

Dim namaTombol As String

Dim Cari As String, Cari1 As String

Dim hasil As String, Hasil1 As String

Dim StatusFilter As Boolean

Dim StatusSortASC As Boolean

Dim StatusSortDESC As Boolean

Private lngformWidth As Long

Private lngformHeight As Long

‘fungsi untuk mengunci picture box yang bernama utility

Sub kunci_utiliti(InFrame As PictureBox, _

ByVal Flag As Boolean)

Dim Contrl As Control

On Error Resume Next ‘Jika error, lanjutkan saja

InFrame.Enabled = Flag

‘Utk setiap control yg ada di dalam picture/frame ybt

For Each Contrl In InFrame.Parent.Controls

If (Contrl.Container.Name = InFrame.Name) Then

If (TypeOf Contrl Is Frame) And Not _

(Contrl.Name = InFrame.Name) Then

EnablePicture Contrl, Flag

Else

If Not (TypeOf Contrl Is Menu) Then _

Contrl.Enabled = Flag

End If

End If

Next

End Sub

Sub bangkit()

Call form_Load

End Sub

Private Sub cmdExit_Click()

End

End Sub

Private Sub cmdLogin_Click()

frmLogin.Show

End Sub

Sub hak_akses()

StatusFilter = False

StatusSortASC = False

StatusSortDESC = False

AmbilData

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

Kunci

picButtons.Enabled = True

picUtility.Enabled = True

picStatBox.Enabled = True

frame_tools.Enabled = True

grdDataGrid.Enabled = True

lblstatus.Caption = “Login Sebagai : ” & grup

End Sub

Private Sub Form_Resize()

Dim D(4) As Double

Dim i As Long

Dim TempPoz As Long

Dim StartPoz As Long

Dim Ctl As Control

Dim TempVisible As Boolean

Dim ScaleX As Double

Dim ScaleY As Double

‘Hitung skala-nya

ScaleX = ScaleWidth / lngFormWidth

ScaleY = ScaleHeight / lngFormHeight

On Error Resume Next

‘Untuk setiap control yang terdapat di form

For Each Ctl In Me

TempVisible = Ctl.Visible

Ctl.Visible = False

StartPoz = 1

‘Baca data dari property Tag

For i = 0 To 4

TempPoz = InStr(StartPoz, Ctl.Tag, ” “, _

vbTextCompare)

If TempPoz > 0 Then

D(i) = Mid(Ctl.Tag, StartPoz, _

TempPoz – StartPoz)

StartPoz = TempPoz + 1

Else

D(i) = 0

End If

‘Pindahkan control berdasarkan data

‘di property Tag dan di skala form

Ctl.Move D(0) * ScaleX, D(1) * ScaleY, _

D(2) * ScaleX, D(3) * ScaleY

Ctl.Width = D(2) * ScaleX

Ctl.Height = D(3) * ScaleY

‘Ganti ukuran huruf

If ScaleX < ScaleY Then

Ctl.FontSize = D(4) * ScaleX

Else

Ctl.FontSize = D(4) * ScaleY

End If

Next i

Ctl.Visible = TempVisible

Next Ctl

On Error GoTo 0

End Sub

Private Sub form_Load()

Dim Ctl As Control

‘Tempatkan dimensi form dalam variabel

lngformWidth = ScaleWidth

lngformHeight = ScaleHeight

‘Tempatkan inisialisasi dimensi control dalam ‘property Tag – dengan penanganan error untuk ‘controls yang tidak memiliki properties seperti ‘Top (misalnya: control Line)

On Error Resume Next

For Each Ctl In Me

Ctl.Tag = Ctl.Left & ” ” & Ctl.Top & ” ” & _

Ctl.Width & ” ” & Ctl.Height & ” “

Ctl.Tag = Ctl.Tag & Ctl.FontSize & ” “

Next Ctl

On Error GoTo 0

‘——————–

If pernah_login Then

If login_sukses Then

Me.Enabled = True

If grup = “Programer” Or grup = “Administrator” Or grup = “Operator” Then

Call hak_akses

cmdAdd.Enabled = True

cmdDelete.Enabled = True

cmdEdit.Enabled = True

EnablePicture picUtility, True

ElseIf grup = “User” Then

Call hak_akses

EnablePicture picUtility, True

cmdAdd.Enabled = False

cmdDelete.Enabled = False

cmdEdit.Enabled = False

kunci_utiliti picUtility, True

ElseIf grup = “Guest” Then

Call hak_akses

EnablePicture picUtility, True

cmdAdd.Enabled = False

cmdDelete.Enabled = False

cmdEdit.Enabled = False

kunci_utiliti picUtility, False

End If

Else

Call hak_akses

lblstatus.Caption = “Login Gagal”

Exit Sub

End If

Else:

AmbilData

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

Kunci

picButtons.Enabled = False

picUtility.Enabled = False

picStatBox.Enabled = False

frmLogin.Zorder (0)

frmMain.Zorder (1)

lblstatus.Caption = “Belum Login”

End If

End Sub

Private Sub cmdView_Click()

frminfo.Show

End Sub

Private Sub cmdEdit_Click()

BukaKunci

EnablePicture picUtility, False

SetButtons False

txtFields(0).SetFocus

SendKeys “{Home}+{End}”

End Sub

Private Sub cmdAbout_Click()

frmAboutMe.Show

End Sub

Private Sub cmdCancel_Click()

On Error GoTo Pesan

adoPrimaryRS.Recordset.Cancel

EnablePicture picUtility, True

EnablePicture picStatBox, True

If StatusFilter = True Or _

StatusSortASC = True Or _

StatusSortDESC = True Then

StatusSortASC = False

StatusSortDESC = False

StatusFilter = False

AmbilData

cmdUnFilter_Click

SetButtons True

Kunci

grdDataGrid.Enabled = True

Call IsiTextFields

Exit Sub

End If

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

cmdRefresh_Click

SetButtons True

Kunci

grdDataGrid.Enabled = True

Call IsiTextFields

Exit Sub

Pesan:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdClearSearch_Click()

‘Membersihkan kriteria pencarian

Dim jawab As Integer

If Len(Cari) = 0 Then

MsgBox “Belum ada kriteria pencarian.”, _

vbInformation, “Kriteria Masih Kosong”

Exit Sub

Else

jawab = MsgBox(“Kriteria pencarian sebelumnya = ” _

& Cari & “” & Chr(13) & _

Anda yakin ingin menghapusnya?”, _

vbQuestion + vbYesNo, “Reset Pencarian”)

End If

If jawab = vbYes Then

cmdFindFirst.Enabled = True

frmInfo.cmdFindFirst.Enabled = True

Cari = “”

hasil = “”

frmInfo.Text1 = “”

End If

End Sub

Private Sub cmdFilter_Click()

Dim kriteria As String

On Error GoTo Pesan

kriteria = InputBox(“Masukkan data apa saja yang diketahui:”, “Saring/Filter Data”)

If kriteria = “” Then Exit Sub

adoPrimaryRS.RecordSource = “” ‘Bersihkan memori sebelumnya

adoPrimaryRS.RecordSource = “SHAPE ” & _

“{select * from SISWA_SMADA ” & _

“WHERE NIS LIKE ‘%” & kriteria & “%’ OR ” & “Nama LIKE ‘%” & kriteria & “%’ OR ” & “Jenis_Kelamin LIKE ‘%” & kriteria & “%’ OR ” & “Kelas LIKE ‘%” & kriteria & “%’ OR ” & _

“Tempat_Lahir LIKE ‘%” & kriteria & “%’ OR ” & “Tgl_Lahir LIKE ‘%” & kriteria & “%’ OR ” & _

Organisasi_Ekstra LIKE ‘%” & kriteria & “%’ OR ” & “Alamat_Makassar LIKE ‘%” & kriteria & “%’ OR ” & “Tlp_Hp LIKE ‘%” & kriteria & “%’ OR ” & “Email LIKE ‘%” & kriteria & “%’ OR ” & “Home_Page LIKE ‘%” & kriteria & “%’ OR ” & “Catatan LIKE ‘%” & kriteria & “%’ ” & _

“ORDER BY NIS} ” & _

“AS ParentCMD ” & _

“APPEND ({select * from SISWA_SMADA ” & _

“WHERE NIS LIKE ‘%” & kriteria & “%’ OR ” & “Nama LIKE ‘%” & kriteria & “%’ OR ” & “Jenis_Kelamin LIKE ‘%” & kriteria & “%’ OR ” & “Kelas LIKE ‘%” & kriteria & “%’ OR ” & _

“Tempat_Lahir LIKE ‘%” & kriteria & “%’ OR ” & “Tgl_Lahir LIKE ‘%” & kriteria & “%’ OR ” & _

Organisasi_Ekstra LIKE ‘%” & kriteria & “%’ OR ” & “Alamat_Makassar LIKE ‘%” & kriteria & “%’ OR ” & “Tlp_Hp LIKE ‘%” & kriteria & “%’ OR ” & “Email LIKE ‘%” & kriteria & “%’ OR ” & “Home_Page LIKE ‘%” & kriteria & “%’ OR ” & “Catatan LIKE ‘%” & kriteria & “%’ ” & _

“ORDER BY NIS} ” & _

“AS ChildCMD RELATE NIS TO NIS) ” & _

“AS ChildCMD”

adoPrimaryRS.Refresh

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

StatusFilter = True

If txtFields(0).Text = “” Then

cmdUnFilter_Click

MsgBox “‘” & kriteria & “‘ tidak ditemukan” & Chr(13) & _

“dalam data SISWA_SMADA!”, vbInformation, “Tidak Ditemukan”

Exit Sub

End If

Exit Sub

Pesan:

MsgBox “‘” & kriteria & “‘ tidak ditemukan” & Chr(13) & _

“dalam data SISWA_SMADA!”, vbCritical, “Tidak Ditemukan”

Call cmdUnFilter_Click

End Sub

Private Sub cmdPetunjuk_Click()

frmPetunjuk.Show

End Sub

Private Sub cmdSortASC_Click()

Dim kriteria As String

On Error GoTo Pesan

kriteria = InputBox(“Masukkan field yang akan di-sortd ASCENDING:” & vbCrLf & _

“Pilih salah satu:” & vbCrLf & _

“—————————————————————————————–” & vbCrLf & _

“NIS/Nama/Jenis_Kelamin/Kelas/” & vbCrLf & _

“Tempat_Lahir/Tgl_Lahir/Organisasi_Ekstra/” & vbCrLf & _

“Alamat_Makassar/Tlp_Hp/Email/Home_Page/Catatan” & vbCrLf & _

“—————————————————————————————–“, _

“Urutkan Data”)

If kriteria = “” Then Exit Sub

If (kriteria <> “NIS”) And (kriteria <> “Nama”) And _

(kriteria <> “Jenis_Kelamin”) And (kriteria <> “Kelas”) And _

(kriteria <> “Tempat_Lahir”) And (kriteria <> “Tgl_Lahir”) And _

(kriteria <> “Organisasi_Ekstra”) And (kriteria <> “Alamat_Makassar”) And _

(kriteria <> “Tlp_Hp”) And (kriteria <> “Email”) And _

(kriteria <> “Home_Page”) And (kriteria <> “Catatan”) Then

MsgBox “Isi dengan :” & vbCrLf & _

“—————————————————————–” & vbCrLf & _

“NIS/Nama/Jenis_Kelamin/Kelas/” & vbCrLf & _

“Tempat_Lahir/Tgl_Lahir/Organisasi_Ekstra/” & vbCrLf & _

“Alamat_Makassar/Tlp_Hp/Email/Home_Page/Catatan” & vbCrLf & _

“—————————————————————–“, _

vbCritical, “Nama Field Salah”

Exit Sub

End If

adoPrimaryRS.RecordSource = “SHAPE {select * from SISWA_SMADA ORDER BY ” _

& kriteria & ” ASC} AS ParentCMD APPEND ” & _

“({select * from SISWA_SMADA ORDER BY ” _

& kriteria & ” ASC} AS ChildCMD RELATE NIS ” & _

TO NIS) AS ChildCMD”

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

StatusSortASC = True

adoPrimaryRS.Refresh

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

Exit Sub

Pesan:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdSortDESC_Click()

Dim kriteria As String

On Error GoTo Pesan

Set rsCariData = New Recordset

kriteria = InputBox(“Masukkan field yang akan di-sortd DESCENDING:” & vbCrLf & _

“Pilih salah satu:” & vbCrLf & _

“—————————————————————————————–” & vbCrLf & _

“NIS/Nama/Jenis_Kelamin/Kelas/” & vbCrLf & _

“Tempat_Lahir/Tgl_Lahir/Organisasi_Ekstra/” & vbCrLf & _

“Alamat_Makassar/Tlp_Hp/Email/Home_Page/Catatan” & vbCrLf & _

“—————————————————————————————–“, _

“Urutkan Data”)

If kriteria = “” Then Exit Sub

If (kriteria <> “NIS”) And (kriteria <> “Nama”) And _

(kriteria <> “Jenis_Kelamin”) And (kriteria <> “Kelas”) And _

(kriteria <> “Tempat_Lahir”) And (kriteria <> “Tgl_Lahir”) And _

(kriteria <> “Organisasi_Ekstra”) And (kriteria <> “Alamat_Makassar”) And _

(kriteria <> “Tlp_Hp”) And (kriteria <> “Email”) And _

(kriteria <> “Home_Page”) And (kriteria <> “Catatan”) Then

MsgBox “Isi dengan :” & vbCrLf & _

“—————————————————————–” & vbCrLf & _

“NIS/Nama/Jenis_Kelamin/Kelas/” & vbCrLf & _

“Tempat_Lahir/Tgl_Lahir/Organisasi_Ekstra/” & vbCrLf & _

“Alamat_Makassar/Tlp_Hp/Email/Home_Page/Catatan” & vbCrLf & _

“—————————————————————–“, _

vbCritical, “Nama Field Salah”

Exit Sub

End If

adoPrimaryRS.RecordSource = “SHAPE {select * from SISWA_SMADA ORDER BY ” _

& kriteria & ” DESC} AS ParentCMD APPEND ” & _

“({select * from SISWA_SMADA ORDER BY ” _

& kriteria & ” DESC} AS ChildCMD RELATE NIS ” & _

TO NIS) AS ChildCMD”

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

StatusSortDESC = True

adoPrimaryRS.Refresh

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

Exit Sub

Pesan:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdUnFilter_Click()

On Error GoTo Pesan

AmbilData

‘adoPrimaryRS.Refresh

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

EnablePicture picButtons, True

cmdUpdate.Enabled = False

cmdCancel.Enabled = False

cmdEdit_Foto.Enabled = False

StatusFilter = False

Exit Sub

Pesan:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

‘Untuk mencari sembarang data mulai record pertama

‘di seluruh field ybt sampai ketemu pertama sekali pada

‘records berikutnya jika di record yang pertama tidak ada

Private Sub cmdFindFirst_Click()

Dim adoCari As Recordset

adoPrimaryRS.Recordset.MoveFirst

Set adoCari = New Recordset

If Cari = “” Then

Cari = UCase(InputBox(“Masukkan kata kunci pencarian yang diketahui:” & Chr(13) & _

“—————————————————————————————–” & Chr(13) & _

“Untuk pencarian tanggal dan bulan,gunakan garis miring” & Chr(13) & _

“Contoh: ” & Chr(91) & Chr(47) & “11” & Chr(47) & Chr(93) & “ untuk pencarian bulan, dan” & Chr(13) & _

” & Chr(91) & “30” & Chr(47) & Chr(93) & “ untuk pencarian tanggal” & Chr(13) & _

“—————————————————————————————–” _

, “Cari Data”))

Else

Cari = Cari1

End If

If StrPtr(Cari) = 0 Or Cari = “” Then Exit Sub

Ulang:

If adoPrimaryRS.Recordset.EOF And adoPrimaryRS.Recordset.RecordCount > 0 Then

adoPrimaryRS.Recordset.MoveLast

MsgBox “Data ” & Cari & ” tidak ditemukan!”, _

vbCritical, “Tidak Ditemukan”

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1 = “Data ” & Cari & ” tidak ditemukan!”

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

Close #1

Exit Sub

End If

For i = 0 To 8

hasil = UCase(txtFields(i).Text)

If InStr(1, UCase(txtFields(i).Text), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “Ditemukan data ‘” & Cari & “‘ pada:” & vbCrLf & _

“———————-” & String(Len(Cari) + 1, “-“) & “” & vbCrLf & _

“”

Print #1, frmInfo.Text1.Text

Close #1

For j = 0 To 8

hasil = UCase(txtFields(j).Text)

If InStr(1, UCase(txtFields(j).Text), UCase(Cari)) > 0 Then

Cari1 = Cari

‘Jika ketemu, beritahu user di field

‘mana saja data yg dicari berada

If j = 0 Or j = 1 Then

jwb = j + 1

ElseIf j = 2 Then

jwb = j + 3

ElseIf j = 3 Or j = 4 Or j = 5 Or j = 6 Or j = 7 Or j = 8 Then

jwb = j + 4

End If

Open FileName For Output As #1

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & txtFields(j).DataField & “” & vbCrLf & _

Isi field : ” & txtFields(j).Text & “” & vbCrLf & _

– Kolom ke : ” & jwb & ” di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Else

End If

Next j

Exit Sub

Else

End If

‘jenis kelamin

If InStr(1, UCase(cbJenis_Kelamin.Text), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1 = “” & frmInfo.Text1.Text & “Ditemukan data ‘” & Cari & “‘ pada:” & vbCrLf & _

“———————-” & String(Len(Cari) + 1, “-“) & “” & vbCrLf & _

“”

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & cbJenis_Kelamin.DataField & “” & vbCrLf & _

Isi field : ” & cbJenis_Kelamin.Text & “” & vbCrLf & _

– Kolom ke : 3 di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Exit Sub

End If

‘ kelas

If InStr(1, UCase(cbKelas.Text), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1 = “” & frmInfo.Text1.Text & “Ditemukan data ‘” & Cari & “‘ pada:” & vbCrLf & _

“———————-” & String(Len(Cari) + 1, “-“) & “” & vbCrLf & _

“”

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & cbKelas.DataField & “” & vbCrLf & _

Isi field : ” & cbKelas.Text & “” & vbCrLf & _

– Kolom ke : 4 di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Exit Sub

End If

‘dtpTglLahir

If InStr(1, UCase(dtpTglLahir.Value), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1 = “” & frmInfo.Text1.Text & “Ditemukan data ‘” & Cari & “‘ pada:” & vbCrLf & _

“———————-” & String(Len(Cari) + 1, “-“) & “” & vbCrLf & _

“”

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & dtpTglLahir.DataField & “” & vbCrLf & _

Isi field : ” & dtpTglLahir.Value & “” & vbCrLf & _

– Kolom ke : 6 di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Exit Sub

End If

Next i

adoPrimaryRS.Recordset.MoveNext

GoTo Ulang

End Sub

‘Untuk mencari sembarang data pada record berikutnya

‘di seluruh field mulai record I s.d. terakhir

‘di mana kriteria pencarian telah diketahui

‘pada saat pencarian pertama di atas…

Private Sub cmdFindNext_Click()

Cari1 = Cari

‘Jika belum pernah pencarian pertama,

If Len(Trim(hasil)) = 0 Then

‘MsgBox “Klik dulu tombol Find First”, vbCritical, “Find First”

cmdFindFirst_Click

Exit Sub

End If

‘Jika sudah pernah dicari sebelumnya

adoPrimaryRS.Recordset.MoveNext

Ulang:

‘Jika tdk ketemu

If adoPrimaryRS.Recordset.EOF And adoPrimaryRS.Recordset.RecordCount > 0 Then

adoPrimaryRS.Recordset.MoveLast

MsgBox “Data ” & Cari & ” tidak ditemukan!”, vbCritical, “Tidak Ditemukan”

Exit Sub

End If

For n = 0 To 8

hasil = UCase(txtFields(n).Text)

If InStr(1, UCase(txtFields(n).Text), UCase(Cari1)) > 0 Then

For m = 0 To 8

hasil = UCase(txtFields(m).Text)

If InStr(1, UCase(txtFields(m).Text), UCase(Cari1)) > 0 Then

‘Jika ketemu, beritahu user di field

‘mana saja data yg dicari berada

If m = 0 Or m = 1 Then

jwb = m + 1

ElseIf m = 2 Then

jwb = m + 3

ElseIf m = 3 Or m = 4 Or m = 5 Or m = 6 Or m = 7 Or m = 8 Then

jwb = m + 4

End If

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & txtFields(m).DataField & “” & vbCrLf & _

Isi field : ” & txtFields(m).Text & “” & vbCrLf & _

– Kolom ke : ” & jwb & ” di tabel.”

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Else

End If

Next m

Exit Sub

Else

End If

‘ jenis kelamin

If InStr(1, UCase(cbJenis_Kelamin.Text), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & cbJenis_Kelamin.DataField & “” & vbCrLf & _

Isi field : ” & cbJenis_Kelamin.Text & “” & vbCrLf & _

– Kolom ke : 3 di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Exit Sub

End If

‘ kelas

If InStr(1, UCase(cbKelas.Text), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1 = “” & frmInfo.Text1.Text & “Ditemukan data ‘” & Cari & “‘ pada:” & vbCrLf & _

“———————-” & String(Len(Cari) + 1, “-“) & “” & vbCrLf & _

“”

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & cbKelas.DataField & “” & vbCrLf & _

Isi field : ” & cbKelas.Text & “” & vbCrLf & _

– Kolom ke : 4 di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Exit Sub

End If

‘tgl lahir

If InStr(1, UCase(dtpTglLahir.Value), UCase(Cari)) > 0 Then

FileName = “Info.dat”

Open FileName For Output As #1

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text)

frmInfo.Text1 = “” & frmInfo.Text1.Text & “” & vbCrLf & _

Record ke-” & CStr(adoPrimaryRS.Recordset.AbsolutePosition) & “” & vbCrLf & _

– Nama field: ” & dtpTglLahir.DataField & “” & vbCrLf & _

Isi field : ” & dtpTglLahir.Value & “” & vbCrLf & _

– Kolom ke : 6 di tabel.”

cmdFindFirst.Enabled = False

frmInfo.cmdFindFirst.Enabled = False

Print #1, frmInfo.Text1.Text

Close #1

Open FileName For Input As #1

frmInfo.Text1.Text = Input(LOF(1), 1)

frmInfo.Text1.SelStart = Len(frmInfo.Text1.Text) + 1

Close #1

frmInfo.Show

SendKeys “{Home}+{End}”

Exit Sub

End If

Next n

adoPrimaryRS.Recordset.MoveNext

GoTo Ulang

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

adoPrimaryRS.Recordset.Close

adoPrimaryRS.ConnectionString = “” ‘Bersihkan memori

adoPrimaryRS.RecordSource = “” ‘Bersihkan memori

End

End Sub

Private Sub Form_Unload(Cancel As Integer)

Screen.MousePointer = vbDefault

End Sub

‘Private Sub adoPrimaryRS_Error(ByVal ErrorNumber As Long, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)

‘Untuk penanganan error di ADODC

‘Jika ingin menghindarinya, tutup coding di bawah (MsgBox)

‘menjadi komentar…

‘MsgBox “error loh masData error event hit err:” & Description

‘End Sub

Private Sub adoPrimaryRS_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)

‘POSISi record yang aktIf

Dim posisi, total, hasil As String

posisi = adoPrimaryRS.Recordset.AbsolutePosition

total = adoPrimaryRS.Recordset.RecordCount

hasil = “ Record: ” & CStr(posisi) & ” dari ” & CStr(total)

adoPrimaryRS.Caption = hasil

End Sub

Private Sub adoPrimaryRS_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)

‘Untuk validasi coding di prosedur ybt

Dim bCancel As Boolean

Select Case adReason

Case adRsnAddNew

Case adRsnClose

Case adRsnDelete

Case adRsnFirstChange

Case adRsnMove

Case adRsnRequery

Case adRsnResynch

Case adRsnUndoAddNew

Case adRsnUndoDelete

Case adRsnUndoUpdate

Case adRsnUpdate

End Select

If bCancel Then adStatus = adStatusCancel

End Sub

Private Sub cmdAdd_Click()

On Error GoTo AddErr

BukaKunci ‘Buka kunci entrian terlebih dulu…

SetButtons False

adoPrimaryRS.Recordset.AddNew

cbJenis_Kelamin.Text = “”

cbKelas.Text = “”

dtpTglLahir.Value = #11/11/1987# ‘anda bisa ganti defaultnya, soalnya tanggal ini….

EnablePicture picUtility, False

EnablePicture picStatBox, False

txtFields(0).SetFocus

Exit Sub

AddErr:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdDelete_Click()

On Error GoTo DeleteErr

If MsgBox(“Yakin record ini mau dihapus”, _

vbQuestion + vbYesNo, “Hapus Record”) _

<> vbYes Then

Exit Sub

End If

Call hapus

With adoPrimaryRS.Recordset

.Delete

.MoveNext

If .EOF Then .MoveLast

End With

Exit Sub

DeleteErr:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdRefresh_Click()

‘Dibutuhkan untuk aplikasi multi user

On Error GoTo RefreshErr

adoPrimaryRS.Refresh

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

If StatusFilter = True Then

StatusFilter = False

cmdUnFilter_Click

End If

If StatusSortASC = True Or _

StatusSortDESC = True Then

StatusSortASC = False

StatusSortDESC = False

AmbilData

SetButtons True

Kunci

grdDataGrid.Enabled = True

Exit Sub

End If

Call IsiTextFields

Exit Sub

RefreshErr:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdUpdate_Click()

Dim cFileFoto As String

Dim namafoto As String

Dim jawab As Integer

On Error GoTo UpdateErr

If Len(txtFields(0).Text) = 0 Then

MsgBox “NIS masih kosong”, vbInformation, “Invalid Data”

txtFields(0).SetFocus

Exit Sub

ElseIf IsNumeric(txtFields(0).Text) = False Then

MsgBox “NIS harus diisi dengan angka dan tidak menggunakan spasi”, vbInformation, “Invalid Data”

txtFields(0).Text = “”

txtFields(0).SetFocus

Exit Sub

ElseIf Len(txtFields(1).Text) = 0 Then

MsgBox “Nama masih kosong”, vbInformation, “Invalid Data”

txtFields(1).SetFocus

Exit Sub

ElseIf IsNumeric(txtFields(1).Text) = True Then

MsgBox “Nama tidak boleh diisi dengan angka”, vbInformation, “Invalid Data”

txtFields(1).Text = “”

txtFields(1).SetFocus

Exit Sub

ElseIf Len(txtFields(2).Text) = 0 Then

MsgBox “Tempat lahir masih kosong”, vbInformation, “Invalid Data”

txtFields(2).SetFocus

Exit Sub

ElseIf IsNumeric(txtFields(2).Text) = True Then

MsgBox “Tempat lahir tidak boleh diisi dengan angka”, vbInformation, “Invalid Data”

txtFields(2).Text = “”

txtFields(2).SetFocus

Exit Sub

ElseIf Len(txtFields(3).Text) = 0 Then

MsgBox “Organisasi_Ekstra masih kosong”, vbInformation, “Invalid Data”

txtFields(3).SetFocus

Exit Sub

ElseIf Len(txtFields(4).Text) = 0 Then

MsgBox “Alamat Makassar masih kosong”, vbInformation, “Invalid Data”

txtFields(4).SetFocus

Exit Sub

ElseIf Len(txtFields(5).Text) = 0 Then

MsgBox “Nomor Telepon atau Hp masih kosong”, vbInformation, “Invalid Data”

txtFields(5).SetFocus

Exit Sub

ElseIf Len(txtFields(6).Text) = 0 Then

MsgBox “Email masih kosong” & Chr(13) & “Jika tidak memiliki Email, isikan dengan garis datar”, vbInformation, “Invalid Data”

txtFields(6).SetFocus

Exit Sub

ElseIf Len(txtFields(7).Text) = 0 Then

MsgBox “Home Page masih kosong” & Chr(13) & “Jika tidak memiliki Home Page, isikan dengan garis datar”, vbInformation, “Invalid Data”

txtFields(7).SetFocus

Exit Sub

ElseIf Len(txtFields(8).Text) = 0 Then

MsgBox “Catatan masih kosong”, vbInformation, “Invalid Data”

txtFields(9).SetFocus

Exit Sub

Else

End If

Call kopi

namafoto = txtFields(0).Text

cFileFoto = App.Path & “\Components\” & namafoto & “.res”

If Dir(cFileFoto) = “” Then

jawab = MsgBox(“Anda belum memasukkan foto untuk record ini ” & Chr(13) & _

“Apakah Anda ingin memasukkannya?”, _

vbQuestion + vbYesNo, “Masukkan Foto”)

If jawab = vbYes Then

SetButtons False

Call cmdEdit_Foto_Click

Exit Sub

End If

End If

adoPrimaryRS.Recordset.UpdateBatch adAffectAll

EnablePicture picUtility, True

EnablePicture picStatBox, True

SetButtons True

Kunci

Call kopi

grdDataGrid.Enabled = True

Exit Sub

UpdateErr:

Select Case Err.Number

Case -2147467259

MsgBox “NIS yang Anda masukkan telah ada.” & Chr(13) & _

“Silahkan ganti dengan yang lain!”, vbCritical, “Duplikasi NIS”

txtFields(0).SetFocus

SendKeys “{Home}+{End}”

Case -2147217887

MsgBox “Pengisian Data masih terdapat kesalahan.” & vbCrLf & _

“Silahkan periksa kembali”, vbCritical, _

“Peringatan”

Case 3021

adoPrimaryRS.Recordset.AddNew

MsgBox “Database telah kosong!”, vbOKOnly + vbCritical, “Kosong”

Case 3167

MsgBox “Data telah dihapus user lain.” & vbCrLf & _

vbOKOnly & vbInformation, “Telah Dihapus”

Case 3197

MsgBox “Data telah diubah oleh user lain.” & vbCrLf & _

“Proses edit terakhir dibatalkan.”, _

vbOKOnly + vbExclamation, “Telah Diubah”

Case 3260

MsgBox “Data Sedang diedit oleh user lain.” & vbCrLf & _

“Cobalah beberapa saat lagi!”, _

vbOKOnly + vbExclamation, “Sedang Diedit”

Case 3315

MsgBox “Ada field yang belum diisi.”, vbInformation, “Invalid Data”

Case 424

MsgBox “Objek tidak sesuai.”, vbCritical, “Peringatan”

Case Else

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Select

End Sub

Private Sub cmdLogOut_Click()

Unload Me

frmLogin.Show

End

End Sub

Private Sub Timer1_Timer()

lbltgl.Caption = Now

End Sub

Private Sub txtFields_Change(Index As Integer)

If Index = 0 Then

Call Gerak

End If

End Sub

‘agar ketika ditekan enter dapat pindah…

Private Sub txtFields_KeyPress(Index As Integer, KeyAscii As Integer)

Select Case Index

Case 0 To 8

If KeyAscii = 13 Then SendKeys “{Tab}”

End Select

End Sub

Private Sub cmdEdit_Foto_Click()

On Error Resume Next

dlg1.ShowOpen

If dlg1.FileName <> “” Then

imgFoto.Picture = LoadPicture(dlg1.FileName)

lblPesan.Visible = False

End If

End Sub

‘====================fungsi-fungsi==========================

‘—fungsi tampilkan foto

Sub Gerak()

On Error Resume Next

Dim cFileFoto As String

Dim namafoto As String

namafoto = txtFields(0).Text

cFileFoto = App.Path & “\Components\” & namafoto & “.res”

If Dir(cFileFoto) <> “” Then

lblPesan.Visible = False

imgFoto.Picture = LoadPicture(cFileFoto)

If namafoto = “0319620” Then ‘khusus untuk NIS saya akan muncul tampilan yang lain daripada yang lain

lblas.Visible = True

lbltgl.Visible = False

Else:

lblas.Visible = False

lbltgl.Visible = True

End If

Else

imgFoto.Picture = LoadPicture(App.Path & “\Components\empty.res”)

lblPesan.Visible = True

lblPesan.Caption = “FOTO BELUM ADA”

lblas.Visible = False

lbltgl.Visible = True

End If

End Sub

‘you now lah

Public Sub EnablePicture(InFrame As PictureBox, _

ByVal Flag As Boolean)

If grup = “Programer” Or grup = “Administrator” Or grup = “Operator” Then

‘Untuk mengaktIfkan/menon-aktIfkan control dalam

‘satu picture/frame tertentu secara menyeluruh…

Dim Contrl As Control

On Error Resume Next ‘Jika error, lanjutkan saja

InFrame.Enabled = Flag

‘Utk setiap control yg ada di dalam picture/frame ybt

For Each Contrl In InFrame.Parent.Controls

If (Contrl.Container.Name = InFrame.Name) Then

If (TypeOf Contrl Is Frame) And Not _

(Contrl.Name = InFrame.Name) Then

EnablePicture Contrl, Flag

Else

If Not (TypeOf Contrl Is Menu) Then _

Contrl.Enabled = Flag

End If

End If

Next

‘Else: MsgBox “guest”

End If

End Sub

‘—fungsi enable\disable button

Private Sub SetButtons(bVal As Boolean)

If grup = “Programer” Or grup = “Administrator” Or grup = “Operator” Then

cmdAdd.Enabled = bVal

cmdEdit.Enabled = bVal

cmdUpdate.Enabled = Not bVal

cmdCancel.Enabled = Not bVal

cmdEdit_Foto.Enabled = Not bVal

cmdDelete.Enabled = bVal

cmdExit.Enabled = bVal

cmdLogin.Enabled = bVal

cmdRefresh.Enabled = bVal

Else

cmdAdd.Enabled = Not bVal

cmdEdit.Enabled = Not bVal

cmdUpdate.Enabled = Not bVal

cmdCancel.Enabled = Not bVal

cmdEdit_Foto.Enabled = Not bVal

cmdDelete.Enabled = Not bVal

cmdExit.Enabled = bVal

cmdLogin.Enabled = bVal

cmdRefresh.Enabled = bVal

End If

End Sub

‘—fungsi disable text file

Sub Kunci()

Dim i As Integer

For i = 0 To 8

txtFields(i).Locked = True

Next i

cbJenis_Kelamin.Locked = True

cbKelas.Locked = True

dtpTglLahir.Enabled = False

grdDataGrid.Enabled = False

End Sub

‘—fungsi enable text file

Sub BukaKunci()

Dim i As Integer

For i = 0 To 8

txtFields(i).Locked = False

Next i

cbJenis_Kelamin.Locked = False

cbKelas.Locked = False

dtpTglLahir.Enabled = True

grdDataGrid.Enabled = True

End Sub

‘—fungsi ambil data dari akses

Sub AmbilData()

On Error GoTo ExclusIf

adoPrimaryRS.ConnectionString = “PROVIDER=MSDataShape;” & _

“Data PROVIDER=Microsoft.Jet.OLEDB.3.51;” & _

“Data Source=” & App.Path & “\Resources.dat”

adoPrimaryRS.CommandType = adCmdUnknown

adoPrimaryRS.RecordSource = “SHAPE {select * from SISWA_SMADA Order by NIS} ” & _

“AS ParentCMD APPEND ” & _

“({select * from SISWA_SMADA Order by NIS } ” & _

“AS ChildCMD RELATE NIS TO NIS) AS ChildCMD”

adoPrimaryRS.Refresh

Exit Sub

ExclusIf:

Select Case Err.Number

Case -2147467259

MsgBox “Maaf,Database sedang sibuk” & vbCrLf & _

“Silahkan tutup,Refresh, kemudian jalankan kembali”, vbInformation, “Peringatan”

End

Case 3045, 3356

If MsgBox(“Database sedang digunakan user” & vbCrLf & _

“lain secara Exclusive”, _

vbRetryCancel + vbCritical, “Warning”) _

= vbRetry Then

Resume

Else

Unload Me

End If

Case Else

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Select

End Sub

‘—fungsi mengisi textfile dari datagrid

Sub IsiTextFields()

Dim oTextData As TextBox

For Each oTextData In Me.txtFields

Set oTextData.DataSource = adoPrimaryRS.Recordset

Next

Set Me.cbJenis_Kelamin.DataSource = adoPrimaryRS.Recordset

Set Me.cbKelas.DataSource = adoPrimaryRS.Recordset

Set Me.dtpTglLahir.DataSource = adoPrimaryRS.Recordset

End Sub

‘—fungsi untuk mengopi foto

Private Sub kopi()

Dim P1 As Long

Dim poto As String

poto = App.Path & “\Components\” & txtFields(0).Text & “.res”

P1 = CopyFile(Trim$(dlg1.FileName), Trim(poto), False)

dlg1.FileName = “”

poto = “”

End Sub

‘—fungsi untuk menghapus foto ketika record di delete

Private Sub hapus()

Dim P1 As Long

Dim poto As String

poto = App.Path & “\Components\” & txtFields(0).Text & “.res”

P1 = DeleteFile(poto)

poto = “”

End Sub

‘—style tombol

Sub UbahWarnaTombol(nmTbl As String)

namaTombol = nmTbl

For Each Ctl In Me.Controls

With Ctl

If TypeOf Ctl Is CommandButton Then

If .Name <> namaTombol Then

.BackColor = &HE29B81

Else

.BackColor = &HFF&

End If

End If

End With

Next

End Sub

Private Sub cmdAbout_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdAbout”)

End Sub

Private Sub cmdAdd_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdAdd”)

End Sub

Private Sub cmdCancel_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdCancel”)

End Sub

Private Sub cmdClearSearch_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdClearSearch”)

End Sub

Private Sub cmdExit_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdExit”)

End Sub

Private Sub cmdFilter_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdFilter”)

End Sub

Private Sub cmdFindFirst_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdFindFirst”)

End Sub

Private Sub cmdFindNext_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdFindNext”)

End Sub

Private Sub cmdEdit_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdEdit”)

End Sub

Private Sub cmdPetunjuk_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdPetunjuk”)

End Sub

Private Sub cmdRefresh_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdRefresh”)

End Sub

Private Sub cmdSortASC_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdSortASC”)

End Sub

Private Sub cmdSortDESC_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdSortDESC”)

End Sub

Private Sub cmdUnFilter_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdUnFilter”)

End Sub

Private Sub cmdUpdate_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdUpdate”)

End Sub

Private Sub cmdView_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdView”)

End Sub

Private Sub cmdDelete_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdDelete”)

End Sub

Private Sub cmdLogin_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdLogin”)

End Sub

‘====================| frmPetunjuk

Private Sub Command1_Click()

Unload Me

End Sub

‘====================| frmSplash |====================

Private Sub Form_Load()

cmp = App.Path & “\Components\”

‘On Error Resume Next

If Dir(cmp, vbDirectory) = “” Then

MkDir cmp

End If

‘menutup form sama saja dengan fungsi Win+D

Call keybd_event(VK_LWIN, 0, 0, 0)

Call keybd_event(&H4D, 0, 0, 0)

Call keybd_event(VK_LWIN, 0, KEYEVENTF_KEYUP, 0)

‘form menangan/ tampil paling atas

Dim NN As New clsfrmtop

NN.NoTopForm Me.hwnd

‘————-

Me.MousePointer = vbHourglass

Timer1.Interval = 1000

With ProgressBar1

.Height = (Label1.Height) / 2

.Min = 0

.Max = 8

End With

End Sub

Private Sub Timer1_Timer()

Static a As Integer

a = a + 1

ProgressBar1.Value = a

‘Exit Sub

End Sub

‘====================| frmLogin |====================

Dim Hitung As Integer

Private Sub cmdCancel_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

cmdCancel.BackColor = &HFF&

cmdLogin.BackColor = &HE29B81

End Sub

Private Sub cmdLogin_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

cmdCancel.BackColor = &HE29B81

cmdLogin.BackColor = &HFF&

End Sub

Private Sub Form_Load()

‘pernah_login = False

With datLogin

.DatabaseName = App.Path & “\Resources.dat”

.RecordSource = “LOGIN”

‘.Refresh

End With

frmMain.Show

End Sub

Private Sub cmdCancel_Click()

If pernah_login = False Then

frmMain.bangkit

End If

Unload Me

End Sub

Private Sub cmdLogin_Click()

Dim user_name, user_id, usercode, Password, loggedUser As String

Dim ada, jawab As Integer

ada = False

If txtPassword.Text = “” And txtUserName.Text = “” Then

jawab = MsgBox(“Jika Anda tidak mengisi User Name dan Password,” & Chr(13) & “Berarti Anda login sebagai Guest” & Chr(13) & “Apakah Anda ingin login sebagai Guest?”, vbQuestion + vbYesNo, “Login”)

If jawab = vbYes Then

grup = “Guest”

Call selesai

Exit Sub

Else: Exit Sub

End If

ElseIf Len(txtUserName.Text) = 0 Then

MsgBox “User Name masih kosong”, vbInformation, “Login”

txtUserName.SetFocus

Exit Sub

ElseIf Len(txtPassword.Text) = 0 Then

MsgBox “Password masih kosong”, vbInformation, “Login”

txtUserName.SetFocus

Exit Sub

End If

‘search UserName To see If it exists

datLogin.Recordset.MoveFirst

usercode = datLogin.Recordset.Fields(“UserName”).Value

Do Until ada Or datLogin.Recordset.EOF

usercode = datLogin.Recordset.Fields(“UserName”).Value

If usercode = txtUserName.Text Then

ada = True

user_id = usercode

‘MsgBox user_id

Exit Do

Else

datLogin.Recordset.MoveNext

End If

Loop

If ada Then

‘check password If ada

Password = datLogin.Recordset.Fields(“Password”).Value

grup = datLogin.Recordset.Fields(“Group”).Value

If Password = txtPassword.Text Then

Call selesai

Else

Hitung = Hitung + 1

MsgBox “Password yang Anda masukkan salah”, vbExclamation, “Login”

txtPassword.SetFocus

SendKeys “{Home}+{End}”

If Hitung >= 3 Then

Unload Me

frmMain.lblstatus = “Login Gagal”

Hitung = 0

End If

End If

Else:

Hitung = Hitung + 1

MsgBox “User Name yang Anda masukkan salah”, vbExclamation, “Login”

txtUserName.SetFocus

SendKeys “{Home}+{End}”

If Hitung >= 3 Then

Unload Me

frmMain.lblstatus = “Login Gagal”

Hitung = 0

End If

End If

End Sub

Sub selesai()

pernah_login = True

login_sukses = True

datLogin.Recordset.Close

Unload Me

frmMain.bangkit

End Sub

‘====================| frminfo |====================

Coding untuk membantu pencarian data dan

menampilkan hasilnya dalam bentuk dokumen

sederhana dan file teks

Sub UbahWarnaTombol(nmTbl As String)

namaTombol = nmTbl

For Each Ctl In Me.Controls

With Ctl

If TypeOf Ctl Is CommandButton Then

If .Name <> namaTombol Then

.BackColor = &HE29B81

Else

.BackColor = &HFF&

End If

End If

End With

Next

End Sub

Private Sub cmdSimpan_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdSimpan”)

End Sub

Private Sub cmdClearSearch_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdClearSearch”)

End Sub

Private Sub cmdFindFirst_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdFindFirst”)

End Sub

Private Sub cmdFindNext_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdFindNext”)

End Sub

Private Sub cmdOK_MouseMove(Button As Integer, ShIft As Integer, X As Single, Y As Single)

UbahWarnaTombol (“cmdOK”)

End Sub

Private Sub cmdClearSearch_Click()

‘tombol cmdClearSearch di frmMain diklik…

frmMain.cmdClearSearch.Value = True

End Sub

Private Sub cmdFindFirst_Click()

‘tombol FindFirst di frmMain diklik…

frmMain.cmdFindFirst.Value = True

End Sub

Private Sub cmdFindNext_Click()

‘tombol FindNext di frmMain diklik…

frmMain.cmdFindNext.Value = True

End Sub

Private Sub cmdOK_Click()

Me.Hide

End Sub

Private Sub cmdSimpan_Click()

On Error GoTo Batal ‘Jika batal menyimpan file pergi ke Batal

If Text1.Text <> “” Then

With Dialog

.DialogTitle = “Simpan sebagai file teks”

.Filter = “Text File (*.txt)|*.txt” ‘Hanya file txt yg bisa disimpan

.FileName = “HasilCari”

.ShowSave ‘Tampilkan kotak dialog simpan file

Open .FileName For Output As #1 ‘Simpan ke file

Print #1, Text1.Text

Close #1 ‘Tutup file

End With: Exit Sub

Else

MsgBox “Belum ada hasil pencarian!”, vbCritical, “Kosong”

Exit Sub

End If

Batal: ‘Label jika batal menyimpan

Exit Sub ‘Langsung keluar dari prosedur ini

End Sub

‘====================| frmhelp |====================

Private Sub Form_Click()

Unload Me

Main.Show

End Sub

Private Sub Frame1_Click()

Unload Me

Main.Show

End Sub

Private Sub Frame2_Click()

Unload Me

Main.Show

End Sub

Private Sub Label1_Click()

Unload Me

Main.Show

End Sub

Private Sub Label2_Click()

Unload Me

Main.Show

End Sub

‘=====================================================| CUT HERE

Cukup sudah penderitaan kita, saya pikir saudara tidak membaca listing program ini dari awal sampai akhir. Ya kita berenti sejenak, kita minum dulu puyer cap 19 yang kita beli tadi. Setelah itu tekan {Win+D} buka {start} {All Program} kemudian cari yang ada kata GAMES, itu yang kita butuhkan sekarang sebagai penghilang stress. -Saya tidak sarankan anda tekan tombol POWER lho..J.

Setelah kita baca kode diatas, ada beberapa hal yang kita dapatkan

1. Database

Kita menggunakan Microsoft Access sebagai penampung data siswa, hanya kita manipulasi file tersebut(yang seharusnya berekstensi [.mdb]) mejadi fie dat yang biasanya diputar di windows media player. Hanya sayang file database tersebut belum kita proteksi dengan password. Sorry kawan, saya belum dapatkan ilmu itu, nantilah kita sempurnakan. Ini kan baru versi satunya.

2. Level pengguna.

Terdapat beberapa level pengguna, antara lain Guest,User,Operator, dan Administrator. Ada satu pengguna yang tidak kita ekspos karena itu milik kita yaitu Programer. Inilah level tertinggi yang berhak melakukan apa saja. Terserah kita, kan kita yang bikin programnya. Siapa tahu nantinya ada admin yang nakal. Kalau levelnya hanya sampai ke admin, berarti kita sama dengan mereka, jadi kita tidak dapat berbuat apa-apa.

Entah pembagian level ini sesuai aturan atau tidak, atau mungkin hanya boros-boros pengguna (seperti Guest dan User), tapi tidak mengapa, hal ini disesuaikan saja dengan kebutuhan. Benar begitu kan…

3. File Foto

Agar privasi siswa terjaga, kita melakukan manipulasi terhadap file foto mereka. Yang semula file gembar dengan ekstensi JPG menjadi file berekstensi [res]. Yang jelas program database ini menganggap file tersebut adalah file picture, apapun ekstensinya, bahkan tidak berekstensi sekalipun.

# PROYEK DATABASE SMADA BAGIAN III#

ADMINISTRATIF TOOLS

Pada bagian sebelumnya, kita telah membahas mengenai Master database walaupun hanya sebatas listing program dan komentar-komentar singkat yang dianggap perlu. Bagian ini pun tak kalah pentingnya, karena administratif tools merupakan komponen database smada yang mengatur manajemen pengguna. Bayangkan jika setiap orang memiliki hak yang sama dalam menggunakan DATABASE SMADA ini, kan repot jadinya. Bisa saja ada pengguna dengan usil menghapus satu record mahasiswa (karena benci misalnya), atau ada siswa yang ngerjai temannya dengan merubah fotonya menjadi foto Mr. Bean.(ndak jadi masalah kalau dia nerima… J ).

Mari kita mulai, karena saudara berbaik hati turut membaca artikel ini saya akan hadahkan kepada saudara kopi susu panas, nanti saya kirim lewat email (janji batal klo yahoo nolak L)0. Atau kalau ndak mau repot download saja di warung sebelah. He..he..he….

Berikut ini listing adminstratif tools.

================================ADMINISTRATIF TOOLS

‘====================| module1 |====================

Public grup, ID, PWD As String

Public Declare Function CopyFile Lib “kernel32” Alias “CopyFileA” (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long

Public Declare Function RegOpenKeyEx Lib “advapi32.dll” Alias “RegOpenKeyExA” (ByVal Hkey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long

Public Declare Function RegCloseKey Lib “advapi32.dll” (ByVal Hkey As Long) As Long

Public Declare Function RegSetValueEx Lib “advapi32.dll” Alias “RegSetValueExA” (ByVal Hkey As Long, ByVal lpValueName As String, ByVal Reserved As Long, ByVal dwType As Long, lpData As Any, ByVal cbData As Long) As Long

Public Declare Function RegDeleteValue Lib “advapi32.dll” Alias “RegDeleteValueA” (ByVal Hkey As Long, ByVal lpValueName As String) As Long

Public Const HKEY_CURRENT_USER = &H80000001

Public Const HKEY_LOCAL_MACHINE = &H80000002

Public Const KEY_WRITE = &H20006

Public Const REG_SZ = 1

Option Explicit

Private Const MAX_PATH As Long = 260

Private Const BIF_RETURNONLYFSDIRS As Long = 1

Private Type BrowseInfo

hWndOwner As Long

pIDLRoot As Long

pszDisplayName As Long

lpszTitle As Long

ulFlags As Long

lpfnCallback As Long

lParam As Long

iImage As Long

End Type

Private Declare Sub CoTaskMemFree Lib “ole32.dll” ( _

ByVal hMem As Long)

Private Declare Function SHBrowseForFolder Lib “shell32” ( _

lpbi As BrowseInfo) _

As Long

Private Declare Function SHGetPathFromIDList Lib “shell32” ( _

ByVal pidList As Long, _

ByVal lpBuffer As String) _

As Long

Private Declare Function lstrcat Lib “kernel32” Alias “lstrcatA” ( _

ByVal lpString1 As String, _

ByVal lpString2 As String) _

As Long

Public Function BrowseForFolder(hWndOwner As Long, _

sTitle As String) As String

Dim BI As BrowseInfo

Dim iPos As Integer

Dim lpIDList As Long

Dim lResult As Long

Dim sPath As String

With BI

.hWndOwner = hWndOwner

.lpszTitle = lstrcat(sTitle, vbNullChar)

.ulFlags = BIF_RETURNONLYFSDIRS

End With

lpIDList = SHBrowseForFolder(BI)

If lpIDList Then

sPath = String$(MAX_PATH, vbNullChar)

SHGetPathFromIDList lpIDList, sPath

CoTaskMemFree lpIDList

iPos = InStr(sPath, vbNullChar)

If iPos Then sPath = Left$(sPath, iPos – 1)

End If

BrowseForFolder = sPath

End Function

‘====================| frmAboutMe |====================

Private Sub cmdClose_Click()

Unload Me

End Sub

‘====================| frmEditLogin |====================

Sub AmbilData()

On Error GoTo Exclusif

adoPrimaryRS.ConnectionString = “PROVIDER=MSDataShape;” & _

“Data PROVIDER=Microsoft.Jet.OLEDB.3.51;” & _

“Data Source=” & App.Path & “\Resources.dat”

adoPrimaryRS.CommandType = adCmdUnknown

If grup = “Programer” Then

adoPrimaryRS.RecordSource = “SELECT * FROM LOGIN”

adoPrimaryRS.Refresh

Exit Sub

ElseIf grup = “Administrator” Then

adoPrimaryRS.RecordSource = “SELECT * FROM LOGIN WHERE (Group = ‘Operator’OR Group=’User’)”

adoPrimaryRS.Refresh

Exit Sub

ElseIf grup = “Operator” Then

adoPrimaryRS.RecordSource = “SELECT * FROM LOGIN WHERE (Group = ‘User’)”

adoPrimaryRS.Refresh

Exit Sub

End If

Exclusif:

Select Case Err.Number

Case -2147467259

MsgBox “Maaf,Database sedang sibuk” & vbCrLf & _

“Silahkan tutup,Refresh, kemudian jalankan kembali”, vbInformation, “Peringatan”

End

Case 3045, 3356

If MsgBox(“Database sedang digunakan user” & vbCrLf & _

“lain secara Exclusive”, _

vbRetryCancel + vbCritical, “Warning”) _

= vbRetry Then

Resume

Else

Unload Me

End If

Case Else

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Select

End Sub

Private Sub cmdCancel_Click()

On Error GoTo Pesan

adoPrimaryRS.Recordset.Cancel

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

SetButtons True

kunci True

grdDataGrid.Enabled = True

Call IsiTextFields

Exit Sub

Pesan:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdDelete_Click()

On Error GoTo DeleteErr

If MsgBox(“Yakin record ini mau dihapus”, _

vbQuestion + vbYesNo, “Hapus Record”) _

<> vbYes Then

Exit Sub

End If

With adoPrimaryRS.Recordset

.Delete

.MoveNext

If .EOF Then .MoveLast

End With

Exit Sub

DeleteErr:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Private Sub cmdEdit_Click()

kunci False

SetButtons False

Call otoritasnya

txtFields(0).SetFocus

SendKeys “{Home}+{End}”

End Sub

Private Sub cmdExit_Click()

Unload Me

End Sub

Private Sub cmdUpdate_Click()

On Error GoTo UpdateErr

If Len(txtFields(0).Text) = 0 Then

MsgBox “User Name masih kosong”, vbInformation, “Invalid Data”

txtFields(0).SetFocus

Exit Sub

ElseIf Len(txtFields(1).Text) = 0 Then

MsgBox “Password masih kosong”, vbInformation, “Invalid Data”

txtFields(1).SetFocus

Exit Sub

ElseIf Len(txtFields(1).Text) < 5 Then

MsgBox “Password minimal 5 karakter”, vbInformation, “Invalid Data”

txtFields(1).SetFocus

Exit Sub

End If

adoPrimaryRS.Recordset.UpdateBatch adAffectAll

kunci (True)

SetButtons (True)

grdDataGrid.Enabled = True

Exit Sub

UpdateErr:

Select Case Err.Number

Case -2147467259

MsgBox “User Name yang Anda masukkan telah ada.” & Chr(13) & _

“Silahkan ganti dengan yang lain!”, vbCritical, “Duplikasi User Name”

txtFields(0).SetFocus

SendKeys “{Home}+{End}”

Case -2147217887

MsgBox “Pengisian Data masih terdapat kesalahan.” & vbCrLf & _

“Silahkan periksa kembali”, vbCritical, _

“Peringatan”

Case 3021

adoPrimaryRS.Recordset.AddNew

MsgBox “Database telah kosong!”, vbOKOnly + vbCritical, “Kosong”

Case 3167

MsgBox “Data telah dihapus user lain.” & vbCrLf & _

vbOKOnly & vbInformation, “Telah Dihapus”

Case 3197

MsgBox “Data telah diubah oleh user lain.” & vbCrLf & _

“Proses edit terakhir dibatalkan.”, _

vbOKOnly + vbExclamation, “Telah Diubah”

Case 3260

MsgBox “Data Sedang diedit oleh user lain.” & vbCrLf & _

“Cobalah beberapa saat lagi!”, _

vbOKOnly + vbExclamation, “Sedang Diedit”

Case 3315

MsgBox “Ada field yang belum diisi.”, vbInformation, “Invalid Data”

Case 424

MsgBox “Objek tidak sesuai.”, vbCritical, “Peringatan”

Case Else

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Select

End Sub

Private Sub Form_Load()

kunci (True)

SetButtons (True)

AmbilData

Set grdDataGrid.DataSource = adoPrimaryRS.Recordset

Call IsiTextFields

End Sub

Sub IsiTextFields()

Dim oTextData As TextBox

For Each oTextData In Me.txtFields

Set oTextData.DataSource = adoPrimaryRS.Recordset

Next

Set Me.otoritas.DataSource = adoPrimaryRS.Recordset

End Sub

Private Sub cmdAdd_Click()

On Error GoTo AddErr

kunci (False)

SetButtons (False)

adoPrimaryRS.Recordset.AddNew

txtFields(0).SetFocus

Call otoritasnya

Exit Sub

AddErr:

MsgBox Err.Number & vbCrLf & Err.Description & vbCrLf & _

“Hubungi Administrator Anda !”, vbInformation, “Peringatan”

End Sub

Sub otoritasnya()

If grup = “Programer” Then

otoritas.List(0) = “User”

otoritas.List(1) = “Operator”

otoritas.List(2) = “Administrator”

otoritas.Text = “Administrator”

ElseIf grup = “Administrator” Then

otoritas.List(0) = “User”

otoritas.List(1) = “Operator”

otoritas.Text = “Operator”

ElseIf grup = “Operator” Then

otoritas.Locked = True

otoritas.List(0) = “User”

otoritas.Text = “User”

End If

End Sub

Sub kunci(b As Boolean)

txtFields(0).Locked = b

txtFields(1).Locked = b

otoritas.Locked = b

End Sub

Private Sub SetButtons(bVal As Boolean)

cmdAdd.Enabled = bVal

cmdEdit.Enabled = bVal

cmdUpdate.Enabled = Not bVal

cmdCancel.Enabled = Not bVal

cmdDelete.Enabled = bVal

cmdExit.Enabled = bVal

End Sub

‘====================| frmEditYourLogin |====================

Private Sub cmdCancel_Click()

datLogin.Recordset.Close

Unload Me

End Sub

Private Sub cmdSavePass_Click()

If (tNewPassword.Text) = “” Then

MsgBox “Password masih kosong”, vbInformation, “Peringatan”

Else

‘make sure password is 5 characters long

If Len(tNewPassword) >= 5 Then

‘update password in database

With datLogin.Recordset

.MoveFirst

.FindFirst “UserName = ‘” & ID & “‘”

.Edit

.Fields(“Password”).Value = Trim(txtPassword)

.Update

MsgBox “Password Telah diganti”, vbInformation, “Berhasil”

End With

Else

MsgBox “Password minimal 5 karakter”, vbInformation, “Peringatan”

End If

End If

End Sub

Private Sub Form_Load()

datLogin.DatabaseName = App.Path & “\Resources.dat”

datLogin.RecordSource = “LOGIN”

datLogin.Refresh

tUserName.Text = ID

tOldPassword.Text = PWD

tgrup.Text = grup

End Sub

‘====================| frmLogin |====================

Dim Hitung As Integer

‘Private Sub cmdCancel_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)

‘cmdCancel.BackColor = &HFF&

‘cmdLogin.BackColor = &HE29B81

‘End Sub

‘Private Sub cmdLogin_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)

‘cmdCancel.BackColor = &HE29B81

‘cmdLogin.BackColor = &HFF&

‘End Sub

Private Sub Form_Load()

With datLogin

.DatabaseName = App.Path & “\Resources.dat”

.RecordSource = “LOGIN”

End With

End Sub

Private Sub cmdCancel_Click()

Unload Me

End Sub

Private Sub cmdLogin_Click()

Dim user_name, user_id, usercode, Password, loggedUser As String

Dim ada As Integer

ada = False

If txtPassword.Text = “” And txtUserName.Text = “” Then

MsgBox “User Name dan Password harus diisi”, vbInformation, “Login”

Exit Sub

ElseIf Len(txtUserName.Text) = 0 Then

MsgBox “User Name masih kosong”, vbInformation, “Login”

txtUserName.SetFocus

Exit Sub

ElseIf Len(txtPassword.Text) = 0 Then

MsgBox “Password masih kosong”, vbInformation, “Login”

txtUserName.SetFocus

Exit Sub

End If

‘search UserName to see if it exists

datLogin.Recordset.MoveFirst

usercode = datLogin.Recordset.Fields(“UserName”).Value

Do Until ada Or datLogin.Recordset.EOF

usercode = datLogin.Recordset.Fields(“UserName”).Value

If usercode = txtUserName.Text Then

ada = True

Exit Do

Else

datLogin.Recordset.MoveNext

End If

Loop

If ada Then

‘check password if ada

Password = datLogin.Recordset.Fields(“Password”).Value

grup = datLogin.Recordset.Fields(“Group”).Value

If Password = txtPassword.Text Then

If grup = “Programer” Or grup = “Administrator” Or grup = “Operator” Then

Call selesai

Else

MsgBox “Maaf, Anda tidak memiliki hak” & Chr(13) & “untuk menggunakan fasilitas ini”, vbInformation, “Login”

End If

Else

Hitung = Hitung + 1

MsgBox “Password yang Anda masukkan salah”, vbExclamation, “Login”

txtPassword.SetFocus

SendKeys “{Home}+{End}”

If Hitung >= 3 Then

Unload Me

Hitung = 0

End If

End If

Else:

Hitung = Hitung + 1

MsgBox “User Name yang Anda masukkan salah”, vbExclamation, “Login”

txtUserName.SetFocus

SendKeys “{Home}+{End}”

If Hitung >= 3 Then

Unload Me

Hitung = 0

End If

End If

End Sub

Sub selesai()

ID = txtUserName.Text

PWD = txtPassword.Text

datLogin.Recordset.Close

Unload Me

frmMain.Show

End Sub

‘====================| frmMain |====================

Private Sub Form_Load()

sts.Caption = “<Open By : ” & ID & “><Status : ” & grup & “>”

End Sub

Private Sub men_BackUp_Click()

Dim tgl As String

Dim sFolder As String

Dim P As Long

Dim a1, a2, t4 As String

On Error Resume Next

sFolder = BrowseForFolder(Me.hWnd, “Silahkan pilih folder tempat BackUp Database”)

If sFolder <> “” Then

tgl = “BackUp_” & Day(Now) & Month(Now) & Year(Now)

t4 = sFolder & “\” & tgl & “\”

gua = App.Path & “\BackUp.bat”

a1 = App.Path & “\Components\*.res”

a2 = App.Path & “\Resources.dat”

tls = Chr(32) & Chr(34) & a1 & Chr(34) & Chr(32) & Chr(34) & t4 & Chr(34)

If Dir(t4, vbDirectory) = “” Then

MkDir (t4)

End If

Open gua For Output As #1

Print #1, “Copy”; tls

Close #1

Shell gua, vbHide

P = CopyFile(Trim$(a2), Trim(t4 & “Resources.dat”), False)

MsgBox “Database SMADAtelah di BackUp”, vbInformation, “Berhasil”

End If

Kill gua

End Sub

Private Sub men_rb_Click()

Dim tgl As String

Dim sFolder As String

Dim P As Long

Dim a1, a2, t4, tls As String

‘On Error Resume Next

sFolder = BrowseForFolder(Me.hWnd, “Silahkan pilih folder BackUp Database yang akan di kembalikan”)

If sFolder <> “” Then

If Dir(sFolder & “\Resources.dat”, vbNormal) <> “” Then

t4 = sFolder & “\*.res”

a1 = App.Path & “\Components\”

a2 = App.Path & “\Resources.dat”

tls = Chr(32) & Chr(34) & t4 & Chr(34) & Chr(32) & Chr(34) & a1 & Chr(34)

lu = App.Path & “\Restore.bat”

Open lu For Output As #1

Print #1, “Copy”; tls

Close #1

Kill App.Path & “\Components\*.*”

Shell lu, vbHide

P = CopyFile(Trim$(sFolder & “\Resources.dat”), Trim(a2), False)

MsgBox “Database SMADAtelah di Restore”, vbInformation, “Berhasil”

Kill lu

Else

MsgBox “Folder tersebut bukan Folder BackUp Database”, vbInformation, “Restore Database”

End If

End If

End Sub

Private Sub men_foto_Click()

dlg1.ShowOpen

If dlg1.FileName <> “” Then

Dim p1 As Long

Dim poto As String

poto = App.Path & “\Components\Empty.res”

p1 = CopyFile(Trim$(dlg1.FileName), Trim(poto), False)

MsgBox “Foto Empty telah diganti”, vbInformation, “Berhasil”

End If

End Sub

Private Sub men_about_Click()

frmAboutMe.Show (1)

End Sub

Private Sub men_edit_your_Click()

frmEditYourLogin.Show (1)

End Sub

Private Sub men_el_Click()

frmEditLogin.Show (1)

End Sub

Private Sub men_exit_Click()

End

End Sub

Private Sub men_open_tp_Click()

Unload Me

frmLogin.Show

End Sub

Private Sub men_start_Click()

Dim hregkey As Long

Dim subkey As String

Dim stringbuffer As String

subkey = “SOFTWARE\Microsoft\Windows\CurrentVersion\Run”

retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, subkey, 0, KEY_WRITE, hregkey)

If retval <> 0 Then

retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, KEY_WRITE, hregkey)

End If

stringbuffer = App.Path & “\Database TekPend.exe” & vbNullChar

retval = RegSetValueEx(hregkey, “Database TekPend”, 0, REG_SZ, ByVal stringbuffer, Len(stringbuffer))

RegCloseKey hregkey

MsgBox “Start Up Database SMADAtelah diset”, vbInformation, “Berhasil”

End Sub

Private Sub men_del_Click()

Dim hregkey As Long

Dim subkey As String

Dim stringbuffer As String

subkey = “SOFTWARE\Microsoft\Windows\CurrentVersion\Run”

retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, subkey, 0, KEY_WRITE, hregkey)

If retval <> 0 Then

retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, KEY_WRITE, hregkey)

End If

stringbuffer = App.Path & “\Database TekPend.exe” & vbNullChar

retval = RegDeleteValue(hregkey, “Database TekPend”)

RegCloseKey hregkey

MsgBox “Start Up Database SMADAtelah dihapus”, vbInformation, “Berhasil”

End Sub

Private Sub men_Update_Click()

If grup <> “Programer” Then

MsgBox “Status Anda sebagai ” & grup & Chr(13) & “tidak dapat menggunakan fasilitas ini” & Chr(13) & “Release 11 November 2006” & Chr(13) & “Last Update 11 November 2006”, vbInformation

Else

MsgBox “Info” & Chr(13) & “Release 11 November 2006” & Chr(13) & “Last Update 11 November 2006”, vbInformation

End If

End Sub

Private Sub showdesktop_Click()

Dim hregkey As Long

Dim subkey As String

Dim stringbuffer As String

subkey = “SOFTWARE\Microsoft\Windows\CurrentVersion\Run”

retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, subkey, 0, KEY_WRITE, hregkey)

If retval <> 0 Then

retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, KEY_WRITE, hregkey)

End If

stringbuffer = App.Path & “\Show Desktop.exe” & vbNullChar

retval = RegSetValueEx(hregkey, “Show Desktop”, 0, REG_SZ, ByVal stringbuffer, Len(stringbuffer))

RegCloseKey hregkey

MsgBox “Tampilan Show Database SMADA telah diset”, vbInformation, “Berhasil”

End Sub

Private Sub hidedesktop_Click()

Dim hregkey As Long

Dim subkey As String

Dim stringbuffer As String

subkey = “SOFTWARE\Microsoft\Windows\CurrentVersion\Run”

retval = RegOpenKeyEx(HKEY_LOCAL_MACHINE, subkey, 0, KEY_WRITE, hregkey)

If retval <> 0 Then

retval = RegOpenKeyEx(HKEY_CURRENT_USER, subkey, 0, KEY_WRITE, hregkey)

End If

stringbuffer = App.Path & “\Show Desktop.exe” & vbNullChar

retval = RegDeleteValue(hregkey, “Show Desktop”)

RegCloseKey hregkey

MsgBox “Tampilan Show Database SMADA telah dihapus”, vbInformation, “Berhasil”

End Sub

‘===================================================CUT HERE

Harap dimaklumi, listing diatas tidak saya warnai soalnya lagi malas, harap maklum sifa itu kadang muncul. Ada saran tidak untuk menghilangkannya.

Selain manajemen pengguna, andministratif tools juga berfungsi untuk mengeset fasilitas start up yang bernama Show Desktop.exe. saya lupa menjelaskannya pada bagian sebelum-sebelumnya. Bagian itu nanti kita akan bahas khusus pada artikel ke 4.

# PROYEK DATABASE SMADA BAGIAN IV #

SHOW DESKTOP

Sesuai janji saya pada artikel sebelumnya, sekarang kita akan membahas mengenai salah satu fasiitas database yang kita buat yaitu tampilan form di desktop. Fasilitas tersebut sebenarnya merupakan program terpisah dari Master database dan administratif tools.

Secara sederhana dapat saya jelaskan bahwa aplikasi ini(sebut saja demikian) memerlukan satu file gambar berformat .bmp yang akan kita crop dengan menggunakan kode-kode vb. Gambar yang di crop hanya bagian yang berwarna hitam, untuk itu saya akan menggunakan gambar jamur di malam hari yang menyala. Jika saaudara memiliki gambar lain, ya slahkan saja. Toh saudara kan yang bikin. Tapi saya sarankan saudara memlih gambar yang netral agar sesuai dengan semua background di desktop. Asudara juga harus memilih gambar yang simpel, usahakan bagian hitamnya ada di tepi.

Saya kira gambarannya sudah cukup, sekarang kita melihat kembali listing program Show Desktop ini.

‘====================| module1 |====================

Option Explicit

Public Declare Function GetPixel Lib “gdi32” (ByVal hDC As Long, ByVal X As Long, ByVal Y As Long) As Long

Public Declare Function SetWindowRgn Lib “user32” (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

Public Declare Function CreateRectRgn Lib “gdi32” (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

Public Declare Function CombineRgn Lib “gdi32” (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long

Public Declare Function SendMessage Lib “user32” Alias “SendMessageA” (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Public Declare Function ReleaseCapture Lib “user32” () As Long

Public Declare Function DeleteObject Lib “gdi32” (ByVal hObject As Long) As Long

Public Const RGN_OR = 2

Public Const WM_NCLBUTTONDOWN = &HA1

Public Const HTCAPTION = 2

Public Function MakeRegion(picSkin As PictureBox) As Long

Dim X As Long, Y As Long, StartLineX As Long

Dim FullRegion As Long, LineRegion As Long

Dim TransparentColor As Long

Dim InFirstRegion As Boolean

Dim InLine As Boolean ‘ Flags whether we are in a non-tranparent pixel sequence

Dim hDC As Long

Dim PicWidth As Long

Dim PicHeight As Long

hDC = picSkin.hDC

PicWidth = picSkin.ScaleWidth

PicHeight = picSkin.ScaleHeight

InFirstRegion = True: InLine = False

X = Y = StartLineX = 0

TransparentColor = GetPixel(hDC, 0, 0)

For Y = 0 To PicHeight – 1

For X = 0 To PicWidth – 1

If GetPixel(hDC, X, Y) = TransparentColor Or X = PicWidth Then

‘ We reached a transparent pixel

If InLine Then

InLine = False

LineRegion = CreateRectRgn(StartLineX, Y, X, Y + 1)

If InFirstRegion Then

FullRegion = LineRegion

InFirstRegion = False

Else

CombineRgn FullRegion, FullRegion, LineRegion, RGN_OR

‘ Always clean up your mess

DeleteObject LineRegion

End If

End If

Else

‘ We reached a non-transparent pixel

If Not InLine Then

InLine = True

StartLineX = X

End If

End If

Next

Next

MakeRegion = FullRegion

End Function

‘====================| form1 |====================

Option Explicit

Private Sub Form_Load()

On Error GoTo pesan

Dim WindowRegion As Long

picMainSkin.ScaleMode = vbPixels

picMainSkin.AutoRedraw = True

picMainSkin.AutoSize = True

picMainSkin.BorderStyle = vbBSNone

Me.BorderStyle = vbBSNone

Set picMainSkin.Picture = LoadPicture(App.Path & “\ShowDesktop.bmp”)

Me.Width = picMainSkin.Width

Me.Height = picMainSkin.Height

WindowRegion = MakeRegion(picMainSkin)

SetWindowRgn Me.hWnd, WindowRegion, True

pesan:

Select Case Err.Number

Case 53

MsgBox “Komponent Database tidak tersedia” & Chr(13) & “Silahkan hubungi Administrator Anda”, vbCritical, App.Title

End

Case Else

MsgBox err.Number & Chr(13) & err.Description & Chr(13) & “Silahkan hubungi Programer Anda”, vbCritical, App.Title

End Select

End Sub

Private Sub picMainSkin_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

On Error GoTo pesan

Dim jwb As Integer

jwb = MsgBox(“Apakah Anda akan mengaktifkan” & Chr(13) & “Program Database SMADA”, vbQuestion + vbYesNo, “Show Desktop”)

If jwb = vbYes Then

Shell App.Path & “\Database SMADA.exe”, vbNormalFocus

Exit Sub

Else: Exit Sub

End If

ReleaseCapture

SendMessage Me.hWnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&

pesan:

Select Case Err.Number

Case 53

MsgBox “File Database tidak tersedia” & Chr(13) & “Silahkan hubungi Administrator Anda”, vbCritical, App.Title

Case Else

MsgBox Err.Number & Chr(13) & Err.Description & Chr(13) & “Silahkan hubungi Programer Anda”, vbCritical, App.Title

End Select

End Sub

‘==========================================CUT HERE


Leave a Reply

Fill in your details below or click an icon to log in:

WordPress.com Logo

You are commenting using your WordPress.com account. Log Out / Change )

Twitter picture

You are commenting using your Twitter account. Log Out / Change )

Facebook photo

You are commenting using your Facebook account. Log Out / Change )

Google+ photo

You are commenting using your Google+ account. Log Out / Change )

Connecting to %s

Categories

%d bloggers like this: