Jawaban SOAL 2 (Agus Susanto Hrp)

Kasus : Link kan Kasus nya ke Page ini  Soal QuiZ

Modul.server
Public Db As New ADODB.Connection
Public Rs As New ADODB.Recordset
Public Rs2 As New ADODB.Recordset
Public SQL As String

Sub OPENDB()
If Db.State = adStateOpen Then Db.Close
Db.CursorLocation = adUseClient
Db.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\putra Server\db1.mdb;Persist Security Info=False"
End Sub

Sub clearFORM(f As Form)
Dim ctl As Control
For Each ctl In f
If TypeOf ctl Is TextBox Then ctl.Text = ""
If TypeOf ctl Is ComboBox Then ctl.Text = ""
Next
End Sub
Sub center(f As Form)
f.Move (Screen.Width - f.Width) / 2, (Screen.Height - f.Height) / 4
End Sub
Sub RubahCMD(f As Form, L0 As Boolean, L1 As Boolean, L2 As Boolean, L3 As Boolean)
f.CmdProses(0).Enabled = L0
f.CmdProses(1).Enabled = L1
f.CmdProses(2).Enabled = L2
f.CmdProses(3).Enabled = L3
End Sub
Listing program server
Sub hapus()
Kode.Enabled = True
clearFORM Me
Call RubahCMD(Me, True, False, False, False)
CmdProses(1).Caption = "&Simpan"
End Sub
Sub ProsesDB(Log As Byte)
Select Case Log
Case 0
SQL = "INSERT INTO Barang(Kode, Nama, Harga)" & _
"values('" & Kode.Text & _
"','" & Nama.Text & _
"','" & Harga.Text & "')"
Case 1
SQL = "UPDATE Barang SET Nama='" & Nama.Text & "'," & _
" Harga = '" & Harga.Text & "' " & _
"where Kode ='" & Kode.Text & "'"
Case 2
SQL = "DELETE FROM Barang WHERE Kode='" & Kode.Text & "'"
End Select
MsgBox "Pemorosesan record Database telah Berhasil...!", vbInformation, "Data Barang"
Db.BeginTrans
Db.Execute SQL, adCmdTable
Db.CommitTrans
Call hapus
Adodc1.Refresh
Kode.SetFocus
End Sub
Sub tampilBarang()
On Error Resume Next
Kode.Text = Rs!Kode
Nama.Text = Rs!Nama
Harga.Text = Rs!Harga
End Sub

Private Sub CMDproses_click(index As Integer)
Select Case index
Case 0
Call hapus
Kode.SetFocus
Case 1
If CmdProses(1).Caption = "&Simpan" Then
Call ProsesDB(0)
Else
Call ProsesDB(1)
End If
Case 2
x = MsgBox("Yakin RECORD Barang Akan Dihapus...!", vbQuestion + vbYesNo, "Barang")
If x = vbYes Then ProsesDB 2
Call hapus
Kode.SetFocus
Case 3
Call hapus
Kode.SetFocus
Case 5
Adodc1.Refresh
Case 4
Unload Me
End Select
End Sub


Private Sub Command1_Click()
Adodc1.Refresh
End Sub

Private Sub form_load()
Call OPENDB
Call hapus
MulaiServer
End Sub
Private Sub Kode_keyPress(keyAscii As Integer)
If keyAscii = 13 Then
If Kode.Text = "" Then
MsgBox "Masukkan Kode Barang!", vbInformation, "Barang"
Kode.SetFocus
Exit Sub
End If
SQL = "SELECT * FROM Barang WHERE Kode='" & Kode.Text & "'"
If Rs.State = adStateOpen Then Rs.Close
Rs.Open SQL, Db, adOpenDynamic, adLockBatchOptimistic
If Rs.RecordCount <> 0 Then
tampilBarang
Call RubahCMD(Me, False, True, True, True)
CmdProses(1).Caption = "&Edit"
Kode.Enabled = False
Else
x = Kode.Text
Call hapus
Kode.Text = x
Call RubahCMD(Me, False, True, False, True)
CmdProses(1).Caption = "&Simpan"
End If
Nama.SetFocus
End If
End Sub


