Private Sub Cmddelete_Click() '删除
Data1.Recordset.Delete
Data1.Recordset.MovePrevious '回到前一个记录
End Sub
Private Sub cmdexit_Click()
Unload Me
End Sub
Private Sub Form_Load()
firstflag = True '首次使用
Frame1.Visible = False '使主按钮组可见
End Sub
几个控件联动的例子
放置控件: Form1:Data1;Text1,Combo1,List1
属性设置:
Data1:〖DatabseName〗="db2.mdb",内有测站信息、径流量表等2个表。
Private Sub Combo1_Click()
Dim li, lstr, lstr1
For li = 1 To List1.ListCount
List1.Clear
Next
Data1.RecordSource = "select 测站代码 from 测站信息 where 测站名称='" & Combo1 & "'"
Data1.Refresh
lstr = Data1.Recordset!测站代码
Data1.RecordSource = "径流量表"
Data1.Refresh
Do While Not Data1.Recordset.EOF
lstr1 = Data1.Recordset!测站代码
If lstr1 = lstr Then
List1.AddItem Data1.Recordset!测量日期
End If
Data1.Recordset.MoveNext
Loop
End Sub
Private Sub List1_Click()
Dim lstr, sql1
Data1.RecordSource = "select 测站代码 from 测站信息 where 测站名称='" & Combo1 & "'"
Data1.Refresh
lstr = Data1.Recordset!测站代码
sql1 = "select * from 径流量表 where 测站代码='" & lstr & "' and 测量日期='" & List1 & "'"
Data1.RecordSource = sql1
Data1.Refresh
Text1 = Data1.Recordset!径流量
End Sub
Private Sub Form_Load()
Text1 = ""
Data1.RecordSource = "测站信息"
Data1.Refresh
Combo1 = Data1.Recordset!测站名称
Do While Not Data1.Recordset.EOF
Combo1.AddItem Data1.Recordset!测站名称
Data1.Recordset.MoveNext
Loop
End Sub
注：测量日期是字符型；
使用DATAGRID控件
使用FLEXGRID控件不能连接ADODC数据控件，这时就要用DATAGRID控件了。使用时只要在DATASOURCE属性中设置了ADODC控件名，就可以自动显示整个数据表了。
要取消DATAGRID的改动记录的功能，右击控件，在【属性】中把【允许更新】取消。要使第一个单元数据出现，在【拆分】选项卡中选【锁定】即可。
还可以在界面设计中改变字段名和字体。这时要用【添加】添加字段，然后选取或输入即可。
设置MSHFlexGrid每行的颜色
Public Sub SetRowColor(ByRef MSHFlexGrid As Object)
Dim j, i, objName
objName = TypeName(MSHFlexGrid)
If StrConv(Trim(objName), vbUpperCase) <> "MSHFLEXGRID" Then
Exit Sub
End If
MSHFlexGrid.FillStyle = 1
For i = 1 To MSHFlexGrid.Rows - 1
MSHFlexGrid.Row = i
If i Mod 2 = 0 Then
MSHFlexGrid.Col = 0
MSHFlexGrid.ColSel = MSHFlexGrid.Cols - 1
MSHFlexGrid.CellBackColor = &H80FFFF
End If
Next i
MSHFlexGrid.FillStyle = 0
MSHFlexGrid.Row = 0
MSHFlexGrid.Col = 0
End Sub
查询结果在DATAGRID控件中的显示
Dim rs1
Private Sub Form_Load()
Dim fpath2
'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;"
fpath2 = "DBQ=c:\vb\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;PageTimeou t=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!Year
Adodc1.Recordset.MoveNext
Loop
End Sub
Private Sub List1_Click()
Text1 = List1.ListIndex
Adodc1.Refresh
Set rs1 = Adodc1.Recordset
While Not rs1.EOF
If rs1!Year = List1 Then
DataGrid1.SelBookmarks.Add rs1.Bookmark
End If
rs1.MoveNext
Wend
DataGrid1.Scroll 0, -3
End Sub
使用DATAGRID控件的高级实例
本例使用DATAGRID1控件显示前几个月的实际降水量，再用历史数据推算后几个月的降水量，在DATAGRID2控件中显示。最后把全年数据写到第二个表中。
放置控件: Form1:Command1,Command2,List1,Adodc1,Datagrid1,Adodc2,Datagrid2, Text1等。
'估算当年降水量，并用DATAGRID控件实现显示功能 by Xue Wei 10/20/2001
Option Explicit
Const mmax = 13
Dim mj '有数据的截止月份
'退出
Private Sub Command1_Click()
'加入前面输入数据
Dim ii
Adodc1.RecordSource = "HYDNETDATA1"
Adodc1.Refresh
Adodc2.RecordSource = "HYDNETDATA2"
Adodc2.Refresh
While Not Adodc2.Recordset.EOF
For ii = 2 To mj + 1
Adodc2.Recordset.Fields(ii) = Adodc1.Recordset.Fields(ii)
Next ii
Adodc1.Recordset.MoveNext
Adodc2.Recordset.MoveNext
Wend
Unload Me
End Sub
'计算本年已有月份降水量的算术平均值
Function CalYp() As Integer
Dim mi, ii, qi
'Adodc1.Recordset.MoveFirst
'While Not Adodc1.Recordset.EOF
mi = 2
mj = 0
qi = 0
For ii = mi To mmax
If Not IsNull(Adodc1.Recordset.Fields(ii)) Then
qi = qi + Adodc1.Recordset.Fields(ii)
mj = mj + 1
End If
Next ii
CalYp = Int(qi / mj)
'Adodc1.Recordset.MoveNext
'Wend
End Function
'计算已有月份多年平均降水量的算术平均值
Function CalYd() As Integer
Dim ii, yd1
yd1 = 0
'MsgBox "cal=" & CalYm(1, 2)
For ii = 1 To mj
yd1 = yd1 + CalYm(ii, 2)
Next ii
CalYd = yd1 / mj
End Function
Private Sub Command2_Click()
Dim ii
For ii = 0 To 4
List1.Selected(ii) = True
CalList1 (List1.List(ii))
Next ii
End Sub
Sub CalList1(Listselected)
Dim mi, ii, qi
Dim yp '当年已有月份降水量的算术平均值
Dim ym '月多年平均降水量
Dim yd '相应月份多年平均降水量的算术平均值
Dim yk '比例系数
Dim ydn '多年平均降水量
Dim yy '估算的当年降水量
Dim ymj '估算的月降水量
'检查第一个月是否有值
Adodc1.Recordset.MoveFirst
If IsNull(Adodc1.Recordset("1月")) Then
MsgBox "没有当年的前几个月数据，不能进行当年降水量估算"
Unload Me
End If
'根据选择的流域名找到所在记录
While Adodc1.Recordset("流域名") <> Listselected
Adodc1.Recordset.MoveNext
Wend
Adodc2.RecordSource = "HYDNETDATA2"
Adodc2.Refresh
While Adodc2.Recordset.Fields(0) <> Adodc1.Recordset("代码")
Adodc2.Recordset.MoveNext
Wend
'估算当年降水量
yp = CalYp
yd = CalYd
ydn = CalYdn(2)
yk = yp / yd
'yy = Int(ydn * yk)
'Adodc2.Recordset.Fields(mmax + 1) = yy
Adodc2.Recordset!total = yy
Adodc2.Recordset.Update
'MsgBox "yY=" & yy & " mj=" & mj
'估算后续每月降水量
yy = 0
For ii = mj + 1 To mmax - 1
ymj = CalYm(ii, 2) * yk
yy = yy + ymj
Adodc2.Recordset.Fields(ii + 1) = ymj
Adodc2.Recordset.Update
Next ii
'合计得到估算年降水量
yy = yy + yp * mj
Adodc2.Recordset.Fields(mmax + 1) = yy
Adodc2.Recordset.Update
Adodc2.Refresh
Adodc2.RecordSource = "select HYDNETDATA2.hydnetcd as 代码,HYDNET.hydnetnm as 流域名 ,HYDNETDATA2.jan as 1月,HYDNETDATA2.feb as 2月,HYDNETDATA2.mar as 3月" & _
",HYDNETDATA2.apr as 4月,HYDNETDATA2.may as 5月,HYDNETDATA2.jun as 6月,HYDNETDATA2.jul as 7月,HYDNETDATA2.aug as 8月,HYDNETDATA2.sep as 9月,HYDNETDATA2.oct as 10月" & _
",HYDNETDATA2.nov as 11月,HYDNETDATA2.dec as 12月,HYDNETDATA2.total as 年降水量" & _
" from HYDNETDATA2,HYDNET where HYDNET.hydnetcd= HYDNETDATA2.hydnetcd " 'and HYDNET.hydnetcd='01'"
Adodc2.Refresh
End Sub
Private Sub list1_Click()
CalList1 (List1)
End Sub
Private Sub Form_Load()
Dim ii, Temp
Adodc1.ConnectionString = "Provider=MSDASQL.1;Persist Security Info= False;Extended Properties=" & fpath2
Adodc1.RecordSource = "HYDNETDATA1"
Adodc1.Refresh
Text1 = Adodc1.Recordset!year1
Adodc2.ConnectionString = "Provider=MSDASQL.1;Persist Security Info= False;Extended Properties=" & fpath2
Adodc2.RecordSource = "HYDNETDATA2"
Adodc2.Refresh
While Not Adodc2.Recordset.EOF
Adodc2.Recordset.Delete
Adodc2.Recordset.MoveNext
Wend
While Not Adodc1.Recordset.EOF
Adodc2.Recordset.AddNew
Adodc2.Recordset.Fields(0) = Adodc1.Recordset.Fields(0)
Adodc2.Recordset.Fields(1) = Adodc1.Recordset.Fields(1)
Adodc2.Recordset.Update
Adodc1.Recordset.MoveNext
Wend
Adodc1.RecordSource = "select HYDNETDATA1.hydnetcd as 代码,HYDNET.hydnetnm as 流域名 ,HYDNETDATA1.jan as 1月,HYDNETDATA1.feb as 2月,HYDNETDATA1.mar as 3月" & _
",HYDNETDATA1.apr as 4月,HYDNETDATA1.may as 5月,HYDNETDATA1.jun as 6月,HYDNETDATA1.jul as 7月,HYDNETDATA1.aug as 8月,HYDNETDATA1.sep as 9月,HYDNETDATA1.oct as 10月" & _
",HYDNETDATA1.nov as 11月,HYDNETDATA1.dec as 12月,HYDNETDATA1.total as 年降水量" & _
" from HYDNETDATA1,HYDNET where HYDNET.hydnetcd= HYDNETDATA1.hydnetcd " 'and HYDNET.hydnetcd='01'"
Adodc1.Refresh
While Not Adodc1.Recordset.EOF
List1.AddItem Adodc1.Recordset("流域名")
Adodc1.Recordset.MoveNext
Wend
Adodc2.Refresh
Adodc2.RecordSource = "select HYDNETDATA2.hydnetcd as 代码,HYDNET.hydnetnm as 流域名 ,HYDNETDATA2.jan as 1月,HYDNETDATA2.feb as 2月,HYDNETDATA2.mar as 3月" & _
",HYDNETDATA2.apr as 4月,HYDNETDATA2.may as 5月,HYDNETDATA2.jun as 6月,HYDNETDATA2.jul as 7月,HYDNETDATA2.aug as 8月,HYDNETDATA2.sep as 9月,HYDNETDATA2.oct as 10月" & _
",HYDNETDATA2.nov as 11月,HYDNETDATA2.dec as 12月,HYDNETDATA2.total as 年降水量" & _
" from HYDNETDATA2,HYDNET where HYDNET.hydnetcd= HYDNETDATA2.hydnetcd " 'and HYDNET.hydnetcd='01'"
Adodc2.Refresh
Gflag = False
If GisCD <> "" Then
Gflag = True
SetDb
Set Rst2 = New ADODB.Recordset
Rst2.Open "select * from HYDNET where trim(hydnetcd)='" & Trim(GisCD) & "'", Cnn
On Error Resume Next
Temp = Rst2("hydnetnm")
If err.Number > 0 Then
MsgBox "调用错误，返回"
Unload Me
End If
List1.Enabled = False
CalList1 (Temp)
End If
End Sub
在公用模块中用到代码如下：
Public Const fpath2 = "DBQ=\\WEBGIS\share\降水量文件\raindb.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;"
Public Cnn As ADODB.Connection '数据库连接
Public Rst1 As ADODB.Recordset '记录集，和set联合使用
Public Rst2 As ADODB.Recordset '记录集，和set联合使用
Public Const year0 = 1950 '最早记录年份
Public GisCD As String 'GIS调用的计算分区号
Public Gflag As Boolean '判断是否为GIS调用
'连接数据库
Public Sub SetDb()
Dim fpath2
Set Cnn = New ADODB.Connection
fpath2 = "DBQ=\\WEBGIS\share\降水量文件\raindb.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
End Sub
'月多年平均降水量,ym1为月份数字，ym2为类型：1-测站、2-流域、3-水库、4-区县
Public Function CalYm(ym1, ym2) As Single
Dim rst0 As New ADODB.Recordset
Dim Temp, Ti
SetDb
Select Case ym2
Case 2
rst0.Open "select * from HYDNETDATA", Cnn
Temp = 0
Ti = 0
While Not rst0.EOF
If IsNull(rst0.Fields(ym1 + 1)) Then rst0.Fields(ym1 + 1) = 0
Temp = Temp + rst0.Fields(ym1 + 1)
Ti = Ti + 1
'MsgBox "TI=" & Ti & " TEMP=" & Temp
rst0.MoveNext
Wend
End Select
rst0.Close
CalYm = Int(Temp * 100 / Ti) / 100
End Function
用数据库控件实现图表显示
在FORM上添加选项卡控件SSTAB1，在其中放入MSCHART控件（Chart0,1,2）和MSFLEXGRID (MfGrid0,1,2) 控件：
代码：
Option Explicit
Dim codetype(2) As String
Dim colfield(7) As String
Dim collabel(5) As String
Dim strsum(50)
Dim arrChartData()
Private Sub Command1_Click()
Unload Me
End Sub
Private Sub Form_Load()
'调用公共连接数据库
SetDb
'选项卡数组
codetype(0) = "流域"
codetype(2) = "水库"
codetype(1) = "区县"
'GRID横坐标数组
colfield(1) = "计算面积 "
colfield(2) = "多年平均降水量 "
colfield(3) = "多年平均降水总量 "
colfield(4) = "20%"
colfield(5) = "50%"
colfield(6) = "75%"
colfield(7) = "95%"
'CHART控件横坐标数组
collabel(1) = "多年平均降水总量"
collabel(2) = "20%"
collabel(3) = "50%"
collabel(4) = "75%"
collabel(5) = "95%"
End Sub
Private Sub SSTab1_Click(PreviousTab As Integer)
Dim strsql As String
Dim i
Select Case SSTab1.Tab
'流域表
Case 0
Set Rst1 = New ADODB.Recordset
strsql = "select * from hydnet where hydnetcd in (select hydnetcd from hydnetdata)"
Rst1.Open strsql, cnn
ReportSet 0, MfGrid0, Chart0
Rst1.Close
'区县表
Case 1
Set Rst1 = New ADODB.Recordset
strsql = "select * from addv where addvcd in (select addvcd from addvdata)"
Rst1.Open strsql, cnn
ReportSet 1, mfgrid1, Chart1
Rst1.Close
'水库表
Case 2
Set Rst1 = New ADODB.Recordset
strsql = "select * from shuiku where shuikucd in (select shuikucd from shuikudata)"
Rst1.Open strsql, cnn
ReportSet 2, mfgrid2, Chart2
Rst1.Close
End Select
End Sub
'计算和赋值
Sub ReportSet(k, mfgrid, Chart As Object)
Dim i, j, h
With mfgrid
.Col = 0
.Row = 0
.Text = codetype(k)
For i = 1 To 7
.Col = i
.ColWidth(i) = 1450
.Text = colfield(i)
Next i
End With
j = 0
If Rst1.EOF Then
MsgBox "no data"
Exit Sub
Else
Rst1.MoveFirst
Do While Not Rst1.EOF
j = j + 1
Rst1.MoveNext
Loop
End If
ReDim arrChartData(1 To j, 1 To 5)
Rst1.MoveFirst
i = 1
Do While Not Rst1.EOF
strsum(8) = Rst1.Fields(0) 'code
'多年平均降水总量计算
strsum(0) = Rst1.Fields(1) 'name
strsum(1) = Rst1!area 'area
strsum(2) = CalYdn2(strsum(8), k + 2) '调用计算多年平均降水量函数
strsum(3) = CLng(strsum(2)) * CLng(strsum(1)) / 100000
strsum(4) = calduoping(strsum(8), strsum(1), 0.2, k) '调用计算某频率下降水量的函数
strsum(5) = calduoping(strsum(8), strsum(1), 0.5, k)
strsum(6) = calduoping(strsum(8), strsum(1), 0.75, k)
strsum(7) = calduoping(strsum(8), strsum(1), 0.95, k)
'向CHART控件赋值
arrChartData(i, 1) = strsum(3)
arrChartData(i, 2) = strsum(4)
arrChartData(i, 3) = strsum(5)
arrChartData(i, 4) = strsum(6)
arrChartData(i, 5) = strsum(7)
Chart.ChartData = arrChartData
'表格显示
With mfgrid
.Row = i
For h = 0 To 7
.Col = h
.Text = Format(strsum(h), "0.00")
Next h
End With
i = i + 1
Rst1.MoveNext
Loop
'写CHART右边系列标签
Chart.RowCount = j
Chart.ColumnLabelCount = j
Rst1.MoveFirst
For i = 1 To j
Chart.Row = i
Chart.RowLabel = Rst1.Fields(1)
Rst1.MoveNext
Next i
'写CHART横坐标
Chart.ColumnCount = 5
For i = 1 To 5
Chart.Column = i
Chart.ColumnLabel = colfield(i + 2)
Next i
Chart.Refresh
End Sub
数据库控件卸载
Set Data1.Recordset = Nothing
九 ADO数据库编程
打开mdb数据库
设置: 在【工程】‖【引用】中选”MS Dao 2.5/3.51 Compatibility Library”
代码:
Public cnn1 As ADODB.Connection
Public rst1 As Recordset
Public rst2 As Recordset
Sub mdbopen()
Dim strcnn As String
Text2 = "panx.mdb"
Fpath2 = “C:\fxfx\pan\”
strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _
"Data Source=" & Fpath2 & Text2
Set cnn1 = New ADODB.Connection
cnn1.Open strcnn
End Sub
打开dbf数据库
设置: 在【工程】‖【引用】中选”MS Dao 2.5/3.51 Compatibility Library”
代码:
Public cnn2 As ADODB.Connection
Public rst1 As Recordset
Public rst2 As Recordset
Sub dbfopen()
Dim strcnn As String
Fpath2 = “C:\fxfx\pan\”
strcnn = "Provider=MSDASQL.1;Persist Security Info=False;" & _
"Data Source=FoxPro Files; Initial Catalog=" & fpath2
Set cnn2 = New ADODB.Connection
cnn2.Open strcnn
End Sub
