Mandasari Nababan

lihat soal disini

PROGRAM SERVER

Listing FormBarang
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 "Pemrosesan 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 4
    Unload Me
    End Select
  
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, adLockOptimistic
    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, vbString, 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-DATA"
            End If
          
        Case "INSERT"
            Db.BeginTrans
            Db.Execute xData1(1), adCmdTable
            Db.CommitTrans
            WS.SendData " INSERT-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"
      
        Case "UPDATE"
            Db.BeginTrans
            Db.Execute xData1(1), adCmdTable
            Db.CommitTrans
            WS.SendData "EDIT-xxx"
            Adodc1.Refresh
    End Select
End Sub

Listing Modul
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=C:\Belajar Server\test.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

FormServer

FormClient

lihat soal disini

PROGRAM SERVER

Dim ClientIndex As Byte
Dim cRequest As Integer
Dim cData As String
Dim i As Integer
Dim iGD As Integer

Sub MulaiServer()
        WS(0).LocalPort = 3000
        WS(0).Listen
        cRequest = 1
        ClientIndex = 1
End Sub

Private Sub Form_Load()
        MulaiServer
        GD.Rows = 41
        For i = 1 To 40
            GD.Col = 0
            GD.Row = i
            GD.Text = i
        Next i
        iGD = 1
End Sub

Private Sub Timer1_Timer()

    For i = 1 To GD.Rows - 1
        GD.Row = i
        GD.Col = 4
        If GD.Text = "START" Then
            GD.Col = 3
            GD.Text = Time
        End If
    Next i
End Sub

Private Sub Timer2_Timer()
WS.SendData "PAKAI-" & Pakai.Value & "/" & 3000
End Sub

Private Sub WS_ConnectionRequest(index As Integer, ByVal requestID As Long)
        Load WS(cRequest)
        WS(cRequest).Close
        WS(cRequest).Accept requestID
        cRequest = cRequest + 1 '
Timer1.Enabled = True
Timer2.Enabled = True

End Sub

Private Sub WS_DataArrival(index As Integer, ByVal bytesTotal As Long)
        WS(index).GetData cData, vbString, bytesTotal
        Call CekData(index)
       
End Sub

Sub CekData(index)
        Dim kata() As String
        kata = Split(cData, "-")
        Select Case kata(0)
        Case "START"
                        GD.Row = iGD
                        GD.Col = 1
                        GD.Text = kata(1) 'WS(index).RemoteHostIP
                        GD.Col = 2
                        GD.Text = Time
                        GD.Col = 4
                        GD.Text = "START"
                        GD.Col = 5
                        GD.Text = kata(2)
                        iGD = iGD
        Case "STOP"
            For i = 1 To GD.Rows - 1
                GD.Row = i
                GD.Col = 1
                If GD.Text = kata(1) Then
                        GD.Col = 4
                        GD.Text = "STOP"
                End If
            Next i
        End Select
End Sub
       
Private Sub WS_Error(index As Integer, ByVal Number As Integer, Description As String, ByVal Scode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, CancelDisplay As Boolean)
        WS(index).Close
End Sub


PROGRAM CLIENT

Dim IPS As String
Dim User As String

Private Sub Command1_Click()
    WS.SendData "START-" & User & "-mandasari"
End Sub

Private Sub Command2_Click()
    WS.SendData "STOP-" & User
End Sub

Private Sub Form_Load()
    IPS = "127.0.0.1"
    User = WS.LocalIP
    WS.Connect IPS, 3000
End Sub

Private Sub WS_DataArrival(ByVal bytesTotal As Long)
WS.GetData xKirim, vbString, bytesTotal
Call CheckData
End Sub

Sub CheckData()
xdata1 = Split(xKirim, "-")
xdata2 = Split(xdata1(1), "/")

Select Case xdata1(0)
    Case "PAKAI"
    mulai.Value = xdata2(0)
    selesai.Value = xdata2(1)
    pakai.Value = xdata2(2)
    biaya.Text = (Val(Hour(pakai.Value) * 60) + Val(Minute(pakai.Value) * 50))
    End Select
End Sub

Program Server

* Buat database dengan nama database dbbuku.mdb
* Buat tabel buku seperti di bawah ini
field : kdbuku, judul, pengarang, penerbit, tahun, edisi, harga, jumlah
* Dan tabel login, seperti di bawah ini
field : user, password
* Buka Visual Basic 6.0,
* Desain Formbuku, Login, MDIForm1


*Listing program pada Login :

Private Sub masuk_Click()
If user.Text = "manda" And password.Text = "1234" Then
MDIForm1.Show
ElseIf user.Text = "" & password.Text = "" Then
MsgBox "Silahkan masukkan password login", vbCritical, "info"
user.SetFocus
Else
MsgBox "password yang anda inputkan salah", vbCritical, "info"
user.Text = ""
password.Text = ""
End If
End Sub

Private Sub keluar_Click()
Unload Me
End Sub

Private Sub Form_Load()
user.Text = ""
password.Text = ""
password.PasswordChar = "*"
End Sub