Sub MulaiServer()
WS.LocalPort = 1000
WS.Listen
End Sub

Private Sub WS_ConnectionRequest(ByVal requestID As Long)
WS.Close
WS.Accept requestID
Me.Caption = "Server-Client" & WS.RemoteHostIP & "Connect"

End Sub

Private Sub WS_DataArrival(ByVal bytesTotal As Long)
Dim xKirim As String
Dim xData1() As String
Dim xData2() As String

WS.GetData xKirim, vdString, bytesTotal
xData1 = Split(xKirim, "-")

Select Case xData1(0)
Case "SEARCH"
SQL = "SELECT*FROM Barang WHERE Kode='" & xData1(1) & "'"
If Rs.State = adStateOpen Then Rs.Close
Rs.Open SQL, Db, adOpenDynamic, adLockOptimistic
If Rs.RecordCount <> 0 Then
WS.SendData "RECORD-" & Rs!Nama & "/" & Rs!Harga
Else
WS.SendData "NOTHING-xxx"
End If
Case "INSERT"
Db.BeginTrans
Db.Execute xData1(1), adCmdTable
Db.CommitTrans
WS.SendData "INSERT-xxx"
Adodc1.Refresh
Case "UPDATE"
Db.BeginTrans
Db.Execute xData1(1), adCmdTable
Db.CommitTrans
WS.SendData "EDIT-xxx"
Adodc1.Refresh
Case "DELETE"
SQL = "Delete * from Barang " & _
"where Kode='" & xData1(1) & "'"
Db.BeginTrans
Db.Execute SQL, adCmdTable
Db.CommitTrans
Adodc1.Refresh
WS.SendData "DEL-xxx"
End Select
End Sub

Modul client
Public SQL As String

Sub ClearFORM(f As Form)
Dim ctl As Control
For Each ctl In f
If TypeOf ctl Is TextBox Then ctl.Text = ""
If TypeOf ctl Is ComboBox Then ctl.Text = ""
Next
End Sub

Sub center(f As Form)
f.Move (Screen.Width - f.Width) / 2, (Screen.Height - f.Height) / 4
End Sub

Sub RubahCMD(f As Form, L0 As Boolean, L1 As Boolean, L2 As Boolean, L3 As Boolean)
f.CmdProses(0).Enabled = L0
f.CmdProses(1).Enabled = L1
f.CmdProses(2).Enabled = L2
f.CmdProses(3).Enabled = L3
End Sub

Listing program client
Dim IPServer As String

Sub Hapus()
Kode.Enabled = True
ClearFORM Me
Call RubahCMD(Me, True, False, False, False)
CmdProses(1).Caption = "&Simpan"
End Sub

Sub ProsesDB(Log As Byte)
Select Case Log
Case 0
SQL = "INSERT INTO Barang(Kode,Nama,Harga)" & _
"values('" & Kode.Text & _
"','" & Nama.Text & _
"','" & Harga.Text & "')"
Case 1
SQL = "UPDATE Barang SET Nama='" & Nama.Text & "'," & _
"Harga='" & Harga.Text & "'," & _
"where Kode='" & Kode.Text & "'"
Case 2
SQL = "DELETE FROM Barang WHERE Kode='" & Kode.Text & "'"
End Select
MsgBox "Pemprosesan RECORD Database telah berhasil...!", vbInformation, "Barang"
Call Hapus
Kode.SetFocus
End Sub

Private Sub CmdProses_Click(Index As Integer)
Select Case Index
Case 0
Call Hapus
Kode.SetFocus
Case 1
If CmdProses(1).Caption = "&Simpan" Then
SQL = "INSERT INTO Barang(Kode,Nama,Harga)" & _
"values('" & Kode.Text & _
"','" & Nama.Text & _
"','" & Harga.Text & "')"
WS.SendData "INSERT-" & SQL

Else
SQL = "UPDATE barang set " & _
"nama= '" & Nama.Text & _
"',harga='" & Harga.Text & _
"' where kode='" & Kode.Text & "'"
WS.SendData "UPDATE-" & SQL

