CONTOH BAHASA PEMROGRAM PADA VISUAL BASIC 6.0

Dim kolom As Integer

Dim Baris As Integer

Dim brs As Integer

Dim kol As Integer

Dim i As Integer

Dim j As Integer

Private Sub cmdWin_Click()

If Val(Me.xNoAcak.Text) > 0 Then

Me.List1.AddItem Me.xNoAcak.Text

ms.TextMatrix(Val(Me.xbaris.Text), Val(Me.xKolom.Text)) = "false"

End If

End Sub

Private Sub Command1_Click()

Timer1.Enabled = False

' Me.List1.AddItem Me.xNoAcak.Text

End Sub

Private Sub cmdMulai_Click()

Me.Frame1.Visible = True

Timer1.Enabled = True

ms.SetFocus

End Sub

Private Sub Command2_Click()

With frmcetak

.xNoPIN.Text = List1.Text

.xNama.Text = FindSatuRecord("TCustomer", "NoPin", "Nama", List1.Text)

.xAlamat.Text = FindSatuRecord("TCustomer", "NoPin", "Alamat", List1.Text)

.xSalesMemo.Text = FindSatuRecord("TCustomer", "NoPin", "SalesMemo", List1.Text)

.Show

End With

End Sub

Private Sub Form_Load()

Tengah Me

Baris = 10

kolom = 5

ms.Cols = kolom

ms.Rows = Baris

isiGrid01

isiGrid

End Sub

Private Sub Timer1_Timer()

On Error Resume Next

'ms.SetFocus

Randomize

brs = Rnd(9) * Baris

kol = Rnd(5) * kolom

ms.Row = brs

ms.col = kol

Me.xNoAcak.Text = ms.TextMatrix(brs, kol)

Me.xbaris.Text = brs

Me.xKolom.Text = kol

Me.xNama.Text = FindSatuRecord("TCustomer", "NoPIn", "SalesMemo", Me.xNoAcak.Text)

'ms.ForeColor = vbBlack

End Sub

Function AcakNo(s1 As Integer, s2 As Integer)

Dim i As Integer

For i = s1 To s2

Next i

End Function

Private Sub isiGrid01()

On Error Resume Next

Dim j As Long

Dim i As Integer

For i = 0 To Baris

For j = 0 To kolom

ms.TextMatrix(i, j) = 0

Next j

Next i

End Sub

Private Sub isiGrid()

Dim rs As ADODB.Recordset

Dim sql As String

sql = "Select NoACak from q_cpm"

Set rs = New ADODB.Recordset

rs.Open sql, MyDB, adOpenDynamic, adLockOptimistic

Dim j As Long

Dim i As Integer

Dim ss As String

i = 0

j = 0

Dim rs1 As ADODB.Recordset

If Not rs.EOF Then

rs.MoveFirst

While Not rs.EOF

ss = 0

If i > ms.Rows - 1 Then

i = 0

j = j + 1

End If

ss = rs!noacak

If rs!noacak >= 50 Then

ss = Right(Trim(rs!noacak), 1)

Else

ss = rs!noacak

End If

Set rs1 = New ADODB.Recordset

sql = "select * from q_pin where sNo = " & Val(Trim(ss))

rs1.Open sql, MyDB, adOpenDynamic, adLockOptimistic

If Not rs1.EOF Then

ms.TextMatrix(i, j) = rs1!NoPin

List2.AddItem rs1!NoPin

End If

i = i + 1

rs.MoveNext

Wend

End If

For i = 0 To 9

If Val(ms.TextMatrix(i, 0)) = 0 Then

Set rs1 = New ADODB.Recordset

sql = "select * from q_pin where sNo = 36"

rs1.Open sql, MyDB, adOpenDynamic, adLockOptimistic

If Not rs1.EOF Then

ms.TextMatrix(i, 0) = rs1!NoPin

End If

End If

Next i

ms.TextMatrix(9, 4) = ""

'setData ms

End Sub

FORM CETAK

Dim kolom As Integer

Dim Baris As Integer

Dim brs As Integer

Dim kol As Integer

Dim i As Integer

Dim j As Integer

Private Sub cmdWin_Click()

If Val(Me.xNoAcak.Text) > 0 Then

Me.List1.AddItem Me.xNoAcak.Text

ms.TextMatrix(Val(Me.xbaris.Text), Val(Me.xKolom.Text)) = "false"

End If

End Sub

Private Sub Command1_Click()

Timer1.Enabled = False

' Me.List1.AddItem Me.xNoAcak.Text

End Sub

Private Sub cmdMulai_Click()

Me.Frame1.Visible = True

Timer1.Enabled = True

ms.SetFocus

End Sub

Private Sub Command2_Click()

With frmcetak