*Listing tampilan menu (MDIForm1) :

Private Sub keluar_Click()
Unload Me
End Sub

Private Sub buku_Click()
Formbuku.Show
End Sub


*Listing pada modul program :

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=" & App.Path & _ "\dbbuku.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 pada Formbuku :

Sub hapus()
kdbuku.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 buku(kdbuku,judul,pengarang,penerbit,tahun,edisi,harga,jumlah)" & _
        "values('" & kdbuku.Text & _
        "','" & judul.Text & _
        "','" & pengarang.Text & _
        "','" & penerbit.Text & _
        "','" & tahun.Text & _
        "','" & edisi.Text & _
        "','" & harga.Text & _
        "','" & jumlah.Text & "')"
    Case 1
        SQL = "UPDATE buku SET judul='" & judul.Text & "'," & _
            "pengarang='" & pengarang.Text & "'" & _
            "penerbit='" & penerbit.Text & "'" & _
            "tahun='" & tahun.Text & "'" & _
            "edisi='" & edisi.Text & "'" & _
            "harga='" & harga.Text & "'" & _
            "jumlah='" & jumlah.Text & "'" & _
            "WHERE kdbuku='" & kdbuku.Text & "'"
    Case 2
        SQL = "DELETE  FROM buku WHERE kdbuku='" & kdbuku.Text & "'"
    End Select
   
MsgBox "Pemrosesan record Database telah berhasil....!!", vbInformation, "dbbuku"
    db.BeginTrans
    db.Execute SQL, adCmdTable
    db.CommitTrans
    Adodc1.Refresh
    Call hapus
    Adodc1.Refresh
    kdbuku.SetFocus

End Sub

Sub tampilbuku()
    On Error Resume Next
    kdbuku.Text = rs!kdbuku
    judul.Text = rs!judul
    pengarang.Text = rs!pengarang
    penerbit.Text = rs!penerbit
    tahun.Text = rs!tahun
    edisi.Text = rs!edisi
    harga.Text = rs!harga
    jumlah.Text = rs!jumlah
   
End Sub

Private Sub cmdproses_Click(Index As Integer)
Select Case Index
    Case 0
        Call hapus
        kdbuku.SetFocus
    Case 1
        If cmdproses(1).Caption = "&Simpan" Then
            Call prosesDB(0)
        Else
            Call prosesDB(1)
        End If
    Case 2
        X = MsgBox("yakin RECORD buku akan dihapus...!", vbQuestion + vbYesNo, "buku")
        If X = vbYes Then prosesDB 2
        Call hapus
        kdbuku.SetFocus
    Case 3
        Call hapus
        kdbuku.SetFocus
    Case 4
    Unload Me
End Select
       
End Sub

Private Sub Form_Load()
Call opendb
Call hapus
mulaiserver
End Sub

Private Sub kdbuku_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    If kdbuku.Text = "" Then
        MsgBox "Masukkan kode buku!", vbInformation, "buku"
        kdbuku.SetFocus
        Exit Sub
End If
SQL = "SELECT * FROM buku WHERE kdbuku='" & kdbuku.Text & "'"
If rs.State = adStateOpen Then rs.Close
rs.Open SQL, db, adOpenDynamic, adLockOptimistic
If rs.RecordCount <> 0 Then
    tampilbuku
    Call rubahcmd(Me, False, True, True, True)
    cmdproses(1).Caption = "&Edit"
    kdbuku.Enabled = False

    Else
        X = kdbuku.Text
        Call hapus
        kdbuku.Text = X
        Call rubahcmd(Me, False, True, False, True)
          cmdproses(1).Caption = "&Simpan"
End If
judul.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, vbString, bytesTotal

xData1 = Split(xkirim, "-")
Select Case xData1(0)
    Case "SEARCH"
        SQL = "SELECT * FROM buku WHERE kdbuku='" & xData1(1) & "'"
    If rs.State = adStateOpen Then rs.Close
    rs.Open SQL, db, adOpenDynamic, adLockOptimistic
    If rs.RecordCount <> 0 Then
    ws.SendData "RECORD-" & rs!judul & "/" & rs!pengarang & "/" & rs!penerbit & "/" & rs!tahun & "/" & rs!edisi & "/" & rs!harga & "/" & rs!jumlah
    Else
        ws.SendData "NOTHING-DATA"
    End If
   
    Case "INSERT"
    db.BeginTrans
    db.Execute xData1(1), adCmdTable
    db.CommitTrans
    Adodc1.Refresh
    ws.SendData "INSERT-XXX"

    Case "EDIT"
    db.BeginTrans
    db.Execute xData1(1), adCmdTable
    db.CommitTrans
    Adodc1.Refresh
    ws.SendData "EDIT-XXX"

    Case "DELETE"
    SQL = "DELETE * FROM buku WHERE kdbuku='" & xData1(1) & "'"
    db.BeginTrans
    db.Execute SQL, adCmdTable
    db.CommitTrans
    Adodc1.Refresh
    ws.SendData "DEL-XXX"

    End Select