End If
Case 2
x = MsgBox("Yakin RECORD Barang Akan Dihapus...!", vbQuestion + vbYesNo, "Barang")
If x = vbYes Then
WS.SendData "DELETE-" & Kode.Text

End If
Call Hapus
Kode.SetFocus
Case 3
Call Hapus
Kode.SetFocus
Case 4
Unload Me
End Select
End Sub

Private Sub Form_Load()
Call Hapus
MulaiKoneksi
End Sub
Private Sub Kode_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Kode.Text = "" Then Exit Sub
WS.SendData "SEARCH-" & Kode.Text
End If
End Sub
Sub MulaiKoneksi()
IPServer = "127.0.0.1"
IPClient = WS.LocalIP
WS.Connect IPServer, 1000
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
DoEvents
End
End Sub
Private Sub WS_Dataarrival(ByVal bytesTotal As Long)
Dim xkrim As String
Dim xData1() As String
Dim xData2() As String

WS.GetData xkirim, vbString, bytesTotal
xData1 = Split(xkirim, "-")
Select Case xData1(0)
Case "NOTHING"
x = Kode.Text
Call Hapus
Kode.Text = x
Call RubahCMD(Me, False, True, False, True)
CmdProses(1).Caption = "&Simpan"
Nama.SetFocus
Case "RECORD"
xData2 = Split(xData1(1), "/")
Nama.Text = xData2(0)
Harga.Text = xData2(1)
Call RubahCMD(Me, False, True, True, True)
CmdProses(1).Caption = "&Edit"
Kode.Enabled = False
Nama.SetFocus
Case "DEL"
MsgBox "penghapusan data berhasil !"
Call Hapus
Case "EDIT"
MsgBox "pengeditan record berhasil !"
Call Hapus
End Select
End Sub

Listing Program Server Dosen

Sub hapus()
NIDN.Enabled = True
clearFORM Me
Call RubahCMD(Me, True, False, False, False)
CmdProses(1).Caption = "&Simpan"
End Sub
Sub ProsesDB(Log As Byte)

al,Pendidikan,Bagian,Status)" & _
"values('" & NIDN.Text & _
"','" & NAMA.Text & _
"','" & TEMPAT.Text & _
"','" & TANGGAL.Text & _
"','" & PENDIDIKAN.Text & _
"','" & BAGIAN.Text & _
"','" & STATUS.Text & "')"
Case 1
SQL = "UPDATE Dosen SET Nama='" & NAMA.Text & "'," & _
" Tempat = '" & TEMPAT.Text & "' " & _
" Tanggal = '" & TANGGAL.Text & "' " & _
" Pendidikan = '" & PENDIDIKAN.Text & "' " & _
" Bagian = '" & BAGIAN.Text & "' " & _
" Status = '" & STATUS.Text & "' " & _
"where NIDN ='" & NIDN.Text & "'"
Case 2
SQL = "DELETE FROM Dosen WHERE NIDN='" & NIDN.Text & "'"
End Select
MsgBox "Pemorosesan record Database telah Berhasil...!", vbInformation, "Data Dosen"
Db.BeginTrans
Db.Execute SQL, adCmdTable
Db.CommitTrans
Call hapus
Adodc1.Refresh
NIDN.SetFocus
End Sub
Sub tampilDosen()
On Error Resume Next
NIDN.Text = Rs!NIDN
NAMA.Text = Rs!NAMA
TEMPAT.Text = Rs!TEMPAT
TANGGAL.Text = Rs!TANGGAL
PENDIDIKAN.Text = Rs!PENDIDIKAN
BAGIAN.Text = Rs!BAGIAN
STATUS.Text = Rs!STATUS
End Sub