.xNoPIN.Text = List1.Text

.xNama.Text = FindSatuRecord("TCustomer", "NoPin", "Nama", List1.Text)

.xAlamat.Text = FindSatuRecord("TCustomer", "NoPin", "Alamat", List1.Text)

.xSalesMemo.Text = FindSatuRecord("TCustomer", "NoPin", "SalesMemo", List1.Text)

.Show

End With

End Sub

Private Sub Form_Load()

Tengah Me

Baris = 10

kolom = 5

ms.Cols = kolom

ms.Rows = Baris

isiGrid01

isiGrid

End Sub

Private Sub Timer1_Timer()

On Error Resume Next

'ms.SetFocus

Randomize

brs = Rnd(9) * Baris

kol = Rnd(5) * kolom

ms.Row = brs

ms.col = kol

Me.xNoAcak.Text = ms.TextMatrix(brs, kol)

Me.xbaris.Text = brs

Me.xKolom.Text = kol

Me.xNama.Text = FindSatuRecord("TCustomer", "NoPIn", "SalesMemo", Me.xNoAcak.Text)

'ms.ForeColor = vbBlack

End Sub

Function AcakNo(s1 As Integer, s2 As Integer)

Dim i As Integer

For i = s1 To s2

Next i

End Function

Private Sub isiGrid01()

On Error Resume Next

Dim j As Long

Dim i As Integer

For i = 0 To Baris

For j = 0 To kolom

ms.TextMatrix(i, j) = 0

Next j

Next i

End Sub

Private Sub isiGrid()

Dim rs As ADODB.Recordset

Dim sql As String

sql = "Select NoACak from q_cpm"

Set rs = New ADODB.Recordset

rs.Open sql, MyDB, adOpenDynamic, adLockOptimistic

Dim j As Long

Dim i As Integer

Dim ss As String

i = 0

j = 0

Dim rs1 As ADODB.Recordset

If Not rs.EOF Then

rs.MoveFirst

While Not rs.EOF

ss = 0

If i > ms.Rows - 1 Then

i = 0

j = j + 1

End If

ss = rs!noacak

If rs!noacak >= 50 Then

ss = Right(Trim(rs!noacak), 1)

Else

ss = rs!noacak

End If

Set rs1 = New ADODB.Recordset

sql = "select * from q_pin where sNo = " & Val(Trim(ss))

rs1.Open sql, MyDB, adOpenDynamic, adLockOptimistic

If Not rs1.EOF Then

ms.TextMatrix(i, j) = rs1!NoPin

List2.AddItem rs1!NoPin

End If

i = i + 1

rs.MoveNext

Wend

End If

For i = 0 To 9

If Val(ms.TextMatrix(i, 0)) = 0 Then

Set rs1 = New ADODB.Recordset

sql = "select * from q_pin where sNo = 36"

rs1.Open sql, MyDB, adOpenDynamic, adLockOptimistic

If Not rs1.EOF Then

ms.TextMatrix(i, 0) = rs1!NoPin

End If

End If

Next i

ms.TextMatrix(9, 4) = ""

'setData ms

End Sub

FORM ACAK

MODULE 1

Public sTgl As Integer, sBulan As Integer, sTahun As Integer

Public sQuery As String

Public MyDB As ADODB.Connection

Sub BukaDB()

Set MyDB = New ADODB.Connection

MyDB.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\database.mdb;Persist Security Info=False"

End Sub

Sub IsiKombo(query As String, cmb As ComboBox)

Dim rsf As ADODB.Recordset

Set rsf = New ADODB.Recordset

rsf.Open query, MyDB, adOpenDynamic, adLockOptimistic

If Not rsf.EOF Then

rsf.MoveFirst

While Not rsf.EOF

cmb.AddItem rsf.Fields(0)

rsf.MoveNext

Wend

End If

End Sub

Sub IsiListBox(query As String, cmb As ListBox)

Dim rsf As ADODB.Recordset

Set rsf = New ADODB.Recordset

rsf.Open query, MyDB, adOpenDynamic, adLockOptimistic

If Not rsf.EOF Then

rsf.MoveFirst

While Not rsf.EOF

cmb.AddItem rsf.Fields(0)

rsf.MoveNext

Wend

End If

End Sub

Function FindSatuRecord(oTabel As String, oFieldValidasi As String, oFieldHasil As String, oValidasi As String) As String

Dim rs1 As ADODB.Recordset

Dim query As String

query = "Select " & oFieldHasil & " from " & oTabel & " where " & oFieldValidasi & " = '" & oValidasi & "'"

'MsgBox query

Set rs1 = New ADODB.Recordset

rs1.Open query, MyDB, adOpenDynamic, adLockOptimistic

If rs1.EOF Then