End Sub


Program Client


*Listing program pada Login :

Private Sub masuk_Click()
If user.Text = "siska" And password.Text = "1234" Then
MDIForm1.Show
ElseIf user.Text = "" & password.Text = "" Then
MsgBox "Silahkan masukkan password login", vbCritical, "info"
user.SetFocus
Else
MsgBox "password yang anda inputkan salah", vbCritical, "info"
user.Text = ""
password.Text = ""
End If
End Sub

Private Sub keluar_Click()
Unload Me
End Sub

Private Sub Form_Load()
user.Text = ""
password.Text = ""
password.PasswordChar = "*"
End Sub


*Listing pada modul program :

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 pada Formbuku :

Dim IPServer As String
Sub hapus()
kdbuku.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 buku(kdbuku,judul,pengarang,penerbit,tahun,edisi,harga,jumlah)" & _
"values('" & kdbuku.Text & _
"','" & judul.Text & _
"','" & pengarang.Text & _
"','" & penerbit.Text & _
"','" & tahun.Text & _
"','" & edisi.Text & _
"','" & harga.Text & _
"','" & jumlah.Text & "')"
Case 1
SQL = "UPDATE buku SET judul='" & judul.Text & "'," & _
"pengarang='" & pengarang.Text & "' " & _
"penerbit='" & penerbit.Text & "' " & _
"tahun='" & tahun.Text & "' " & _
"edisi='" & edisi.Text & "' " & _
"harga='" & harga.Text & "' " & _
"jumlah='" & jumlah.Text & "' " & _
"where kdbuku='" & kdbuku.Text & "'"
Case 2
SQL = "DELETE FROM buku WHERE kdbuku='" & kdbuku.Text & "'"
End Select
MsgBox "pemrosesan RECORD database telah berhasil...!", vbInformation, "dbbuku"
Call hapus
kdbuku.SetFocus
End Sub

Private Sub cmdproses_Click(Index As Integer)
Select Case Index
Case 0
Call hapus
kdbuku.SetFocus
Case 1
If cmdproses(1).Caption = " &Simpan" Then
SQL = "INSERT INTO buku(kdbuku,judul,pengarang,penerbit,tahun,edisi,harga,jumlah)" & _
"values('" & kdbuku.Text & _
"','" & judul.Text & _
"','" & pengarang.Text & _
"','" & penerbit.Text & _
"','" & tahun.Text & _
"','" & edisi.Text & _
"','" & harga.Text & _
"','" & jumlah.Text & "')"
ws.SendData "UPDATE-" & SQL
Else
SQL = "UPDATE buku SET judul = '" & judul.Text & "'," & _
"' , pengarang = '" & pengarang.Text & _
"' , penerbit= '" & penerbit.Text & _
"' , tahun= '" & tahun.Text & _
"' , edisi= '" & edisi.Text & _
"' , harga= '" & harga.Text & _
"' , jumlah= '" & jumlah.Text & _
"' where kdbuku= '" & kdbuku.Text & "'"
ws.SendData "UPDATE-" & SQL
End If
Case 2
X = MsgBox("yakin RECORD buku akan dihapus...!", vbQuestion + vbYesNo, "buku")
If X = vbYes Then
ws.SendData "DELETE-" & kdbuku.Text
End If
Call hapus
kdbuku.SetFocus
Case 3
Call hapus
kdbuku.SetFocus
Case 4
Unload Me
End Select
End Sub
Private Sub Form_Load()
Call hapus
mulaikoneksi
End Sub
Private Sub kdbuku_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If kdbuku.Text = "" Then Exit Sub
ws.SendData "SEARCH-" & kdbuku.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 xkirim As String
Dim xdata1() As String
Dim xdata2() As String
Dim xdata3() As String
Dim xdata4() As String
ws.GetData xkirim, vbString, bytesTotal
xdata1 = Split(xkirim, "-")
 Select Case xdata1(0)
 Case "NOTHING"
 X = kdbuku.Text
 Call hapus
 kdbuku.Text = X
 Call rubahCMD(Me, False, True, False, True)
 cmdproses(1).Caption = "&Simpan"
 judul.SetFocus

 Case "RECORD"
 xdata2 = Split(xdata1(1), "/")
 judul.Text = xdata2(0)
 penerbit.Text = xdata2(1)
 harga.Text = xdata2(2)
 jumlah.Text = xdata2(3)

 Call rubahCMD(Me, False, True, True, True)
 cmdproses(1).Caption = "&Edit"
 kdbuku.Enabled = False
 judul.SetFocus

 Case "DEL"
 MsgBox "penghapusan data berhasil!"
 Call hapus

 Case "EDIT"
 MsgBox "Pengeditan Record berhasil!"
 Call hapus
 End Select
End Sub


*Listing tampilan menu (MDIForm1) :

Private Sub keluar_Click()
Unload Me
End Sub

Private Sub buku_Click()
Formbuku.Show
End Sub