Private Sub CMDproses_click(index As Integer)
Select Case index
Case 0
Call hapus
NIDN.SetFocus
Case 1
If CmdProses(1).Caption = "&Simpan" Then
Call ProsesDB(0)
Else
Call ProsesDB(1)
End If
Case 2
x = MsgBox("Yakin RECORD Dosen Akan Dihapus...!", vbQuestion + vbYesNo, "Dosen")
If x = vbYes Then ProsesDB 2
Call hapus
NIDN.SetFocus
Case 3
Call hapus
NIDN.SetFocus
Case 5
Adodc1.Refresh
Case 4
Unload Me
End Select
End Sub


Private Sub Command1_Click()
Adodc1.Refresh
End Sub

Private Sub form_load()
Call OPENDB
Call hapus
MulaiServer
BAGIAN.AddItem "HRD"
BAGIAN.AddItem "Humas"
BAGIAN.AddItem "Keuangan"

PENDIDIKAN.AddItem "Diploma III"
PENDIDIKAN.AddItem "Strata I"
PENDIDIKAN.AddItem "Strata II"

STATUS.AddItem "Menikah"
STATUS.AddItem "Belum MENIKAH"
End Sub
Private Sub NIDN_keyPress(keyAscii As Integer)
If keyAscii = 13 Then
If NIDN.Text = "" Then
MsgBox "Masukkan NIDN Dosen!", vbInformation, "Dosen"
NIDN.SetFocus
If NIDN.Text = "" Then
MsgBox "NIDN Harus 6 Digit!", vbInformation, "Dosen"
NIDN.SetFocus
End If

Exit Sub
End If
SQL = "SELECT * FROM Dosen WHERE NIDN='" & NIDN.Text & "'"
If Rs.State = adStateOpen Then Rs.Close
Rs.Open SQL, Db, adOpenDynamic, adLockBatchOptimistic
If Rs.RecordCount <> 0 Then
tampilDosen
Call RubahCMD(Me, False, True, True, True)
CmdProses(1).Caption = "&Edit"
NIDN.Enabled = False
Else
x = NIDN.Text
Call hapus
NIDN.Text = x
Call RubahCMD(Me, False, True, False, True)
CmdProses(1).Caption = "&Simpan"
End If
NAMA.SetFocus
End If

End Sub
Sub MulaiServer()
WS.LocalPort = 1000
End Sub



Private Sub WS_ConnectionRequest(ByVal requestID As Long)
WS.Close
WS.Accept requestID
Me.Caption = "Server-Client" & WS.RemoteHostIP & "Connect"

End Sub

Private Sub WS_DataArrival(ByVal bytesTotal As Long)
Dim xKirim As String
Dim xData1() As String
Dim xData2() As String

WS.GetData xKirim, vdString, bytesTotal
xData1 = Split(xKirim, "-")

Select Case xData1(0)
Case "SEARCH"
SQL = "SELECT*FROM Dosen WHERE NIDN='" & xData1(1) & "'"
If Rs.State = adStateOpen Then Rs.Close
Rs.Open SQL, Db, adOpenDynamic, adLockOptimistic
If Rs.RecordCount <> 0 Then
WS.SendData "RECORD-" & Rs!NAMA & "/" & Rs!TEMPAT & "/" & Rs!TANGGAL
Else
WS.SendData "NOTHING-xxx"
End If
Case "INSERT"
Db.BeginTrans
Db.Execute xData1(1), adCmdTable
Db.CommitTrans
WS.SendData "INSERT-xxx"
Adodc1.Refresh
Case "UPDATE"
Db.BeginTrans
Db.Execute xData1(1), adCmdTable
Db.CommitTrans
WS.SendData "EDIT-xxx"
Adodc1.Refresh
Case "DELETE"
SQL = "Delete * from DOSEN " & _
"where NIDN='" & xData1(1) & "'"
Db.BeginTrans
Db.Execute SQL, adCmdTable
Db.CommitTrans
Adodc1.Refresh
WS.SendData "DEL-xxx"
End Select
End Sub

Listing Program Client

Dim IPServer As String