FindSatuRecord = ""

Else

FindSatuRecord = rs1.Fields(0)

End If

End Function

Sub Tengah(x As Form)

x.Top = ((Screen.Height - x.Height) \ 2) - 800

x.Left = (Screen.Width - x.Width) \ 2

End Sub

Function GetCountRecord(rs As ADODB.Recordset) As Long

Dim j As Long

j = 0

If rs.EOF Then

GetCountRecord = 0

Else

With rs

.MoveFirst

While Not .EOF

DoEvents

j = j + 1

.MoveNext

Wend

End With

GetCountRecord = j

rs.MoveFirst

End If

End Function

Sub isi_FieldKriteria(kombo As ImageCombo, oTabel As String)

Dim rsKombo As ADODB.Recordset

Set rsKombo = New ADODB.Recordset

Dim query As String

query = "Select * from " & oTabel

rsKombo.Open query, MyDB, adOpenDynamic, adLockOptimistic

Dim i As Integer

For i = 0 To rsKombo.Fields.Count - 1

kombo.ComboItems.Add , , rsKombo.Fields(i).Name, 1

Next i

End Sub

Function setData(sM As MSHFlexGrid) As Integer

sM.TextMatrix(3, 0) = "false"

End Function

Option Explicit

Public cmd As ADODB.Command

Public xSQL As String

Public namafield As Field

Public txt As Control

Public Del As Long

Public Status As Boolean

Public JenisReport As String

Sub ListData(x As String, ls As ListView, db As ADODB.Connection, icon As Integer)

On Error Resume Next

Dim pList As ListItem

Dim pJudul As ColumnHeaders

Dim rs As ADODB.Recordset

Dim Jr As Integer

Set rs = New ADODB.Recordset

Dim i, j, jKolom As Integer

Dim Baris As Integer

rs.Open x, db, adOpenDynamic, adLockReadOnly

ls.View = lvwReport

ls.FullRowSelect = True

ls.GridLines = True

ls.AllowColumnReorder = True

ls.ColumnHeaders.Clear

ls.ListItems.Clear

If Not rs.EOF Then

Jr = rs.RecordCount

rs.MoveFirst

jKolom = rs.Fields.Count

For i = 0 To jKolom - 1

ls.ColumnHeaders.Add , , rs.Fields(i).Name

If IsAngkaNumerik(Trim(rs.Fields(i).Type)) = True Then

ls.ColumnHeaders.Item(i + 1).Alignment = lvwColumnRight

End If

If IsAngkaNumerik(Trim(rs.Fields(i).Type)) = False Then

ls.ColumnHeaders.Item(i + 1).Alignment = lvwColumnLeft

End If

Next i

Baris = 0

rs.MoveFirst

While Not rs.EOF

Baris = Baris + 1

Set pList = ls.ListItems.Add(, , rs.Fields(0), , icon)

For i = 1 To jKolom - 1

pList.SubItems(i) = rs.Fields(i)

Next i

rs.MoveNext

Wend

End If

End Sub

Function getItemList(ls As ListView, col As Integer) As String

On Error Resume Next

col = col - 1

If col = 0 Then

getItemList = ls.SelectedItem.Text

Else

getItemList = ls.SelectedItem.ListSubItems(col)

End If

End Function

Function IsAngkaNumerik(nType As String) As Boolean

Dim Ket As String

Select Case nType

Case "202", "200", "129": IsAngkaNumerik = False

Case "2": IsAngkaNumerik = True

Case "3": IsAngkaNumerik = True

Case "7": IsAngkaNumerik = False

Case "5", "131": IsAngkaNumerik = True

Case "4": IsAngkaNumerik = True

Case "203": IsAngkaNumerik = False

Case "6": IsAngkaNumerik = True

Case "11": IsAngkaNumerik = False

End Select

End Function

Sub clear_textbox(frm As Form)

On Error Resume Next

For Each txt In frm.Controls

If TypeOf txt Is TextBox Then

txt.Text = ""

ElseIf TypeOf txt Is ComboBox Then

txt.ListIndex = -1

txt.Text = ""

End If

Next

End Sub

Sub off_object(frm As Form)

On Error Resume Next

For Each txt In frm.Controls

If TypeOf txt Is TextBox Then

txt.Locked = True

txt.BackColor = &H80000005

txt.ForeColor = &H80000001

txt.BorderStyle = 1

txt.FontBold = False

ElseIf TypeOf txt Is ComboBox Then

txt.Locked = True

txt.BackColor = &H80000005

txt.ForeColor = &H80000001

ElseIf TypeOf txt Is OptionButton Then

txt.Locked = True

ElseIf TypeOf txt Is PictureBox Then

txt.Locked = True

End If

Next

End Sub

