Thursday, September 24, 2009

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

0 komentar:

Post a Comment

Silahkan masukkan saran, komentar saudara, dengan ikhlas saya akan meresponnya.

 

Blog Info

SEO Stats powered by MyPagerank.Net
My Ping in TotalPing.com

Visitor Info