Sub hapus()
NIDN.Enabled = True
ClearFORM Me
Call RubahCMD(Me, True, False, False, False)
CmdProses(1).Caption = "&Simpan"
End Sub
Sub ProsesDB(Log As Byte)
Select Case Log
Case 0
SQL = "INSERT INTO Dosen(NIDN, Nama, Tempat,Tanggal,Pendidikan,Bagian,Status)" & _
"values('" & NIDN.Text & _
"','" & NAMA.Text & _
"','" & TEMPAT.Text & _
"','" & TANGGAL.Text & _
"','" & PENDIDIKAN.Text & _
"','" & BAGIAN.Text & _
"','" & STATUS.Text & "')"
Case 1
SQL = "UPDATE Dosen SET Nama='" & NAMA.Text & "'," & _
" Tempat = '" & TEMPAT.Text & "' " & _
" Tanggal = '" & TANGGAL.Text & "' " & _
" Pendidikan = '" & PENDIDIKAN.Text & "' " & _
" Bagian = '" & BAGIAN.Text & "' " & _
" Status = '" & STATUS.Text & "' " & _
"where NIDN ='" & NIDN.Text & "'"
Case 2
x = MsgBox("Yakin RECORD Barang Akan Dihapus...!", vbQuestion + vbYesNo, "Barang")
If x = vbYes Then
WS.SendData "DELETE-" & Kode.Text

End If
Call hapus
Kode.SetFocus
Case 3
Call hapus
Kode.SetFocus
Case 4
Unload Me
End Select
End Sub
Sub tampilDosen()
On Error Resume Next
NIDN.Text = Rs!NIDN
NAMA.Text = Rs!NAMA
TEMPAT.Text = Rs!TEMPAT
TANGGAL.Text = Rs!TANGGAL
PENDIDIKAN.Text = Rs!PENDIDIKAN
BAGIAN.Text = Rs!BAGIAN
STATUS.Text = Rs!STATUS
End Sub

Private Sub CMDproses_click(index As Integer)
Select Case index
Case 0
Call hapus
NIDN.SetFocus
Case 1
If CmdProses(1).Caption = "&Simpan" Then
Call ProsesDB(0)
Else
Call ProsesDB(1)
End If
Case 2
x = MsgBox("Yakin RECORD Dosen Akan Dihapus...!", vbQuestion + vbYesNo, "Dosen")
If x = vbYes Then ProsesDB 2
Call hapus
NIDN.SetFocus
Case 3
Call hapus
NIDN.SetFocus
Case 5
Adodc1.Refresh
Case 4
Unload Me
End Select
End Sub

Private Sub form_load()
Call hapus
MulaiKoneksi
BAGIAN.AddItem "HRD"
BAGIAN.AddItem "Humas"
BAGIAN.AddItem "Keuangan"

PENDIDIKAN.AddItem "Diploma III"
PENDIDIKAN.AddItem "Strata I"
PENDIDIKAN.AddItem "Strata II"

STATUS.AddItem "Menikah"
STATUS.AddItem "Belum MENIKAH"
End Sub
Private Sub NIDN_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If NIDN.Text = "" Then Exit Sub
WS.SendData "SEARCH-" & NIDN.Text
End If
End Sub
Sub MulaiKoneksi()
IPServer = "192.168.10.1"
IPClient = WS.LocalIP
WS.Connect IPServer, 1000
End Sub
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
DoEvents
End
End Sub
Private Sub WS_Dataarrival(ByVal bytesTotal As Long)
Dim xkrim As String
Dim xData1() As String
Dim xData2() As String

WS.GetData xKirim, vbString, bytesTotal
xData1 = Split(xKirim, "-")
Select Case xData1(0)
Case "NOTHING"
x = NIDN.Text
Call hapus
NIDN.Text = x
Call RubahCMD(Me, False, True, False, True)
CmdProses(1).Caption = "&Simpan"
NAMA.SetFocus
Case "RECORD"
xData2 = Split(xData1(1), "/")
NAMA.Text = xData2(0)
TEMPAT.Text = xData2(1)
TANGGAL.Text = xData2(2)
PENDIDIKAN.Text = xData2(3)
BAGIAN.Text = xData2(4)
STATUS.Text = xData2(5)
Call RubahCMD(Me, False, True, True, True)
CmdProses(1).Caption = "&Edit"
NIDN.Enabled = False
NAMA.SetFocus
Case "DEL"
MsgBox "penghapusan data berhasil !"
Call hapus
Case "EDIT"
MsgBox "pengeditan record berhasil !"
Call hapus
End Select
End Sub

