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 Command1_Click()
Adodc1.Refresh
End Sub

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

Private Sub Form_Load()
Call OPENDB
Call Hapus
MulaiServer
End Sub

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 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


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"

Case "EDIT"

Case "DELETE"

End Select
End Sub
"Module1 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=C:\WSDB\WSDB-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

"Listing Program Client"
Dim IPServer As String

Sub Hapus()
Kode.Enabled = True
ClearFORM Me
Call RubahCMD(Me, True, False, False, False)
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
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

Else

End If
Case 2
X = MsgBox("Yakin Record Barang Akan Dihapus.", vbQuestion + vbYesNo, "Barang")
If X = vbYes Then

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

Sub MulaiKoneksi()
IPServer = "192.168.10.1"
IPClient = WS.LocalIP
WS.Connect IPServer, 1000
End Sub

Private Sub Form_Load()
Call Hapus
MulaiKoneksi
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
DoEvents
End
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

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 "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
End Select
End Sub

"Module2 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.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

Contoh Client & Server Pegawai

Tampilan login

Listing Program

Private Sub Cmdok_Click()

    If Txtuser.Text = "pajar" And Txtpas.Text = "udin" Then

 FrmPegawai.Show

 FrmLogin.Hide

 Else

 FrmLogin.Show

 FrmPegawai.Hide

 MsgBox "maaf User dan Password Salah Bosss"

 bersih

 Txtuser.SetFocus

 End If

End Sub

Private Sub Form_Load()

    bersih

End Sub

Sub bersih()

Txtuser.Text = ""

Txtpas.Text = ""

End Sub

Private Sub CmdKeluar_Click()

End

End Sub

Listing Program

Sub Hapus()

    NIP.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 Pegawai(NIP, Nama, TempatLhr, TanggalLhr, Pendidikan, Bagian, Status)" & _

                " values('" & NIP.Text & _

                "','" & NAMA.Text & _

                "','" & TEMPAT.Text & _

                "','" & TANGGAL.Text & _

                "','" & PENDIDIKAN.Text & _

                "','" & BAGIAN.Text & _

                "','" & STATUS.Text & "')"

        Case 1

            ctgl = Mid(TANGGAL.Text, 7, 4) & "-" & Mid(TANGGAL.Text, 4, 2) & "-" & Mid(TANGGAL.Text, 1, 2)

           

            SQL = "UPDATE Pegawai SET Nama ='" & NAMA.Text & "'," & _

                  " TempatLhr = '" & TEMPAT.Text & "'," & _

                  " TanggalLhr = '" & ctgl & "'," & _

                  " Pendidikan = '" & PENDIDIKAN.Text & "'," & _

                  " Bagian = '" & BAGIAN.Text & "'," & _

                  " Status = '" & STATUS.Text & "' " & _

                  " where NIP ='" & NIP.Text & "'"

        Case 2

            SQL = "DELETE FROM Pegawai WHERE NIP='" & NIP.Text & "'"

    End Select

    MsgBox "Pemorosesan RECORD Database telah berhasil...!", vbInformation, "Data Pegawai"

    Db.Execute SQL, adCmdTable

    Call Hapus

    Adodc1.Refresh

    NIP.SetFocus

End Sub

Sub Tampilpegawai()

    On Error Resume Next

    NIP.Text = RS!NIP

    NAMA.Text = RS!NAMA

    TEMPAT.Text = RS!TempatLhr

    TANGGAL.Text = RS!TanggalLhr

    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

        NIP.SetFocus

    Case 1

        If CmdProses(1).Caption = "&Simpan" Then

            Call ProsesDB(0)

        Else

            Call ProsesDB(1)

        End If

    Case 2

        x = MsgBox("Yakin RECORD PEGAWAI Akan Dihapus...!", vbQuestion + vbYesNo, "Pegawai")

        If x = vbYes Then ProsesDB 2

        Call Hapus

        NIP.SetFocus

    Case 3

        Call Hapus

        NIP.SetFocus

    Case 4

        Unload Me

    End Select

End Sub

Private Sub Form_Load()

    Call OPENDB

    Call Hapus

   

    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 "TIDAK MENIKAH"

End Sub

Private Sub NIP_KeyPress(KeyAscii As Integer)

    If KeyAscii = 13 Then

        If NIP.Text = "" Then

            MsgBox "Masukkan NIP Pegawai !", vbInformation, "Pegawai"

            NIP.SetFocus

            Exit Sub

        End If

        SQL = "SELECT * FROM Pegawai WHERE NIP='" & NIP.Text & "'"

        If RS.State = adStateOpen Then RS.Close

        RS.Open SQL, Db, adOpenDynamic, adLockOptimistic

        If RS.RecordCount <> 0 Then

            Tampilpegawai

            Call RubahCMD(Me, False, True, True, True)

            CmdProses(1).Caption = "&Edit"

            NIP.Enabled = False

        Else

            x = NIP.Text

            Call Hapus

            NIP.Text = x

            Call RubahCMD(Me, False, True, False, True)

            CmdProses(1).Caption = "&Simpan"

        End If

        NAMA.SetFocus

    End If

End Sub

Private Sub WS_CconnectionRequest(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 Pegawai WHERE NIP='" & 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!TempatLhr & "/" & RS!TanggalLhr & "/" & RS!PENDIDIKAN & "/" & RS!STATUS

            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 Pegawai " & _

    "where NIP='" & xData1(1) & "'"

    Db.BeginTrans

    Db.Execute SQL, adCmdTable

    Db.CommitTrans

    Adodc1.Refresh

    WS.SendData "DEL-xxx"

        End Select

End Sub

Module1

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=MSDASQL.1;Persist Security Info=False;Data Source=Pegawai"

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