Sub on_object(frm As Form)

On Error Resume Next

For Each txt In frm.Controls

If TypeOf txt Is TextBox Then

txt.Locked = False

txt.BorderStyle = 1

txt.Appearance = 1

txt.BackColor = vbWhite

txt.ForeColor = vbBlack

txt.FontBold = False

ElseIf TypeOf txt Is ComboBox Then

txt.Locked = False

txt.BackColor = vbWhite

txt.ForeColor = vbBlack

ElseIf TypeOf txt Is OptionButton Then

txt.Locked = False

End If

Next

End Sub

Public oFieldTujuan(100) As String

Public ostrData(100) As String

Public oValiDasiEdit(10) As String

Public oWhereEdit(10) As String

Public oTypeData(100) As String

Sub KosongkanSimpanData()

Dim i As Integer

For i = 1 To 100

oFieldTujuan(i) = ""

ostrData(i) = ""

oTypeData(i) = "'"

Next i

For i = 1 To 10

oValiDasiEdit(i) = ""

oWhereEdit(i) = ""

Next i

End Sub

Sub setFieldRecord(idx As Integer, FieldTujuan As String, strData As String, TypeData As String)

On Error Resume Next

oFieldTujuan(idx) = FieldTujuan

If IsNull(strData) Then

ostrData(idx) = "0"

Else

ostrData(idx) = strData

End If

oTypeData(idx) = TypeData

End Sub

Sub setValidasi(idx As Integer, oValid As String, strData As String)

On Error Resume Next

oValiDasiEdit(idx) = oValid

oWhereEdit(idx) = strData

End Sub

Function SimpanRecord(db As ADODB.Connection, oTable As String, oStatusEdit As Boolean)

On Error Resume Next

Dim tblRecord As ADODB.Recordset

Dim lb, i, j As Integer

Dim s, q, nf As String

Dim per As String

Dim Tgl As Date

Dim hari, fDt, bulan, Tahun As String

lb = 0

If oStatusEdit = False Then

Set tblRecord = New ADODB.Recordset

q = "INSERT INTO " & oTable & " ("

For i = 1 To 100

If Trim(oFieldTujuan(i)) <> "" Then

q = q & oFieldTujuan(i) & ","

End If

Next i

s = Mid(q, 1, Len(Trim(q)) - 1)

q = s + " ) VALUES ("

For j = 1 To 100

If Trim(oFieldTujuan(j)) <> "" Then

If oTypeData(j) = "D" Then

Tgl = DateValue(ostrData(j))

hari = str(Day(Tgl))

bulan = str(Month(Tgl))

Tahun = str(Year(Tgl))

If Len(Trim(hari)) = 1 Then

hari = "0" & Trim(hari)

End If

If Len(Trim(bulan)) = 1 Then

bulan = "0" & Trim(bulan)

End If

fDt = Trim(Tahun) & "" & Trim(bulan) & "" & Trim(hari)

q = q & "'" & fDt & "',"

Else

q = q & "'" & ostrData(j) & "',"

End If

End If

Next j

s = Mid(q, 1, Len(Trim(q)) - 1)

q = s + ")"

End If

If oStatusEdit = True Then

Set tblRecord = New ADODB.Recordset

q = "UPDATE " & oTable & " SET "

For i = 1 To 100

If Trim(oFieldTujuan(i)) <> "" Then

If oTypeData(i) = "D" Then

Tgl = DateValue(ostrData(i))

hari = str(Day(Tgl))

bulan = str(Month(Tgl))

Tahun = str(Year(Tgl))

If Len(Trim(hari)) = 1 Then

hari = "0" & Trim(hari)

End If

If Len(Trim(bulan)) = 1 Then

bulan = "0" & Trim(bulan)

End If

fDt = Trim(Tahun) & "" & Trim(bulan) & "" & Trim(hari)

q = q & oFieldTujuan(i) & " = '" & fDt & "',"

Else

q = q & oFieldTujuan(i) & " = " & "'" & ostrData(i) & "',"

End If

End If

Next i

s = Mid(q, 1, Len(Trim(q)) - 1)

s = s + " WHERE "

For i = 1 To 10

If oValiDasiEdit(i) <> "" Then

If i = 1 Then

If oTypeData(i) = "D" Then

s = s + oValiDasiEdit(i) & "= " & oWhereEdit(i)

Else

s = s + oValiDasiEdit(i) & "= '" & oWhereEdit(i) & "'"

End If

Else

s = s + " AND " & oValiDasiEdit(i) & " = '" & oWhereEdit(i) & "'"

End If

End If

Next i

q = s

End If

Set tblRecord = New ADODB.Recordset

tblRecord.Open q, db, adOpenDynamic, adLockOptimistic

End Function