Module Client

Public SQL As String

Sub ClearFORM(f As Form)
Dim ctl As Control
For Each ctl In f
If TypeOf ctl Is TextBox Then ctl.Text = ""
If TypeOf ctl Is ComboBox Then ctl.Text = ""
Next
End Sub

Sub center(f As Form)
f.Move (Screen.Width - f.Width) / 2, (Screen.Height - f.Height) / 4
End Sub

Sub RubahCMD(f As Form, L0 As Boolean, L1 As Boolean, L2 As Boolean, L3 As Boolean)
f.CmdProses(0).Enabled = L0
f.CmdProses(1).Enabled = L1
f.CmdProses(2).Enabled = L2
f.CmdProses(3).Enabled = L3
End Sub

Listing Progaram Login

' password version 1.0
' created by: Mr. Jake Rodriguez Pomperada, MAED-IT
' date : March 30, 2009 Monday
' tool : Visual Basic 6.0
' email : jakerpomperada@yahoo.com
' location : purok pag-asa, barangay alijis 6100 bacolod city, negros
' occidental philippines

Option Explicit
Dim WrongLogin As Integer
Dim rs As ADODB.Recordset

Private Sub Command1_Click()
On Error GoTo errhandler

If WrongLogin = 2 Then
Call MsgBox("kamu sudah 3 kali gagal. silahkan keluar!!!", vbOKOnly, "Sorry")
End
End If

WrongLogin = WrongLogin + 1
Form1.txt_try.Text = Str(WrongLogin)

If UCase(txtUserName.Text) = "" Or IsNull(txtUserName.Text) = True Then
Call MsgBox("Nama Harus di isi.", vbOKOnly, "Nama")
txtUserName.SetFocus
Exit Sub
End If
If UCase(txtPassword.Text) = "" Or IsNull(txtPassword.Text) = True Then
Call MsgBox("Password Harus di isi.", vbOKOnly, "Password")
txtPassword.SetFocus
Exit Sub
End If

Open_cn

Set rs = New ADODB.Recordset
rs.Open ("Select * from Login Where UserName= '" & UCase(txtUserName.Text) & "'"), cn, adOpenStatic, adLockOptimistic, _
adCmdText


If UCase(txtPassword.Text) <> rs.Fields("password") Then
Call MsgBox("Incorrect Password", vbOKOnly, "Login Error")
txtPassword.Text = ""
txtPassword.SetFocus
Exit Sub
Else
'Correct!
UserName = UCase(txtUserName.Text) 'May need in the future project
MsgBox ("Correct Login. This is where you open another form and close this one.")
'This is where you open a new form and close frmLogin
'Example:

'frmMain.show
'unload me
End If
Close_cn
Exit Sub
errhandler:

Call MsgBox("Incorrect Username", vbOKOnly, "Login Error")
txtUserName.Text = ""
txtPassword.Text = ""
txtUserName.SetFocus
Exit Sub


End Sub

Private Sub Command2_Click()
Unload Me
End Sub

Private Sub Form_Load()
Form1.Show
Form1.txtUserName.SetFocus
WrongLogin = 0
End Sub



Private Sub Txtusername_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Form1.txtPassword.SetFocus
End If
End Sub



Private Sub Txtpassword_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
Form1.Command1.SetFocus
End If
End Sub

Option Explicit

Public UserName As String
Public DatabasePath As String
Public cn As ADODB.Connection

Module Login

Public Sub Open_cn()

Set cn = New ADODB.Connection
cn.CursorLocation = adUseClient
cn.Provider = "Microsoft.Jet.OLEDB.4.0"
cn.Properties("Data Source") = App.Path & "\login.mdb"
cn.Open

End Sub
Public Sub Close_cn()

cn.Close
Set cn = Nothing

End Sub