连接SQL数据库
Dim cnn As ADODB.Connection '数据库连接
Dim Rst2 As ADODB.Recordset
Private Sub Command1_Click()
Set cnn = New ADODB.Connection
si = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=" & _
Text5.Text & ";Data Source=" & Text4.Text
cnn.Open si
Set Rst2 = New ADODB.Recordset
si = "select * from " & Text3.Text
Rst2.Open si, cnn, adOpenDynamic, adLockOptimistic ‘打开一个可写入的表
……
End Sub
Private Sub Form_Load()
Text3.Text = "biao2" ‘表名
Text4.Text = "temp" ‘数据库组
Text5.Text = "xue01" ‘数据库
End Sub
读数据库
mdbopen
Set rst1 = New ADODB.Recordset
rst1.Open "shuku", cnn1
Do While Not rst1.EOF
If rst1!sdanjia = 100 Then
List1.AddItem rst1!sname
End If
rst1.MoveNext
Loop
rst1.Close
写数据库
mdbopen
Set rst2 = New ADODB.Recordset
rst2.CursorType = adOpenKeyset
rst2.LockType = adLockOptimistic
rst2.Open "shu0", cnn1, , , adCmdTable
Do While Not rst1.EOF
If rst1!sdanjia < 0 Then
rst1!sdanjia = 0
rst1.Update
End If
rst1.MoveNext
Loop
rst2.Close
清数据库
mdbopen
Set rst2 = New ADODB.Recordset
rst2.CursorType = adOpenKeyset
rst2.LockType = adLockOptimistic
rst2.Open "shu0", cnn1, , , adCmdTable
Do While Not rst2.EOF
rst2.Delete
rst2.MoveNext
Loop
把dbf库倒入mdb库
先按照dbf的字段建立mdb数据库，再把两库打开。
Do While Not rst2.EOF
rst1.AddNew
For i = 0 To rst1.Fields.Count - 1
rst1.Fields(i) = rst2.Fields(i)
Next i
rst1.Update
rst2.MoveNext
Loop
rst1.Close
rst2.Close
使用SQL语言
mdbopen
s1 = “select * from shuku where sdanjia = 100”
Set rst1 = New ADODB.Recordset
rst1.Open s1, cnn1
Do While Not rst1.EOF
List1.AddItem rst1!sname
rst1.MoveNext
Loop
rst1.Close
逆向查询
Rst1.Open "select distinct 雨量测站数据表.年度 from 雨量测站数据表 order by 年度 desc",cnn
添加新记录
SetDb
Set Rst1 = New ADODB.Recordset
Rst1.Open "决策信息表", cnn, adOpenKeyset, adLockOptimistic, adCmdTable ‘(1,3,2)
Rst1.AddNew
Rst1!决策代码 = JcDaima
Rst1!注册名 = Zhuce
Rst1!决策开始时间 = Date
Rst1.Update
Set Rst1 = Nothing
其中setdb程序为：
Public Sub SetDb()
Set cnn = New ADODB.Connection
fpath3 = "C:\My Documents\decision"
fpath2 = "DBQ=" & fpath3 & ";DefaultDir=c:\VB\demo;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:\Program Files\Common Files\ODBC\Data Sources\test00.dsn;MaxBufferSize=2048; MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2
End Sub
修改记录
STRN = "select * from 决策信息表 where 决策代码 = '" & JcDaima & "'"
Rst1.Open STRN, cnn, 1, 3
Rst1!Fanwei0 = Fanwei
Rst1!year0 = Dyear
Rst1.Update
Set Rst1 = Nothing
查找记录公用过程
Public Sub rseek(ss1 As String, ss2 As String, rst As ADODB.Recordset)
Dim bbb
bbb = True
rst.MoveFirst ‘rst不可为空,否则出现错误
Do While Not rst.EOF And bbb
If rst(ss1) = ss2 Then
bbb = False
Else
rst.MoveNext
End If
Loop
If bbb Then
'MsgBox "没有找到记录!"
brsl = True
End If
End Sub
调用时，只要用
rseek(“单价”,”51.5”,rst1)
就可把单价为51.5元的记录（第一个）找到了。
如果要用
brsl 判别是否找到，要先设
brsl = False。
注意，rst不可为空，可用
If rst1.RecordNum > 0 then rseek(“单价”, ”51.5”, rst1)
加以判别。
要多次使用rseek时，速度较慢。这时最好用SQL查询：
ss1 = "select * from shu0 where scode = '" & rst2!scode & "'"
Set rst1 = New ADODB.Recordset
rst1.Open ss1, cnn1
查询并修改数据
放置控件: Form1:Command1(按价格查), Command2(按书名查), Command3(按代码查),List1
代码:
Option Explicit
Dim s11 As Single, s12 As String
Sub inputp1()
Dim s2
s2 = ""
On Error GoTo head
head1:
s2 = InputBox("请输入单价:")
If s2 = "" Then
MsgBox "按‘确定’放弃"
Else
s11 = s2
End If
Exit Sub
head:
MsgBox "输入错！请重新输入"
Resume head1
End Sub
Sub listdelete()
Dim i
For i = 0 To List1.ListCount - 1
List1.Clear
Next
End Sub
Sub listshow1()
Dim st, s3, i
rst1.MoveFirst
i = 1
Do While Not rst1.EOF
If rst1!sdanjia = s11 Then
s3 = len3(str(i), 8) & len3(rst1!scode, 10) & len3(rst1!sname, 42) & _
" " & len3(str(s11), 8) & len3(rst1!syear, 12) & len3(rst1!skwh, 12) & len3(rst1!sbag, 6)
List1.AddItem s3
i = i + 1
End If
rst1.MoveNext
Loop
If (i = 1) Then
MsgBox "没找到！"
End If
End Sub
Private Sub Command1_Click()
inputp1
listdelete
If s11 <> 0 Then
listshow1
End If
End Sub
Sub listshow2()
Dim st, s3, i
rst1.MoveFirst
i = 1
Do While Not rst1.EOF
st = Mid(Trim(rst1!sname), 1, Len(s12))
If st = s12 Then
s3 = len3(str(i), 8) & len3(rst1!scode, 10) & len3(rst1!sname, 42) & _
" " & len3(rst1!sdanjia, 8) & len3(rst1!syear, 12) & len3(rst1!skwh, 12) & len3(rst1!sbag, 6)
List1.AddItem s3
i = i + 1
End If
rst1.MoveNext
Loop
If i = 1 Then
MsgBox "没找到！"
End If
End Sub
Sub inputp2()
Dim s2
s12 = ""
s2 = InputBox("请输入书名的前几个字:")
If s2 = "" Then
MsgBox "按‘确定’放弃"
Else
s12 = s2
End If
End Sub
Private Sub Command2_Click()
inputp2
listdelete
If s12 <> "" Then
listshow2
End If
End Sub
Sub listshow3()
Dim st, s3, i
rst1.MoveFirst
i = 1
Do While Not rst1.EOF
st = Mid(Trim(rst1!scode), 1, Len(s12))
If st = s12 Then
s3 = len3(str(i), 8) & len3(rst1!scode, 10) & len3(rst1!sname, 42) & _
" " & len3(rst1!sdanjia, 8) & len3(rst1!syear, 12) & len3(rst1!skwh, 12) & len3(rst1!sbag, 6)
List1.AddItem s3
i = i + 1
End If
rst1.MoveNext
Loop
If i = 1 Then
MsgBox "没找到！"
End If
End Sub
Sub inputp3()
Dim s2
s12 = ""
s2 = InputBox("请输入代码的前几个字:")
If s2 = "" Then
MsgBox "按‘确定’放弃"
Else
s12 = s2
End If
End Sub
Private Sub Command3_Click()
inputp3
listdelete
If s12 <> "" Then
listshow3
End If
End Sub
Private Sub Command4_Click()
cnn1.Close
Unload Me
End Sub
Private Sub List1_Click()
Dim li1, s1, s2
li1 = Mid(List1, 9, 8)
s1 = InputBox("请输入书" & Trim(li1) & "的新库位号 : ")
If s1 = "" Then
MsgBox "未输入库位号，请重新输入。"
Exit Sub
Else
Call rseek("scode", Trim(li1), rst1)
s2 = rst1!skwh
rst1!skwh = s1
rst1.Update
rst2.AddNew
rst2!knum = tnum
rst2!kdate = Date
rst2!kcode = rst1!scode
rst2!kh1 = s2
rst2!kh2 = s1
rst2.Update
End If
rst1.Close
rst2.Close
cnn1.Close
Load fkuweip
fkuweip.pp1
MsgBox ("本次入库单处理完毕。按“确定”退出")
Unload Me
End Sub
Private Sub Form_Load()
Dim strcnn
Dim it As Integer
Dim k, s2
strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _
"Data Source=" & fpath1 & "shukux.mdb"
Set cnn1 = New ADODB.Connection
cnn1.Open strcnn
Set rst1 = New ADODB.Recordset
rst1.CursorType = adOpenKeyset
rst1.LockType = adLockOptimistic
rst1.Open "shu0", cnn1, , , adCmdTable
Set rst2 = New ADODB.Recordset
rst2.CursorType = adOpenKeyset
rst2.LockType = adLockOptimistic
rst2.Open "kwh", cnn1, , , adCmdTable
If rst2.RecordCount < 1 Then
tnum = "K00001"
Else
rst2.MoveLast
s2 = rst2!knum
s2 = Mid(s2, 2, 6)
s2 = Trim(str(Int(s2) + 1))
Do While Len(s2) < 5
s2 = "0" + s2
Loop
tnum = "K" & s2
End If
End Sub
连接远程数据库
1．用ADODC控件连接远程数据库
用文件DSN连接，建立连接后，再添加一个ADODC控件，一个List1控件，程序如下：
Private Sub Form_Load()
fpath2 = "DBQ=\\Sans\office2000\demo\db1.mdb;DefaultDir=c:\VB\demo;Driver = {Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:\Program Files\Common Files\ODBC\Data Sources\test00.dsn;MaxBufferSize = 2048;MaxScanRows =8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Adodc1.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False; Extended Properties=" & fpath2
Adodc1.RecordSource = "addvdata"
Adodc1.Refresh
Do While Not Adodc1.Recordset.EOF
List1.AddItem Adodc1.Recordset!addvcd
Adodc1.Recordset.MoveNext
Loop
End Sub
2．用程序连接远程数据库
在【工程】‖【引用】中选”MS Dao 2.5/3.51 Compatibility Library”和“MS ADO 2,0 Library”，再添加一个List1控件，程序如下：
Public Cnn As ADODB.Connection
Private Sub Form_Load()
Dim strcnn, fpath2
Dim rst1 As New ADODB.Recordset
Set Cnn = New ADODB.Connection
fpath2 = "DBQ=\\Sans\office2000\demo\db1.mdb;DefaultDir=c:\VB\demo;Driver = {Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:\Program Files\Common Files\ODBC\Data Sources\test00.dsn;MaxBufferSize = 2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2
rst1.Open "select * from addvdata ", Cnn
Do While Not rst1.EOF
List1.AddItem rst1!addvcd
rst1.MoveNext
Loop
rst1.Close
End Sub
数据录入实例
这是一个在几个控件选择（测站和年度）条件下用TEXT进行录入，如果该记录有值，进入UPDATE状态，如果没有值，进入ADDNEW状态。最后的总和可以输入，也可以计算。按【确认】可以根据计算结果提示用户输入的总和相差太大（超过5%），然后写入数据库，并使测站翻到下一个。
'测站年度数据录入
Option Explicit
Dim RainstatCd As String
Dim flag As Boolean '判断记录是否有值
Private Sub cmdcancel_Click(Index As Integer)
combo_year_Click
End Sub
Private Sub cmdexit_Click()
Unload Me
End Sub
Private Sub cmdjisuan_Click(Index As Integer)
Dim i As Integer
Dim txtbox As TextBox
For Each txtbox In Me.Text1
If txtbox.Text = "" Then
txtbox.Text = "0"
End If
Next
Text1(12) = "0"
For i = 0 To 11
Text1(12) = Val(Text1(12)) + Val(Text1(i))
Next i
Text1(12).SetFocus
End Sub
Private Sub cmdSubmit_Click(Index As Integer)
Dim i As Integer
Dim sum As Long
Dim txtbox As TextBox
On Error GoTo err
For Each txtbox In Me.Text1
If txtbox.Text = "" Then
txtbox.Text = "0"
End If
Next
sum = 0
For i = 0 To 11
sum = sum + Val(Text1(i))
Next i
If sum = 0 Then
MsgBox "没有数据不能提交", , "提示"
Exit Sub
End If
If (sum - Val(Text1(12))) / sum > 0.05 Or (Val(Text1(12)) - sum) / sum > 0.05 Then
If MsgBox("年降水量与各月累加相差5%,是否修正？", vbQuestion + vbYesNo, "提示") = vbYes Then
Text1(12).Text = Trim(Str$(sum))
Text1(12).SetFocus
Exit Sub
End If
End If
Set Rst2 = New ADODB.Recordset
Set Rst1 = New ADODB.Recordset
Rst1.Open "select rainstat.* from rainstat where rainstat.rainstatnm='" & Combo_nm.Text & " ' ", Cnn
RainstatCd = Rst1("rainstatcd")
Rst1.Close
'Cnn.BeginTrans
If flag = False Then
Rst2.Open "select * from statdata", Cnn, adOpenStatic, adLockOptimistic
'Rst2.MoveLast
Rst2.AddNew
Else
Rst2.Open "select * from statdata where rainstatcd='" & RainstatCd & "' and year1=" & Val(combo_year), Cnn, adOpenStatic, adLockOptimistic
End If
Rst2("rainstatcd") = RainstatCd
Rst2("year1") = combo_year
For i = 0 To 12
Rst2.Fields(i + 2) = Text1(i).Text
Next i
Rst2.Update
'rst2.Requery
'Cnn.CommitTrans
If Combo_nm.ListIndex < Combo_nm.ListCount - 1 Then
Combo_nm.ListIndex = Combo_nm.ListIndex + 1
Else
Combo_nm.ListIndex = 0
End If
If Gflag Then
'MsgBox "gflag=" & Gflag
Unload Me
Exit Sub
Else
CalEnter2 Combo_nm.List(Combo_nm.ListIndex) '换到下一个测站
End If
Text1(0).SetFocus
Exit Sub
err:
MsgBox err.Description
End Sub
Private Sub combo_nm_Change()
'combo_year_Click
End Sub
Private Sub combo_nm_Click()
combo_year_Click
End Sub
Private Sub combo_year_Click()
Dim i
flag = False
Set Rst1 = New ADODB.Recordset
Rst1.Open "select * from rainstat where rainstatnm='" & Combo_nm & "'", Cnn
Set Rst2 = New ADODB.Recordset
Rst2.Open "select * from statdata where rainstatcd='" & Rst1!RainstatCd & "' and year1=" & Val(combo_year), Cnn
i = 0
While Not Rst2.EOF
i = i + 1
Rst2.MoveNext
Wend
If i > 0 Then
Rst2.MoveFirst
RainstatCd = Rst2("rainstatcd")
flag = True
For i = 0 To 12
If Not IsNull(Rst2.Fields(i + 2)) Then
Text1(i) = Rst2.Fields(i + 2)
Else
Text1(0) = ""
End If
Next i
Else
For i = 0 To 12
Text1(i) = ""
Next i
flag = False
End If
Rst1.Close
Rst2.Close
End Sub
