使用静态变量
放置控件: Form1:Label1,Command1
属性设置: cLabel1.Autosize= true
代码:
Private Sub Command1_Click()
Static stflag As Boolean '使用静态变量来保存变量值
If stflag = False Then
Label1.Font.Size = 14
stflag = True
Else
Label1.Font.Size = 9
stflag = False
End If
End Sub
创建对象
放置控件: Form1:Command1,text1
代码:
Private Sub Command1_Click()
Dim t1 As TextBox
Set t1 = Form1.Text1
If t1.Text = 0 Then
t1.BackColor = 0
t1.ForeColor = 255
End If
End Sub
运行时，只要在Text1中写入0，点击Command1，Text1框就变色了。
如不用t1对象，则程序中t1.BackColor要写成form1.text1.BackColor，比较麻烦。
自定义方法和属性
放置控件: Form1:Command1,text1
代码:
Public tsize As Integer '定义属性
Public Sub textlarge()
'定义方法
Text1.Width = Text1.Width * 1.1
Text1.Height = Text1.Height * 1.1
Text1.FontSize = Text1.FontSize + tsize
End Sub
Private Sub Command1_Click()
Form1.tsize = 4
Form1.textlarge
End Sub
遍历控件集合
放置控件: Form1:Label1,Command1,text1,list1
代码:
Private Sub Form_Load()
Dim myc1 As Control
For Each myc1 In Controls
List1.AddItem myc1.Name
Next myc1
End Sub
集合寻址
放置控件: Form1:Label1,Command1,text1,list1
代码:
Private Sub Command1_Click()
Text1 = Controls(3).Left
'Text1 = Controls("label1").Left
'Text1 = Controls!label1.Left
End Sub
代码换行和并行
变量：
a1 = 2: a2 = 3: a3 = 4 '并行
b1 = a1 + a2 + _
'换行
a3
对于字符串：
s1 = “sadd” & c1 & “qwer”
'联接
s1 = “sadd” & c1 & “qwer” & _ '换行
“fjkgjgj06”
打印和显示换行
s1 = ”fjdkkjd” & vbcrlf & “iioknno”
强迫变量声明
Option Explicit
还可以在菜单【工具】‖【选项】(编辑器)中选[要求变量声明]，自动在每个模块上加Option Explicit
查找字符串显示长度
Public Function len1(str As String) As Integer ‘公用函数
Dim si, i As Integer
Dim str1 As String
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
‘汉字长度为2
Else
si = si + 1
End If
Next
len1 = si
End Function
截取字符串定长
Public Function len2(s2 As String, si As Integer) As String
Do While len1(s2) > si
s2 = Mid(s2, 1, Len(s2) - 1)
Loop
len2 = s2
End Function
截取并补齐定长字符串
Public Function len3(s2 As String, si As Integer) As String
If len1(s2) > si Then
Do While len1(s2) > si
s2 = Mid(s2, 1, Len(s2) - 1) ‘长了截断
Loop
Else
Do While len1(s2) < si
s2 = s2 & " " ‘短了用空格补齐
Loop
End If
len3 = s2
End Function
模糊查找
Sub shumlook(ByVal shu2 As String)
Dim shu3 As String
shu3 = Mid(shu3, 1, Len(shu2))
If shu3 = shu2 Then
End if
End Sub
清除字符串的所有空格
Function Trimk(cc0)
Dim i, j, s1
j = Len(cc0)
i = 1
While i < j + 1
s1 = Mid(cc0, i, 1)
'MsgBox "s1=" & s1 & ";"
If s1 = " " Or s1 = " " Then
cc0 = Mid(cc0, 1, i - 1) + Mid(cc0, i + 1, j)
i = i - 1
'MsgBox "cc0=" & cc0
End If
i = i + 1
Wend
Trimk = cc0
End Function
读取当前日期和时间
放置控件: Form1:Text1,Text2，Command1
代码:
Private Sub Command1_Click()
Dim d1 As Date
d1 = Date
Text1 = d1
'显示如00-6-24
d1 = Time
Text2 = d1
'显示如10:30:23
End Sub
输入日期并计算
放置控件: Form1:Text1,Text2，Command1
代码:
Private Sub Command1_Click()
Dim d1 As Date
d1 = Text1
d1 = d1 - 100
Text2 = d1
Text1 = Weekday(d1)
End Sub
运行时先在Text1中输入日期(如00-5-30)，再点击Command1，则在Text2中显示输入日期100天前的日期，并在Text1中显示该日期为星期几。
返回年、月、日、时、分、秒的函数为year,month,day,hour,minute,second。
注意Weekday返回1代表星期天，2代表星期一，7代表星期六。
初始化事件和终止事件
当调用一个窗体时，一般首先引发initialize事件，再引发load事件。但只是引用窗体上数据或过程时，可能不引发load事件。只有当调用控件时，才引发load。
当终止窗体时，先引发unload事件，再引发terminate事件。但只用unload form1时，并不能引发terminate事件，这时窗体中的过程和变量仍然可以引用。只有用set form1=nothing才能引发ternimate事件。
不定长数组
先定义数组Dim array1 ( )
使用时再用ReDim ( 3, 9 )
或 ReDim (1 to 3, 1 to 9 )
用FORMAT决定数据格式
1．日期和时间
以系统设置的长日期格式返回当前系统日期。
Print Format(Date, "Long Date")
‘返回2001年10月29日
MyStr = Format(MyTime, "h:m:s")
' 返回 "17:4:23"。
MyStr = Format(MyTime, "hh:mm:ss AMPM")
' 返回 "05:04:23 PM"。
MyStr = Format(MyDate, "dddd, mmm d yyyy")
' 返回 "Wednesday, Jan 27 1993"。
2．数字
MyStr = Format(5459.4, "##,##0.00")
' 返回 "5,459.40"。
MyStr = Format(334.9, "###0.00")
' 返回 "334.90"。
MyStr = Format(0.5, "0.00%")
' 返回 "50.00%"。
简化：如aa = 1235432 / 3
Print Format(aa, "0.000")
‘返回411810.667
整数：Print Format(123, "00000")
‘返回00123
3.字符
小写：MyStr = Format("HELLO", "<")
' 返回 "hello"。
大写：MyStr = Format("This is it", ">")
' 返回 "THIS IS IT"。
如果没有指定格式，则返回原字符串。
MyStr = Format(23)
' 返回 "23"。
记录变量
先在模块（如Module1）中定义：
Type QipuRec
qx As Integer
qy As Integer
qColor As string
End Type
再在Form1中添加：
Dim QiShu(1 To 400) As QipuRec
就可以引用QiShu.qx，QiShu.qy了。
二 常用控件
调用不同的Form
放置控件: Form1:Command1,Command2; Form2:Command1
属性设置: 〖Form1.Command1.Caption〗= 进入Form2
〖Form1.Command2.Caption〗= 退出
〖Form2.Command1.Caption〗= 返回Form1
Form1代码:
Private Sub Command1_Click()
Form2.Show
End Sub
Private Sub Command2_Click()
End
End Sub
Form2代码
Private Sub Command1_Click()
Form2.Hide
Form1.Show
End Sub
用OptionButton单选
放置控件: Form1:Option1,Option2,Option3,Label1
属性设置: 〖Option1.Caption〗=BASIC
〖Option2.Caption〗=PASCAL
〖Option3.Caption〗=C
代码:
Private Sub Option1_Click()
Label1.Caption="BASIC"
End Sub
Private Sub Option2_Click()
Label1.Caption="PASCAL"
End Sub
Private Sub Option3_Click()
Label1.Caption="C"
End Sub
用Check复选
放置控件: Form1:Text1,Check1,Check2
属性设置: 〖Text1.text〗=字体演示
代码:
Private Sub Check1_Click()
If Check1.Value＝1 then
'选中
Text1.FontSize＝14
'字体为14号,大字
Else
'取消
Text1.FontSize=9 '字体为9号,普通字
End If
End Sub
Private Sub Check2_Click()
If Check2.Value=1 then
Text1.FontItalic=True '设斜体
Else
Text1.FontItalic=False '恢复正常
End If
End Sub
选择ComboBox表值
放置控件: Form1:Combo1(ComboBox)
代码:
Private Sub Combo1_Click()
s1 = Combo1.Text
Print "您选中的是: ";s1
End Sub
Private Sub Form_Load()
Combo1.AddItem "初中"
Combo1.AddItem "高中"
Combo1.AddItem "大学"
End Sub
ListBox从程序赋值
放置控件: Form1:list1(ListBox),label1
代码:
Private Sub Form_Load()
List1.AddItem "a1"
'用AddItem方法赋值
List1.AddItem "a2"
List1.AddItem "a3"
End Sub
Private Sub List1_Click()
Select Case List1.ListIndex
'ListIndex值为0,1,2
Case 0: Label1.Caption = "ok1"
Case 1: Label1.Caption = "ok2"
Case 2: Label1.Caption = "ok3"
End Select
End Sub
使用MsgBox双向选择
放置控件: Form1:Command1
属性设置:〖Command1.Caption〗=Exit
代码:
Private Sub Command1_Click()
myexit = MsgBox("确实想退出吗?", VbOkCancel, "退出")
If myexit = VbOk Then
Unload Me
Else
Debug.Print “放弃退出”
End If
End Sub
用InputBox输入数值
放置控件: Form1:Command1
属性设置:〖Command1.Caption〗=开始
代码:
Private Sub Command1_Click()
Dim string1 As String
Dim int1 As Integer
string1 = InputBox("Input")
int1 = Val(string1)
'可直接用int1 = Val(InputBox("input"))
Print "int1="; int1
End Sub
复杂InputBox输入
Private Sub Command1_Click()
qs = 1.2
qs1 = 1.2
ts1 = "2001-2002年乡及乡以上工业增长" & qs & "%，修改后按‘确定’"
s1 = Val(InputBox(ts1, "计算修改", qs1))
If s1 <> "" And s1 <> "0" Then
MsgBox "2002年乡及乡以上工业用水=" & s1 * 123 & "亿立方米。"
Else
MsgBox "放弃修改。"
End If
End Sub
用Timer作定时器
放置控件: Form1:Text1,Timer1
属性设置: 〖Timer1.Interval〗=1000 '1000ms
代码:
Private Sub Timer1_Timer()
If Text1.Text <> "10:02:00" Then
Text1.Text = Time
Else
'时间到
Text1.Text = "OK"
Timer1.Enabled = False '不再显示时间
End If
End Sub
用Timer编制延时程序
放置控件: Form1:Command1,Timer1
属性设置: 〖Timer1.Interval〗=10 '10ms
代码:
Sub delay(ss As Integer)
'延时过程
Dim start, check
start = Timer
Do
check = Timer
Loop While check < start + ss * 0.001
End Sub
Private Sub Command1_Click()
Command1.Caption = "test1"
delay (1000)
Command1.Caption = "test2"
delay (2000)
Unload Me
'退出
End Sub
使用File控件
Private Sub Form_Load()
File1.Pattern = “*.txt”
File1.Path = “C:/fxfx/kfb”
End Sub
如果使用目录列表控件Dir1，则可以用
File1.Path = Dir1
接可以联动使用。
使用COMMONDIALOG控件
在部件的控件中打开Microsoft Common Dialog Control 6.0 (SP)，再添加CommonDialog1、Command1和Text1控件。运行时打开文件对话框，并将选中的文件显示在文本框中。
Private Sub Command1_Click()
On Error GoTo errhandler
CommonDialog1.Filter = "All Files(*.*)|*.*|Text Files(*.txt)|*.txt"
CommonDialog1.FilterIndex = 1 ‘缺省为All Files
CommonDialog1.ShowOpen
Text1 = CommonDialog1.FileName
Exit Sub
errhandler:
Exit Sub
End Sub
CommonDialog控件还可以显示颜色对话框（CommonDialog1.showcolor），字体对话框（CommonDialog1.showfont），打印对话框（CommonDialog1.printer），显示帮助对话框（用CommonDialog1.HelpFile=”C:/Windows/Cadio.hlp”设置，用CommonDialog1.ShowHelp调用）。
取消窗体的按钮组
Form1.ControlBox = False
使用Microsoft Flex Grid 6.0控件绑定数据库
直接添加后设置即可；
运行时动态改变控件数组
先在FORM中添加一个COMBO控件，再复制一个成为控件数组，把COMBO1（1）删除，再把COMBO1（0）移到左上角，添加一个COMMAND在右边，编码如下：
Private Sub Command1_Click()
Unload Combo1(5)
‘去掉一个控件
End Sub
Private Sub Form_Load()
c1y = 600
For i = 1 To 5
‘增加一组控件
Load Combo1(i)
Combo1(i).Top = c1y
Combo1(i).Left = 100
c1y = c1y + 500
Combo1(i).Visible = True
Next
End Sub
StatusBar使用
在部件的控件中打开Microsoft Common Dialog Control 6.0 (SP)，再添加Statusbar控件。右击添加窗格，并调整宽度。
添加文字时程序为：
StatusBar1.Panels(1).text = "比例 1 : " & Format$(sbScaleBar1.RFScale, "###,###,###,###,###")
VbModal调用方式
采用VbModal方式调用FORM，可以在其运行完成后在执行下一语句，如：
frmTip.Show vbModal
MsgBox TipType
如果在frmTip中设定TipType=100，则可以显示出这个值来。
ProgressBar的使用
在部件的控件中打开Microsoft Windows Common Control 6.0，再添加ProgressBar控件。
编程时，要先设ProgressBar1.Max（一般为最大循环数加1）和ProgressBar1.Min（一般为0），再在循环中加上一个和循环数同步的变量，如si，再用
ProgressBar1.Value = si
就可以实现进程条的结果了。
在FOR循环中的例子为：
Private Sub Command1_Click()
Dim i As Long
Dim j As Long
Dim si As Long
si = 0
ProgressBar1.Max = 10001
ProgressBar1.Min = 0
For i = 0 To 10000
For j = 0 To 1000
a = "sdf"
Next j
si = si + 1
ProgressBar1.Value = si
Next i
MsgBox "end"
End Sub
在数据库操作中的例子为：
ProgressBar1.Max = ri + 1
‘ri为全部记录数；
ProgressBar1.Min = 0
Rst2.MoveFirst
While Not Rst2.EOF
……
rj = rj + 1
ProgressBar1.Value = rj
Wend
三 控件编程基本方法
控件输入位置和聚焦
放置控件: Form1:Text1,Command1
代码:
Private Sub Command1_Click()
Text1.SelStart = 3 '光标在第3个位置
Text1.SetFocus
'使焦点回到Text1
End Sub
使用容器控件
容器控件有：Frame，PictureBox和ToolBar。
使用容器控件包容其它控件的方法有：
1．先产生容器控件，在其上画其它控件；
2．把已有控件剪贴到容器控件上；
3．用程序 Command1.Container = Frame1
用一键来回设置
放置控件: Form1:Command1,List1
代码:
Private Sub Command1_Click()
If Bzl then
List1.Visible = True
Command1.Cption = “Exit”
Bzl = false
Else
List1.Visible = False
Command1.Caption = “Display”
Bzl = True
End If
End Sub
Private Sub Form_Load()
Bzl = Ture
List1.Visiblae = False
Command1.Caption = “Display”
End Sub
列表控件的选择属性
以List1 的属性为例，列表类控件如List,Combo,File,Dir等均可使用：
1．选中第I项
List1.Selected(i) （True）
2．返回第I项内容
List1.List(i)
3．返回列表总项数
List1.ListCount
4．返回最近一次点击位置 List1.ListIndex
注意：I均从零开始。
列表控件的全选
For i = 0 To File1.ListCount - 1
File1.Selected(i) = True
Next
列表控件的部份选择
Dim fscount, i, j
Dim fs1(100) As String
j = 0
For i = 0 To File1.ListCount - 1
If File1.Selected(i) Then
fs1(j) = File1.List(i)
j = j + 1
End If
Next
fscount = j
使用TreeView控件产生目录
在【部件】中选择“Microsoft Windows Common Control 6.0（SP3）”，就可以打开一组控件，有Tabstrip、Toolbar、Statusbar、Progressbar、Treeview、Listview、Imagelist、Slider、Imagecombo。
把Treeview1和Imagelist1加入窗体；
右击Imagelist1，打开属性页，添加图形；
右击Treeview1，打开属性页，在【图像列表】中选择Imagelist1，还可以改变自目录的缩进；
改变Treeview1属性Linestyle为1；
添加代码：
Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)
Select Case Node.Key
Case "fx1"
Hyperlink.NavigateTo ("http://b4x5d1/faexcise/fa1/default1.asp")
Case "fx2"
Hyperlink.NavigateTo ("http://b4x5d1/faexcise/fa1/create1.asp")
End Select
End Sub
Private Sub UserDocument_Initialize()
Dim mynode As Node
Set mynode = TreeView1.Nodes.Add(, , "fx", "发行系统", 2)
Set mynode = TreeView1.Nodes.Add(, , "cb", "出版系统", 2)
Set mynode = TreeView1.Nodes.Add(, , "cw", "财务系统", 2)
Set mynode = TreeView1.Nodes.Add(, , "bw", "编务系统", 2)
Set mynode = TreeView1.Nodes.Add(, , "xt", "系统管理", 2)
'二级目录
Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx1", "批销", 3)
Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx2", "样书", 3)
Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx3", "发行管理", 3)
Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx4", "查询", 3)
mynode.EnsureVisible
End Sub
四 错误处理
使用监视窗口调试的例子
放置控件: Form1:Command1
属性设置: 〖Command1.Caption〗=开始计算
代码:
Private Sub Command1_Click()
n = 4
'm = 1
For i = 1 To n
m = m * i
Next i
Print "m="; m
End Sub
选【调试】‖【添加监视】进入后，在【表达式】中写入ｍ，然后点击【确定】。这时屏幕下方出现了含有ｍ的监视窗口。再重复以上过程，把n也加入到监视窗口。
按F8键进行单步调试（即每按一下F8运行一行），逐步检查监视窗口的变量变化。点击【Command1】后，再按F8继续运行。如果屏幕下部先出现【立即】窗口，则把它关掉，再从菜单上选取【窗口】‖【监视窗口】把监视窗口调出来。
用InputBox输入数值时的错误处理
发生错误时继续调用InputBox，直到正确。
Private Sub Command1_Click()
Dim s11 As Integer
Dim s2 As String
On Error GoTo head
head1:
s2 = InputBox("请输入单价:")
If s2 <> "" Then
s11 = s2
End If
Exit Sub
head:
MsgBox "输入错！请重新输入"
Resume head1
End Sub
用Resume Next处理错误
发生错误时退出Command1.
Private Sub Command1_Click()
Dim s11 as Integer
Dim s2 As String
On Error GoTo head
s2 = InputBox("请输入单价:")
If s2 <> "" Then
s11 = s2
End If
Exit Sub
head:
MsgBox "输入错！请重新输入"
Resume Next
End Sub
用Text控件输入数值时的错误处理
Private Sub Command1_Click()
Dim i1 As Integer
On Error GoTo handle
i1 = Text1
MsgBox "输入正确,i1=" & i1
Exit Sub
handle:
MsgBox "输入错误!"
Text1 = ""
Exit Sub
End Sub
Private Sub Form_Load()
Text1 = ""
End Sub
用输入窗体时的错误处理
放置控件: Form1:Command1, Form2:Command1,Text1,Module1
Module1代码:
Public i1 As Integer
Form1代码:
Private Sub Command1_Click()
Form2.Show vbModal
MsgBox "输入完成,i1=" & i1
End Sub
Form2代码:
Private Sub Command1_Click()
On Error GoTo handle
i1 = Text1
MsgBox "输入正确,i1=" & i1
Unload Me
Exit Sub
handle:
MsgBox "输入错误!"
Text1 = ""
Exit Sub
End Sub
Private Sub Form_Load()
Text1 = ""
End Sub
显示错误信息
On Error Resume Next
' 改变错误处理的方式。
Err.Clear
Err.Raise 6
' 生成一个溢出（Overflow）的错误。
' 检查错误代号，显示相关错误信息。
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.Helpfile, Err.HelpContext
End If
五 打印
用Currentx、y指定Print位置
放置控件: Form1:Command1,command2,text1
代码:
Dim g1, g2 As Integer
Private Sub Command1_Click()
g1 = g1 + 200
Cwrite
End Sub
Private Sub Command2_Click()
g2 = g2 + 200
Cwrite
End Sub
Sub Cwrite()
Cls
'清除上次字符串
CurrentX = g1
CurrentY = g2
Print "Position test."
End Sub
用Printer方法编程打印
1．设页面坐标
pw = 400: ph = 650
Printer.Scale (0, 0)-(pw, ph)
注：以上设置只能设页面坐标，不能设置页面大小。要设置页面大小到Windows/打印机/属性/中去设置。对于标准连续打印纸，设Letter。
2．设字体
Printer.FontName = “黑体”
Printer.FontSize = 10
'5号字
Printer.FontBold = True
'粗体
3．打印位置
Printer.CurrentX = 110
Printer.CurrentY = 30
4．打印数据
Printer.Print "中国水利水电出版社入库单"
Printer.Print "单号: " & tnum
5．画表格线
Printer.DrawWidth = 3
'线宽
Printer.Line (20,20) – (300,300)
6．打印份数
Printer.Copies = 2
7．换页
Printer.NewPage
8．打印开始
Printer.EndDoc
注意:只要使用Printer方法，不管是否用Printer.EndDoc，程序运行完时均要打印。
改变页面位置
如用
Printer.Scale (0, 0)-(pw, ph)
增大左边界
Printer.Scale (-50, 0)-(pw, ph)
整体左移
Printer.Scale (-50, 0)-(pw-50, ph)
增大上边界
Printer.Scale (0, -50)-(pw, ph)
增大下边界
Printer.Scale (0, 0)-(pw, ph+50)
整体下移
Printer.Scale (0, -50)-(pw, ph-50)
直接用printer打印表格
Private Sub cmdprint_Click()
Dim n As Integer
Dim rs As New ADODB.Recordset
rs.Open "SELECT * FROM jggz", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:/jggz/jggz.mdb;Persist Security Info=False", adOpenStatic, adLockPessimistic
n = 0
rs.MoveFirst
Form1.Print "┌────┬────┐"
While Not rs.EOF
Printer.Print "│" & rs.Fields("姓名").Value; Tab(11); "│"; rs.Fields("课时工资"); Tab(21); "│"
rs.MoveNext
n = n + 1
If n / 5 = Int(n / 5) Or rs.EOF Then
Printer.Print "└────┴────┘"
Printer.Print "┌────┬────┐"
Else
Printer.Print "├────┼────┤"
End If
Wend
Printer.Print "└────┴────┘"
rs.Close
End Sub
附件1：制表符号区位对照
区位
0904 0906 0916 0920 0924 0940 0948
符号
─
│
┌
┐
└
┤
┬
区位
0956 0964 0905 0907 0919 0931 0939
符号
┴
┼
━
┃
┏
┛
┣
区位
0947 0955 0963 0979 0936 0959
符号
┫
┳
┻
╋
┠
┷
六 绘图
使用Pset画点
放置控件: Form1:Command1
属性设置: 〖Command1.Caption〗=开始
代码:
Private Sub Command1_Click()
Const pi = 3.14159
Dim x0, y0 As Single
Dim x1, y1 As Integer
x0 = 0
Do While x0 <= 4 * pi
'画两个相位
y0 = Sin(x0)
x1 = x0 * 400 '放大400倍
y1 = y0 * 400 + 1000
PSet (x1, y1) '画点
x0 = x0 + 0.01 '步长为0.01
Loop
End Sub
使用Line画线
放置控件: Form1:Command1
属性设置: 〖Command1.Caption〗=开始画图
代码:
Private Sub Command1_Click()
Line (100, 100)-(1000, 1000)
Line -(0, 500)
'第一点缺省采用当前点，即（1000，1000）
Line -(100, 100)
'完成一个三角形
End Sub
使用Line擦除线段
放置控件: Form1:Command1,Command2
属性设置: 〖Command1.Caption〗=画线,〖Command2.Caption〗=擦除
代码:
Private Sub Command1_Click()
DrawMode = 1
Line (0, 0)-(1000, 1000)
End Sub
Private Sub Command2_Click()
DrawMode = 7
Line (0, 0)-(1000, 1000), BackColor
End Sub
使用Circle画弧
放置控件: Form1:Command1
属性设置: 〖Command1.Caption〗=开始画图
代码:
Private Sub Command1_Click()
Const Pi = 3.1416
Circle (1000, 1000), 500, , 0, Pi '画一个从0度到π(180)度的弧
End Sub
用鼠标画园饼并擦除
放置控件: Form1
代码:
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static x0, y0 As Integer
'保存上一个鼠标位置的参数
FillStyle = 0
'设置填充模式
Circle (x0, y0), 200, BackColor '擦除上一个园饼
Refresh
'重画
DrawMode = 1
'绘图方式还原
Circle (X, Y), 200
x0 = X
'保存当前鼠标位置
y0 = Y
DrawMode = 7
'使用XOR绘图方式准备擦图
End Sub
如果要在已有背景上擦除，用以下程序：
Private Sub Command1_Click()
DrawMode = 1
Line (0, 0)-(1000, 1000)
End Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Static x0, y0 As Integer
'保存上一个鼠标位置的参数
FillStyle = 0
'设置填充模式
DrawMode = 7
'使用XOR绘图方式准备擦图
Circle (x0, y0), 200, BackColor '擦除上一个园饼
Refresh
'重画
Command1_Click
DrawMode = 1
'绘图方式还原
Circle (X, Y), 200
x0 = X
'保存当前鼠标位置
y0 = Y
End Sub
用PictureBox做简单的动画
放置控件: Form1:Picture1,Picture2,Picture3,Command1,timer1
属性设置: 〖Picture1.Autosize〗=true,〖Picture1.Picture〗=bfly1.bmp
〖Picture2.Autosize〗=true,〖Picture2.Picture〗=bfly2.bmp
〖Picture3.Autosize〗=true
〖Command1.Caption〗=开始
〖timer1.Interval〗=10
注意:bmp文件从c:/program files/microsoft visual/msdn98/98vs/vcr/选取
代码:
Option Explicit
Sub delay(ss As Integer)
'延时程序,ss单位为毫秒(ms)
Dim start, check
start = Timer
Do
check = Timer
Loop While check < start + ss * 0.001
End Sub
Private Sub Command1_Click()
Dim i As Integer
For i = 1 To 10
'蝴蝶扇动10下翅膀
Picture3.Picture = Picture1.Picture '显示图1
delay (100) '延时100毫秒
Picture3.Picture = Picture2.Picture '显示图2
delay (100)
Next i
End Sub
用PictureBox做动画(用DoEvents中断)
放置控件: Form1:P1,P2,P3(PictureBox),Command1,Command2,timer1
属性设置: 〖P1.Autosize〗=true,〖P1.Picture〗=bfly1.bmp
〖P2.Autosize〗=true,〖P2.Picture〗=bfly2.bmp
〖P3.Autosize〗=true
〖Command1.Caption〗=开始
〖Command2.Caption〗=退出,〖Command2.Visible〗=False
〖timer1.Interval〗=10
〖Form1.BackColor〗=白
'从调色板上选取
注意:bmp文件从c:/program files/microsoft visual/msdn98/98vs/vcr/选取
代码:
Option Explicit
Sub delay(ss As Integer)
Dim start, check
start = Timer
Do
check = Timer
Loop While check < start + ss * 0.001
End Sub
Sub flying()
'飞翔过程
Const d1 = 30
P3.Picture = P1.Picture
delay (d1)
P3.Picture = P2.Picture
delay (d1)
End Sub
Private Sub Command1_Click()
Dim mx0, my0 As Integer
'随机产生的x,y方向的步长
Dim mx, my As Integer
'转换方向后的步长
Dim k As Integer
'步长系数
Dim bl As Integer
'中断检测计数
k = 400
mx0 = k * Rnd: my0 = k * Rnd '赋初始值
mx = mx0: my = my0
Do
Command1.Visible = False
If P3.Left < 0 Then '如果碰到左边界
mx0 = k * Rnd: my0 = k * Rnd '向右飞
mx = mx0: my = 2 * (my0 - k / 2)
End If
If P3.Left > Form1.Width - P3.Width Then '如果碰到右边界
mx0 = k * Rnd: my0 = k * Rnd '向左飞
mx = -mx0: my = 2 * (my0 - k / 2)
End If
If P3.Top < 0 Then '如果碰到上边界
mx0 = k * Rnd: my0 = k * Rnd '向下飞
mx = 2 * (mx0 - k / 2): my = my0
End If
If P3.Top > Form1.Height - P3.Height Then '如果碰到下边界
mx0 = k * Rnd: my0 = k * Rnd '向上飞
mx = 2 * (mx0 - k / 2): my = -my0
End If
P3.Picture = LoadPicture '清除上一幅图
P3.Move P3.Left + mx, P3.Top + my '按设定的步长移动
flying '调用飞翔过程
Form1.Refresh '重画
bl = bl + 1 '中断程序
If bl > 100 Then '设飞动100次中断1次
Command2.Visible = True '显示"退出"按钮
Refresh
delay (3000) '停3秒等待用户点击"退出"按钮
DoEvents '中断处理
Command2.Visible = False '如用户没有选退出,再将按钮隐藏
bl = 0 '重新计数
End If
Loop Until 1 = 2
'无限循环
End Sub
Private Sub Command2_Click()
End
End Sub
用Image做复杂一点的动画
放置控件: Form1:P1,P2,P3(Image),Command1,timer1
属性设置: 〖P1.Stretch〗=true,〖P1.Picture〗=bfly1.bmp
〖P2.Stretch〗=true,〖P2.Picture〗=bfly2.bmp
〖P3.Stretch〗=true
〖timer1.Interval〗=10
〖Form1.BackColor〗=白
'从调色板上选取
注意:bmp文件从c:/program files/microsoft visual/msdn98/98vs/vcr/选取
代码:
Option Explicit
'强制变量说明
Dim mx0, my0 As Integer
'随机产生的x,y方向的步长
Dim mx, my As Integer
'转换方向后的步长
Dim k As Integer
'步长系数
Dim doflag As Boolean
'检测Command1的Click的标记
Sub delay(ss As Integer)
'延时过程
Dim start, check
start = Timer
Do
check = Timer
Loop While check < start + ss * 0.001
End Sub
Sub flying()
'飞翔过程
Const d1 = 40
p3.Picture = LoadPicture
'清除上一幅图
p3.Move p3.Left + mx, p3.Top + my '按设定的步长移动
p3.Picture = p1.Picture
'显示第一幅图
Refresh
delay (d1 * 3)
p3.Picture = p2.Picture
'显示第二幅图
Refresh
delay (d1)
End Sub
Sub fly_direction()
If p3.Left < 0 Then
'如果碰到左边界
mx0 = k * Rnd: my0 = k * Rnd '向右随机方向飞
mx = mx0: my = 2 * (my0 - k / 2)
End If
If p3.Left > Form1.Width - p3.Width Then '如果碰到右边界
mx0 = k * Rnd: my0 = k * Rnd '向左随机方向飞
mx = -mx0: my = 2 * (my0 - k / 2)
End If
If p3.Top < 0 Then
'如果碰到上边界
mx0 = k * Rnd: my0 = k * Rnd '向下随机方向飞
mx = 2 * (mx0 - k / 2): my = my0
End If
If p3.Top > Form1.Height - p3.Height Then '如果碰到下边界
mx0 = k * Rnd: my0 = k * Rnd '向上随机方向飞
mx = 2 * (mx0 - k / 2): my = -my0
End If
flying
'调用飞翔过程
End Sub
Private Sub Command1_Click()
Select Case doflag
Case True
Command1.Caption = "开始"
doflag = False
Cls
Case False
Command1.Caption = "停止"
doflag = True
mx0 = k * Rnd: my0 = k * Rnd '赋初始值
mx = mx0: my = my0
End Select
End Sub
Private Sub Form_Load()
k = 600
doflag = False
End Sub
Private Sub Timer1_Timer() '时钟控件随时检测,如果没有点击
If doflag Then
'Command1(停止),则继续调用动画程序
fly_direction
End If
End Sub
七 报表
用数据库控件产生简单的数据报表
放置控件: Form1:Data1,Command1
属性设置: 〖Data1.DatabseName〗="Nwind.mdb",〖Data1.Recordsource〗=categories
说明:1.Data1中可设置任何普通数据库
2.输出报表到一个.txt文件,可以在WORD或其它编辑软件中编辑.
3.编辑时设行距为零(WORD中设固定值=10磅).
代码:
Option Explicit
Dim f1 As Field
'字段变量
Dim fi As Integer
'字段数
Dim pagerow As Integer
'每页行数
Dim rptcaption As String
'报表标题字符串
Dim repage As Integer
'报表页数
Dim repfield() As Integer
'字段宽度数组
Dim maxwidth as integer
'最大字段宽度
Dim repwidth As Integer
'报表总宽
Dim leftspace As Integer
'报表左边起始位置
Dim chi As Integer
'中文字符数
Function len1(str1 As String) As Integer
'返回字符串绝对长度(如len1("你好!")=5)
Dim l1 As String
Dim i, ln1 As Integer
len1 = 0
For i = 1 To Len(str1)
l1 = Mid$(str1, i, 1)
If Asc(l1) < 0 Then '中文字符
ln1 = 2
Else
ln1 = 1
End If
len1 = len1 + ln1
Next i
End Function
Sub CreateRptField()
'比较字段名和字段长度,决定字段宽度并计算报表总宽
ReDim repfield(fi) As Integer
'使用变长数组
Dim fname, fsize As Integer
Dim fi1 As Integer
repwidth = leftspace + 2
For fi1 = 0 To fi - 1
Set f1 = Data1.Recordset.Fields(fi1)
fname = Int((len1(f1.Name) + 1) / 2 + 0.5) * 2
fsize = Int((f1.Size + 1) / 2 + 0.5) * 2
If fsize > maxwidth Then fsize = maxwidth '限定字段宽度
If fname > fsize Then
repfield(fi1) = fname
Else
repfield(fi1) = fsize
End If
repwidth = repwidth + repfield(fi1) + 2
Next fi1
End Sub
Sub repline(str1, str2, str3, str4 As String) '打印表线
Dim fi1, fi2 As Integer
Dim rl As Integer
For fi1 = 1 To leftspace
Print #1, " ";
Next fi1
Print #1, str1;
For fi2 = 1 To Int(repfield(0) / 2)
Print #1, str2;
Next fi2
For fi1 = 1 To fi - 1
Print #1, str3;
For fi2 = 1 To Int(repfield(fi1) / 2)
Print #1, str2;
Next fi2
Next fi1
Print #1, str4
End Sub
Sub rptheadline(str1 As String)
'打印标题和页码
Dim start, fi1 As Integer
Print #1,
If Int(repwidth / 2) - Int(len1(str1) / 2) > 10 + leftspace Then
start = Int(repwidth / 2) - Int(len1(str1) / 2) + leftspace
For fi1 = 1 To start
Print #1, " ";
Next fi1
Print #1, str1, " -"; repage; "-"
Else
For fi1 = 1 To leftspace
Print #1, " ";
Next fi1
Print #1, str1, " -"; repage; "-"
End If
Print #1,
End Sub
Function leftstr(str1 As String, fsize As Integer) As String
'返回字符串str1左边fsize(绝对长度)长子串
If len1(str1) <= fsize Then
leftstr = str1
Else
Do While len1(str1) > fsize
str1 = Left$(str1, Len(str1) - 1)
Loop
leftstr = str1
End If
End Function
Function checkfield(str1 As Variant, int1 As Integer) As String
'检查记录变量str1的类型,并使它的绝对长度不超过int1
Dim str2 As String
If IsNull(Data1.Recordset(f1.SourceField)) Then '处理空记录
checkfield = ""
ElseIf f1.Type = 11 Then
'处理binary类型记录
checkfield = ""
Else
str2 = str1 '强制转换为string
checkfield = leftstr(str2, int1)
End If
End Function
Sub rpthead()
'打印表头
Dim fi1, ti, chi As Integer
Call repline("┏", "━", "┳", "┓")
For fi1 = 1 To leftspace
Print #1, " ";
Next fi1
ti = leftspace + 1
For fi1 = 0 To fi - 1
Print #1, "┃";
Set f1 = Data1.Recordset.Fields(fi1) '取出当前字段
ti = ti + repfield(fi1) + 2
chi = len1(f1.SourceField) - Len(f1.SourceField) '设置打印变换
ti = ti - chi - 1 '设置打印变换
Print #1, f1.SourceField; Tab(ti); '打印当前字段名
Next fi1
Print #1, "┃"
Call repline("┣", "━", "╇", "┫")
End Sub
Sub rptrecord()
'打印记录行
Dim fi1, ti As Integer
Dim temp As String
'记录内容
For fi1 = 1 To leftspace
'以下先打印第一字段
Print #1, " ";
Next fi1
Print #1, "┃";
ti = leftspace + 3
Set f1 = Data1.Recordset.Fields(0)
'取出第一个字段
ti = ti + repfield(0)
temp = checkfield(Data1.Recordset(f1.SourceField), repfield(0))
chi = len1(temp) - Len(temp)
'设置打印变换
ti = ti - chi - 1
'设置打印变换
Print #1, temp; Tab(ti);
'打印记录内容
For fi1 = 1 To fi - 1
'以下打印其余字段
Print #1, "│";
Set f1 = Data1.Recordset.Fields(fi1)
ti = ti + repfield(fi1) + 2
temp = checkfield(Data1.Recordset(f1.SourceField), repfield(fi1))
chi = len1(temp) - Len(temp) '设置打印变换
ti = ti - chi - 1 '设置打印变换
Print #1, temp; Tab(ti);
Next fi1
Print #1, "┃"
End Sub
Sub repform()
'打印报表
Dim li As Integer
'报表行数变量
Dim pbl As Boolean
'表行类型标记
repage = 1
li = 1
pbl = True
Do While Not Data1.Recordset.EOF
If pbl Then '表行为起始行,要打印表头
Call rptheadline(rptcaption)
Call rpthead
pbl = False
Else '表行为普通记录
Call repline("┠", "─", "┼", "┨")
End If
Call rptrecord
li = li + 1
If li = pagerow Then '到达页尾
Call repline("┗", "━", "┷", "┛")
Print #1,
repage = repage + 1
li = 1
pbl = True '设置起始行标记
End If
Data1.Recordset.MoveNext '移动到下一记录
Loop
If Not pbl Then
'全报表完时打印表底线
Call repline("┗", "━", "┷", "┛")
Print #1,
End If
End Sub
Private Sub Command1_Click()
'主程序
Open "test.txt" For Output As #1
'打开报表文件
leftspace = 0
'设置报表左边距
fi = Data1.Recordset.Fields.Count
'找到当前记录集的字段数
Call CreateRptField
'决定每个字段宽度
rptcaption = "报 表 示 例"
'给出标题
maxwidth=10
'给出最大字段宽度
pagerow = 20
'给出每页行数
Call repform
'打印报表
Close #1
'关闭报表文件
End Sub
用数据库打印报表
放置控件: Form1:Command1,Command2
说明：读mdb数据库rst1打印表格，表格参数在daima数组中。
代码：
Option Explicit
Dim pw, ph '纸宽和纸高的坐标
Dim px, py
Dim ti
'报表字段数
Dim wh, ww '字宽和字高
Dim table1 '第一页表格开始高度
Dim daima(100, 3) as String
Sub finput()
ti = 7
daima(1, 1) = "序号"
daima(1, 2) = 6
'表格宽度
daima(1, 3) = "序号"
daima(2, 1) = "代码"
daima(2, 2) = 8
daima(2, 3) = "scode"
'字段名
daima(3, 1) = "库位号"
daima(3, 2) = 8
daima(3, 3) = "skwh"
daima(4, 1) = "书名"
daima(4, 2) = 36
daima(4, 3) = "sname"
daima(5, 1) = "单价"
daima(5, 2) = 8
daima(5, 3) = "sdanjia"
daima(6, 1) = "出版日期"
daima(6, 2) = 10
daima(6, 3) = "syear"
daima(7, 1) = "备注"
daima(7, 2) = 10
daima(7, 3) = "空白"
End Sub
Sub printhead()
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
Printer.Print "中国水利水电出版社业务清单"
table1 = 50
End Sub
Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)
Dim py1 As Integer
Dim pxm, pxi, px1, bi
Dim daim1, daim2 As String
pxm = 0
'计算报表宽度
For pxi = 1 To ti
pxm = pxm + daima(pxi, 2) * ww
Next
Printer.DrawWidth = 3
Printer.FontSize = 11
Printer.FontBold = True
py = pp1 + (pp3 + 2 - pp2) * wh
'计算报表高度
Printer.Line (0, pp1)-(pxm, pp1)
'打印边框
Printer.Line (pxm, pp1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, pp1)
Printer.DrawWidth = 1
'打印表头
px = 0
For pxi = 1 To ti
daim2 = daima(pxi, 1)
px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = pp1 + Int(0.2 * wh)
Printer.Print daima(pxi, 1) '打印字段名
px = px + daima(pxi, 2) * ww
Printer.Line (px, pp1)-(px, py) '打印竖线
Next
Printer.FontBold = False
py = pp1 + wh
For bi = pp2 To pp3
px = 0
For pxi = 1 To ti
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = daima(pxi, 3)
Select Case daim1
Case "序号": daim2 = bi
'打印序号
Case "空白": daim2 = ""
'打印空白字段
Case Else: daim2 = rst1(daim1)
End Select
Printer.Print len2(daim2, Int(daima(pxi, 2))) '打印字段内容
px = px + daima(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py) '打印横线
py = py + wh
rst1.MoveNext
Next bi
End Sub
Sub printfoot(pp1 As Integer, pp2 As Integer)
'打印页码
px = pw - 300: py = ph - 5 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & pp2 & "
当前页数:" & pp1
End Sub
Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Call printframe(p1, p2, p3)
Call printfoot(p4, p5)
End Sub
Sub printbody()
Dim page As Integer
'页码数
Dim pi As Integer
Dim p1y As Integer
'第一页记录数
Dim p2y As Integer
'第二页记录数
Dim table2
'第二页起始位置
p2y = 37
table2 = 20
table1 = table1 + wh
p1y = (ph - table1 - 100) / wh
rst1.MoveFirst
If bnum < p1y + 1 Then
Call printail(table1, 1, bnum, 1, 1) '只有一页
Else
page = Int(((bnum - p1y) / p2y) + 1.9999) '计算页码
Call printail(table1, 1, p1y, 1, page) '打印第一页
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页
Else
Printer.NewPage
Call printail(table2, p1y + 1, bnum, page, page) '打印最后一页
End If
End If
End Sub
Sub printp()
Dim sp
‘左边距
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
End Sub
Private Sub Command1_Click()
bnum = rst1.RecordCount
finput
printp
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim str1, strcnn
strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _
"Data Source=" & fpath1 & "shukux.mdb"
Set cnn2 = New ADODB.Connection
cnn2.Open strcnn
Set rst1 = New ADODB.Recordset
rst1.CursorType = adOpenKeyset
rst1.LockType = adLockOptimistic
rst1.Open "shu00", cnn2, , , adCmdTable
End Sub
用数据库转数组打印报表
放置控件: Form1:Command1,Command3
说明：读mdb数据库转数组打印表格，daima数组放表格参数,dai1数组放纪录参数。
代码：
Option Explicit
Dim pw, ph, px, py As Integer
Dim ti
'报表字段数
Dim wh, ww 'word height and width
Dim table1 '第一页表格起始位置
Dim dai1(400, 8) As String
Sub finput()
ti = 7
daima(1, 1) = "序号"
daima(1, 2) = 6
daima(1, 3) = 0
daima(2, 1) = "代码"
daima(2, 2) = 8
daima(2, 3) = 1
daima(3, 1) = "库位号"
daima(3, 2) = 8
daima(3, 3) = 2
daima(4, 1) = "书名"
daima(4, 2) = 36
daima(4, 3) = 3
daima(5, 1) = "单价"
daima(5, 2) = 8
daima(5, 3) = 4
daima(6, 1) = "出版日期"
daima(6, 2) = 10
daima(6, 3) = 5
daima(7, 1) = "备注"
daima(7, 2) = 10
daima(7, 3) = 6
End Sub
Sub finput2()
Dim di
di = 0
rst1.MoveFirst
Do While Not rst1.EOF
di = di + 1
dai1(di, 0) = di
dai1(di, 1) = rst1!scode
dai1(di, 2) = rst1!skwh
dai1(di, 3) = rst1!sname
dai1(di, 4) = rst1!sdanjia
dai1(di, 5) = rst1!syear
dai1(di, 6) = ""
rst1.MoveNext
Loop
End Sub
Sub printhead()
Dim x1, x2, x3
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
Printer.Print "中国水利水电出版社业务清单"
table1 = 50
clh = "k0405"
x1 = 20: x2 = 270: x3 = 520
Printer.CurrentX = x1: Printer.CurrentY = table1
Printer.FontSize = 9: Printer.FontBold = False
Printer.Print "处理单号: " & clh
Printer.CurrentX = x2: Printer.CurrentY = table1
Printer.Print "制单日期: 20" & Now
Printer.CurrentX = x3: Printer.CurrentY = table1
Printer.Print "制单人 : "
table1 = table1 + wh
End Sub
Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)
Dim py1 As Integer
Dim pxm, pxi, px1, bi
Dim daim1, daim2 As String
pxm = 0
For pxi = 1 To ti
pxm = pxm + daima(pxi, 2) * ww
Next
Printer.DrawWidth = 3
Printer.FontSize = 11
Printer.FontBold = True
py = pp1 + (pp3 + 2 - pp2) * wh
Printer.Line (0, pp1)-(pxm, pp1)
Printer.Line (pxm, pp1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, pp1)
Printer.DrawWidth = 1
px = 0
For pxi = 1 To ti
daim2 = daima(pxi, 1)
px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = pp1 + Int(0.2 * wh)
Printer.Print daima(pxi, 1)
px = px + daima(pxi, 2) * ww
Printer.Line (px, pp1)-(px, py)
Next
Printer.FontBold = False
py = pp1 + wh
For bi = pp2 To pp3
px = 0
For pxi = 1 To ti
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = daima(pxi, 3)
daim2 = dai1(bi, daim1)
Printer.Print len2(daim2, Int(daima(pxi, 2)))
px = px + daima(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py)
py = py + wh
rst1.MoveNext
Next bi
End Sub
Sub printfoot(pp1 As Integer, pp2 As Integer)
px = pw - 300: py = ph - 5 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & pp2 & "
当前页数:" & pp1
End Sub
Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Call printframe(p1, p2, p3)
Call printfoot(p4, p5)
End Sub
Sub printbody()
Dim page As Integer
Dim pi As Integer
Dim p1y As Integer
Dim p2y As Integer 'first page lines and other page lines
Dim table2
p2y = 37 '44
table2 = 20
table1 = table1 + wh
p1y = (ph - table1 - 100) / wh
rst1.MoveFirst
If bnum < p1y + 1 Then
Call printail(table1, 1, bnum, 1, 1)
Else
page = Int(((bnum - p1y) / p2y) + 1.9999)
Call printail(table1, 1, p1y, 1, page)
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page)
Else
Printer.NewPage
Call printail(table2, p1y + 1, bnum, page, page)
End If
End If
End Sub
Sub printp()
Dim sp
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
End Sub
Private Sub Command1_Click()
bnum = rst1.RecordCount
finput
finput2
printp
End Sub
Private Sub Command3_Click()
Unload Me
End Sub
Private Sub Form_Load()
Dim str1, strcnn
strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _
"Data Source=" & fpath1 & "shukux.mdb"
Set cnn2 = New ADODB.Connection
cnn2.Open strcnn
Set rst1 = New ADODB.Recordset
rst1.CursorType = adOpenKeyset
rst1.LockType = adLockOptimistic
rst1.Open "shu00", cnn2, , , adCmdTable
End Sub
用数组打印报表
建立模块Module1：
Dim wh, ww 'word height and width
Dim pw, ph, px, py As Integer
Dim table1 '第一页表格起始位置
Dim pxm
'表宽
Sub printhead()
Dim i
'计算表宽
pxm = 0
For i = 0 To txI - 1
pxm = pxm + tx(i, 2) * ww
Next
'打印标题
table1 = 0
For i = 0 To tyI - 1
Printer.FontName = ty(i, 0)
Printer.FontSize = ty(i, 1)
Printer.FontBold = ty(i, 2)
Printer.CurrentX = ty(i, 3)
Printer.CurrentY = ty(i, 4)
Printer.Print ty(i, 5)
table1 = ty(i, 4)
'画下划线
If ty(i, 6) = 1 Then
Printer.DrawWidth = 2
Printer.Line (0, table1 + 10)-(pxm, table1 + 10)
End If
Next
End Sub
Sub printa(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Dim py1 As Integer
Dim pxi, px1, bi
Dim daim1, daim2 As String
'打印表格线
Printer.DrawWidth = 3
py = p1 + (p3 + 2 - p2) * wh
Printer.Line (0, p1)-(pxm, p1)
Printer.Line (pxm, p1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, p1)
'打印表头
Printer.DrawWidth = 1
Printer.FontSize = 11
Printer.FontBold = True
px = 0
For pxi = 0 To txI - 1
daim2 = tx(pxi, 1)
px1 = Int((tx(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = p1 + Int(0.2 * wh)
Printer.Print tx(pxi, 1)
px = px + tx(pxi, 2) * ww
Printer.Line (px, p1)-(px, py)
Next
'打印表格内容
Printer.FontBold = False
py = p1 + wh
For bi = p2 To p3
px = 0
For pxi = 0 To txI - 1
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = tx(pxi, 3)
daim2 = tz(bi - 1, daim1)
Printer.Print daim2 'len2(daim2, Int(tx(pxi, 2)))
px = px + tx(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py)
py = py + wh
Next bi
'打印页码
px = Int(0.6 * pw): py = ph - 7 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & p5 & "
当前页数:" & p4
End Sub
Sub printbody()
Dim page As Integer
Dim pi As Integer
Dim p1y As Integer
Dim p2y As Integer 'first page lines and other page lines
Dim table2
'p2y = 38
table2 = 0
table1 = table1 + wh
p1y = (ph - table1 - 115) / wh
p2y = (ph - 115) / wh
MsgBox p2y
If tzI < p1y + 1 Then
Call printa(table1, 1, tzI, 1, 1)
Else
page = Int(((tzI - p1y) / p2y) + 1.9999)
Call printa(table1, 1, p1y, 1, page)
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printa(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printa(table2, p1y + (page - 2) * p2y + 1, tzI, page, page)
Else
Printer.NewPage
Call printa(table2, p1y + 1, tzI, page, page)
End If
End If
End Sub
Sub printp()
Dim sp
If tzI < 1 Then Exit Sub
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (0, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
End Sub
在其它模块中调用时，只要先给出tx，ty，tz数组值和txI，tyI，tzI，再调用Module1.printp即可。例如：
Sub tabledatax()
txI = 10
‘10列
tx(0, 1) = "序号"
‘表标题
tx(0, 2) = 4
‘表宽(4个字)
tx(0, 3) = 0
‘序号
tx(1, 1) = "代码"
tx(1, 2) = 8
tx(1, 3) = 1
tx(2, 1) = "库位号"
tx(2, 2) = 8
tx(2, 3) = 2
tx(3, 1) = "单价"
tx(3, 2) = 7
tx(3, 3) = 3
tx(4, 1) = "书
名"
tx(4, 2) = 33
tx(4, 3) = 4
tx(5, 1) = "册数"
tx(5, 2) = 6
tx(5, 3) = 5
tx(6, 1) = "码洋"
tx(6, 2) = 7
tx(6, 3) = 6
tx(7, 1) = "折扣"
tx(7, 2) = 5
tx(7, 3) = 7
tx(8, 1) = "实洋"
tx(8, 2) = 7
tx(8, 3) = 8
tx(9, 1) = "包+册"
tx(9, 2) = 8
tx(9, 3) = 9
End Sub
Sub tabledatay()
Dim px1, px2, px3, py
Dim wh0
wh0 = 10
tyI = 10
px1 = 20
px2 = 370
px3 = 620
ty(0, 0) = "宋体"
‘字体
ty(0, 1) = 17
‘字号
ty(0, 2) = 1
‘加粗
ty(0, 3) = 180
‘Current X
ty(0, 4) = 10
‘Current Y
ty(0, 5) = "中国水利水电出版社批销业务清单"
ty(0, 6) = 0
‘是否加线
py = 30
ty(1, 0) = "宋体"
ty(1, 1) = 10
ty(1, 2) = 0
ty(1, 3) = px1
ty(1, 4) = py
ty(1, 5) = "处理单号: " & clh
ty(1, 6) = 0
ty(2, 0) = "宋体"
ty(2, 1) = 10
ty(2, 2) = 0
ty(2, 3) = px2
ty(2, 4) = py
ty(2, 5) = "制单日期: 20" & ddate
ty(2, 6) = 0
ty(3, 0) = "宋体"
ty(3, 1) = 10
ty(3, 2) = 0
ty(3, 3) = px3
ty(3, 4) = py
ty(3, 5) = "提书单编号: " & numb
ty(3, 6) = 1
‘加下划线
py = py + 20
ty(4, 0) = "宋体"
ty(4, 1) = 10
ty(4, 2) = 0
ty(4, 3) = px1
ty(4, 4) = py
ty(4, 5) = "购货单位: " & len2(uname, 36)
ty(4, 6) = 0
ty(5, 0) = "宋体"
ty(5, 1) = 10
ty(5, 2) = 0
ty(5, 3) = px2
ty(5, 4) = py
ty(5, 5) = "总册数 : " & zce
ty(5, 6) = 0
ty(6, 0) = "宋体"
ty(6, 1) = 10
ty(6, 2) = 0
ty(6, 3) = px3
ty(6, 4) = py
ty(6, 5) = "制单人 : "
ty(6, 6) = 0
py = py + wh0
ty(7, 0) = "宋体"
ty(7, 1) = 10
ty(7, 2) = 0
ty(7, 3) = px1
ty(7, 4) = py
ty(7, 5) = "地 址: " & add
ty(7, 6) = 0
ty(8, 0) = "宋体"
ty(8, 1) = 10
ty(8, 2) = 0
ty(8, 3) = px2
ty(8, 4) = py
ty(8, 5) = "总码洋 : " & zma
ty(8, 6) = 0
ty(9, 0) = "宋体"
ty(9, 1) = 10
ty(9, 2) = 0
ty(9, 3) = px3
ty(9, 4) = py
ty(9, 5) = "计算件数: " & zl
ty(9, 6) = 0
End Sub
Sub tabledataz()
Dim i, bb As Integer, dd1 As Single
tzI = bnum
For i = 0 To tzI - 1
tz(i, 0) = i + 1
tz(i, 1) = code(i)
tz(i, 2) = kwh(i)
tz(i, 3) = Xiao2(danjia(i))
tz(i, 4) = len2(bname(i), 35)
tz(i, 5) = " " & shice(i)
dd1 = danjia(i) * shice(i)
tz(i, 6) = Xiao2(dd1)
tz(i, 7) = "0" & bzhe(i)
dd1 = danjia(i) * shice(i) * bzhe(i)
tz(i, 8) = Xiao2(dd1)
bb = Int(shice(i) / bag(i))
tz(i, 9) = bb & "+" & shice(i) - bb * bag(i) & "(" & bag(i) & ")"
Next
End Sub
Sub print_pxd()
tabledatax
tabledatay
tabledataz
Module1.printp
‘调用打印表格模块
End Sub
用REPORT产生报表
1．新建标准工程1；
2．添加数据环境：选择菜单【工程】/【更多ActiveX设计器】/【DataEnvironment】，添加DataEnvironment1；
3．建立ODBC连接：
（1）在【控制面板】/【ODBC数据源】/【系统DNS】中设置数据库连接，如test0；
（2）右击【Connection1】，选择【属性】，出现“数据链接”对话框：
（3）在“提供者”属性页中选择【…for ODBC Drivers】；
（4）在“连接”属性页中选择【使用连接字符串】，单击【编译】/【机器数据源】，选中需要的数据连接，如test0，单击【确定】；
（5）单击【测试连接】，如通过，可以进行下一步；
4．添加连接命令：右击【Connection1】，选择【添加命令】，出现“Command1”;
5．设置连接命令：右击【Command1】，选择【属性】，出现“属性”对话框，设【数据库对象】为【表】，【对象名称】为所需要的表名，如“取水户基本信息表”，单击+号，可以展开表，如图所示：
6．添加报表：选择菜单【工程】/【添加DataReport】，添加DataReport1；
7．设置报表连接：在右边的属性面板中设【DataSource】为【DataEnvironment1】，【DataMember】为【Command1】；
8．设置报表数据：把各字段从DataEnvironment1拖到DataReport1，再加以排列；注意：拖动的字段有2块，左边是字段名（可以放在“页标头”栏中），右边是字段值（要放在“细节”栏中）；
9．设置报表标题：右击报表，选择【插入控件】/【标签】，在报表标头栏中放置；还可以在“页注脚”栏中插入页码；
10．设置报表边框：右击报表，选择【插入控件】/【形状】，调整矩形大小，在每个字段和字段名上放置一个复制控件（Shape）；
11．显示报表：在工程的Form1（或UserControl1）中添加一个按钮，在其上添加代码：
DataReport1.Show
然后就可以运行了。运行时既可以显示，也可以打印报表。
如建立ActiveX控件，要先建立一个标准EXE工程（用于调试），再建立一个ActiveX控件，在其上如上操作。
八 数据库控件
用数据库控件实现数据库浏览
放置控件: Form1:Data1,Combo1,Text1,Text2,Lbel1,Label2,Label3
属性设置: 〖Combo1.Datasource〗=data1
〖Text1.Datasource〗=data1
〖Text2.Datasource〗=data1
其余Text1,Text2,Label1,Label2,Label3的属性见图8.4
Data1的RecordsetType属性为0（table）
代码:
Private Sub Form_Load()
Data1.DatabaseName = "biblio.mdb"
'调入"图书管理数据库"
Data1.RecordSource = "select distinct STATE from publishers "
Data1.Refresh
Do While Not Data1.Recordset.EOF
'给Combo1赋值
temp = Data1.Recordset("State")
If IsNull(temp) Then temp = ""
Combo1.AddItem CStr(temp)
Data1.Recordset.MoveNext
Loop
Data1.RecordSource = "publishers"
'改变Recordset为全表
Data1.Refresh
Text1.DataField = "name"
Text2.DataField = "city"
Combo1.DataField = "state"
End Sub
在控件DATAI中显示总记录和当前记录
先设置全局变量firstflag，并在FormLoad中设为True，
Private Sub Data1_Reposition()
'重新定位记录时显示记录号
If firstflag Then
'如果是首次使用
Data1.Caption = "" 'data1标题框显示空白
firstflag = False
Else
'如果不是首次使用，则在
' data1标题框显示记录号
Data1.Caption = "总记录数:" & Data1.Recordset.RecordCount _
& " 当前记录:" & Data1.Recordset.AbsolutePosition + 1
End If
用数据库控件实现数据录入/删除
放置控件: Form1:Data1;Text1,2;Lbel1,2;Command1,2,3,4,5;Frame1
属性设置:
Data1:〖DatabseName〗="Nwind.mdb",〖Recordsource〗=products
Text1:〖Datasource〗=data1,〖Datafield〗=produtID,〖TabIndex〗=0
Text2:〖Datasource〗=data1,〖Datafield〗=produtName,〖TabIndex〗=1
Command1:〖Name〗=Cmdadd,〖Caption〗=增加
Command2:〖Name〗=Cmddelete,〖Caption〗=删除
Command3:〖Name〗=Cmdexit,〖Caption〗=退出
Command4:〖Name〗=Cmdupdate,〖Caption〗=确定
Command5:〖Name〗=Cmdcancel,〖Caption〗=放弃
Frame1中包含Command4,5
其余Text1,2,Label1,2和Command1,2,3,4,5的位置属性见图8.5
代码:
Option Explicit
Dim firstflag As Boolean
'首次使用标记
Private Sub Cmdadd_Click()
'增加记录
Data1.Recordset.AddNew
Frame1.Visible = True
'使主按钮组不可见
Data1.Caption = "记录:" & Data1.Recordset.RecordCount + 1
Text1.SetFocus
End Sub
Private Sub Cmdcancel_Click()
'放弃录入的记录
Data1.Recordset.CancelUpdate
Frame1.Visible = False
'使主按钮组可见
Data1.Recordset.MoveLast
'回到最后一个记录
End Sub
Private Sub Cmdupdate_Click()
'确定录入的记录有效
Data1.Recordset.Update
Frame1.Visible = False
'使主按钮组可见
Data1.Recordset.MoveLast
'显示录入内容
End Sub
Private Sub Data1_Reposition()
'重新定位记录时显示记录号
If firstflag Then
'如果是首次使用
Data1.Caption = "" 'data1标题框显示空白
firstflag = False
Else
'如果不是首次使用，则在
' data1标题框显示记录号
Data1.Caption = "总记录数:" & Data1.Recordset.RecordCount _
& " 当前记录:" & Data1.Recordset.AbsolutePosition + 1
End If
End Sub
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
连接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
Sub CalEnter2(RainName)
Combo_nm = RainName
combo_year_Click
End Sub
Private Sub Form_Load()
Dim j As Integer
Dim Temp
SetDb
Set Rst2 = New ADODB.Recordset
Rst2.Open "RAINSTAT", Cnn
While Not Rst2.EOF
Combo_nm.AddItem Rst2("rainstatnm")
Rst2.MoveNext
Wend
combo_year = Year(Date) - 1
For j = year0 To Year(Date) - 1
combo_year.AddItem j
Next j
Rst2.MoveFirst
Temp = Rst2("rainstatnm")
Combo_nm.ListIndex = 0
'从外部调用这个FORM
Gflag = False
If GisCD <> "" Then
Gflag = True
Set Rst2 = New ADODB.Recordset
Rst2.Open "select * from RAINSTAT where trim(rainstatcd)='" & Trim(GisCD) & "'", Cnn
On Error Resume Next
Temp = Rst2("rainstatnm")
If err.Number > 0 Then
MsgBox "调用错误，返回"
Unload Me
End If
Combo_nm.Enabled = False
End If
'Rst2.Close
CalEnter2 Temp
End Sub
Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)
Dim strvalid As String
strvalid = "0123456789."
If KeyAscii > 26 Then
If InStr(strvalid, Chr(KeyAscii)) = 0 Then
KeyAscii = 0
End If
End If
If KeyAscii = 13 Then
If Index < 11 Then
Text1(Index + 1).SetFocus
End If
If Index = 11 Then
cmdjisuan(0).SetFocus
End If
If Index = 12 Then
cmdSubmit(1).SetFocus
End If
End If
End Sub
程序还用到公用模块代码：
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;Drive r={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
十 文件处理
用open方法读文件
open s1 for input as #1
do while not eof(1)
line input #1, s2
msgbox s2
loop
close #1
用open方法写文件
重写
open s1 for output as #1
print #1, s2
close #1
附加
open s1 for append as #1
print #1, s2
close #1
用FSO对象读写文件
使用FSO对象前要引用Microsoft Scripting Runtime
Dim fso As New FileSystemObject
Dim ts1, ts2 As TextStream
Set ts1 = fso.OpenTextFile(fs1, ForReading)
Set ts2 = fso.OpenTextFile(fs2, ForWriting)
i = 0
Do While Not ts1.AtEndOfStream
s0 = ts1.ReadLine
ts2.WriteLine s0
i = i + 1
Loop
m = i
ts1.Close
ts2.Close
删除文件
Dim fso As New FileSystemObject
fso.DeleteFile fname1
或
Set File2 = fso.GetFile(t1)
File2.Delete
文件更名
把文件t1换名变成t2
t1 = "c:/logs/station.dbf..dbf"
t2 = "c:/logs/station1.dbf"
If fso.FileExists(t1) Then
Set File2 = fso.GetFile(t1)
If Not fso.FileExists(t2) Then
File2.Move t2
End If
Else
MsgBox "数据库文件" & t1 & "不存在！"
End
End If
复制文件
把文件t1复制成t2
t1 = "c:/logs/station.dbf..dbf"
t2 = "c:/logs/station1.dbf"
If fso.FileExists(t1) Then
Set File2 = fso.GetFile(t1)
If Not fso.FileExists(t2) Then
File2.Copy t2
End If
Else
MsgBox "数据库文件" & t1 & "不存在！"
End
End If
删除过期文件
添加File1控件，用来管理所有文件。先要设File1.Path
For i = 0 To File1.ListCount - 1
fn = File1.Path + "/" + File1.List(i)
Set File2 = fso.GetFile(fn)
tt = File2.DateLastModified
If today - tt > 10 Then
‘删除10天前的文件
File2.Delete
End If
Next
十一 收发E-mail
发送E-mail
调用: 【部件】下的Microsoft MAPI Control 6.0
放置控件: Form1:Command1, MAPISession1, MAPIMessages1
属性设置: 〖MAPISession1.名称〗=MAPIS，〖MAPIMessages1.名称〗=MAPIM
说明: 1. MAPISession控件用来进行联接和登录，MAPIMessages控件用来进行收发E-mail的操作。
2. 发送时向MAPIMessages.MsgNoteText输入E-mail内容。要输入多行，用MAPIMessages.MsgNoteText = line1 & vbCrLf & line2 即可。
代码:
Private Sub Command1_Click()
With MAPIS
.DownLoadMail = True '使用开机下载
.LogonUI = True '发送地址不对时可以手工设置
.SignOn '建立会话
End With
With MAPIM
.SessionID = MAPIS.SessionID '用SessionID指定对话序列号,缺省为0
.Compose '写新消息
.RecipAddress = "shuku@waterpub.com.cn" '写收件人地址
.AddressResolveUI = True '使用验证方式
.ResolveName '验证收件人地址
.MsgSubject = "head" '写E-mail主题
.MsgNoteText = "text" '写E-mail内容
.Send '发送
End With
MAPIS.SignOff
'结束会话
MsgBox ("发送完毕。")
End Sub
接收E-mail
调用: 【部件】下的Microsoft MAPI Control 6.0
放置控件: Form1:Command1, MAPISession1, MAPIMessages1,Text1,Text2,Text3
属性设置: 〖MAPISession1.名称〗=MAPIS，〖MAPIMessages1.名称〗=MAPIM
说明:：1．本例为接收一份E-mail的例子；
2．要先打开Outlook Express，并自动接受了邮件。程序从Outlook Express的收件箱中读取信件。
代码:
Private Sub Command1_Click()
With MAPIS
.DownLoadMail = True '使用开机下载
.LogonUI = True '发送地址不对时可以手工设置
.SignOn '建立会话
End With
With MAPIM
.SessionID = MAPIS.SessionID '用SessionID指定对话序列号,缺省为0
.Fetch '取信
Text3 = .MsgCount '信件数量
Text1 = .MsgSubject '主题
Text2 = .MsgNoteText '内容
'.Delete '取后删除
End With
MAPIS.SignOff
'结束会话
End Sub
接收多封E-mail
放置控件和属性设置同前。
要先打开Outlook Express，并自动接受了邮件。程序从Outlook Express的收件箱中读取信件。
Dim i
Fpath3 = “C:/asp/temp/”
With MAPIS
.DownLoadMail = True
.LogonUI = True
.SignOn
End With
With MAPIM
.SessionID = MAPIS.SessionID
.Fetch
For i = 0 To .MsgCount - 1
.MsgIndex = i
s1 = fpath3 & .MsgSubject
Open s1 For Output As #1
Print #1, .MsgNoteText
Close #1
Next
For i = 0 To .MsgCount - 1
.Delete
Next
End With
MAPIS.SignOff
选择发送多封E-mail
放置控件和属性设置同前,增加Fiel1控件。
利用拨号上网时，要先打开Outlook Express，并已拨号上网，这样速度较快。否则每发送一封要拨一次号。
Option Explicit
Dim fscount, i, j
Dim fs1(200) As String
Dim fso As New FileSystemObject
Dim File2 As File
Function disfile(ss1 As String)
Dim sk
disfile = ""
Open File1.Path & "/" & ss1 For Input As #1
Do While Not EOF(1)
Line Input #1, sk
disfile = disfile & sk & vbCrLf
Loop
Close #1
End Function
Sub MAPIsend()
Dim fs2 As String
With MAPIS
.DownLoadMail = False
.LogonUI = True
.SignOn
End With
With MAPIM
.SessionID = MAPIS.SessionID
.Compose
For i = 0 To fscount - 1
'.MsgIndex = i
.RecipAddress = "wrf@waterpub.com.cn"
.AddressResolveUI = True
.ResolveName
fs2 = fs1(i)
'fs2 = "4bu0020.ppp"
.MsgSubject = fs2
.MsgNoteText = disfile(fs2)
.Send
Next i
End With
MsgBox "发送完毕"
End Sub
Sub mfilemove()
Dim fname1
For i = 0 To fscount - 1
fname1 = File1.Path & "/" & fs1(i)
'MsgBox fname1
fso.DeleteFile fname1
Next
End Sub
Private Sub Command1_Click()
j = 0
For i = 0 To File1.ListCount - 1
If File1.Selected(i) Then
fs1(j) = File1.List(i)
j = j + 1
End If
Next
fscount = j
If fscount < 1 Then
MsgBox "没有要发送的文件！"
Exit Sub
Else
For i = 0 To fscount - 1
fs1(i) = File1.List(i)
Next i
End If
MAPIsend
Mfilemove
MAPIS.SignOff
Unload Me
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Private Sub Form_Load()
Fpath1=”c:/fxfx/kfb/”
File1.Path = fpath1 & "email"
End Sub
十二 ActiveX控件
建立简单的ActiveX控件
这是一个显示时间的例子。
1．新建一个ActiveX控件工程
放置控件: UserControl1:Frame1,Timer1，Label1(小时)，Label2(分)，Label3(秒)，使框架包容其它控件
属性设置: 〖Timer1.Interval〗=100 'ms
代码:
Private Sub Timer1_Timer()
Label1.Caption = Hour(Time) & ";"
Label2.Caption = Minute(Time) & ";"
Label3.Caption = Second(Time)
End Sub
Private Sub UserControl_Initialize()
Label1.Caption = Hour(Time) & ";"
Label2.Caption = Minute(Time) & ";"
Label3.Caption = Second(Time)
End Sub
然后保存文件，并生成OCX文件。
2．新建一个标准EXE工程，单击【工程】/【部件】，找到刚才生成的“工程1”部件，把它选中，然后从工具箱中把它添加到Form1中。这时就可以看见这个控件已经在运行了。然后就可以发布使用这个控件了。
改进ActiveX控件的接口
在【外接程序】/【外接程序管理器】中选择“ActiveX接口向导”的加载，再打开向导对话框，按照提示去做即可。
发布和应用ActiveX控件
在【外接程序】/【外接程序管理器】中选择“打包和展开向导”的加载，再打开向导对话框，选择【打包】，再选择【Internet】,在选项中选择“发布到没有VB的计算机上”，然后就可以在指定的文件夹中产生一个CAB文件，可以安装到其它计算机上使用。
这时还产生了一个同名的HTML文件，把其上的OBJECT代码拷贝下来，放到其它网页上，就可以在网上应用这个控件了。
建立一个复杂一点的例子
这是一个添加新的属性和方法的例子。
新建一个ActiveX控件工程，放置控件: UserControl1:command1,label1。
打开“ActiveX接口向导”，只选择caption（对应label1）和click（对应Command1），再新建一个属性leftx（对应label1）。
这时在UserControl1自动产生了几段代码，修改如下，然后再用下节的调试方法来进行在线调试。
'设置leftx的属性（用let和get分别设置赋值和被赋值的情况）
Public Property Let leftx(ByVal New_leftx As Integer)
Label1.Left = New_leftx
PropertyChanged "leftx"
End Property
'注意！不要删除或修改下列被注释的行！
'MemberInfo=7,0,0,0
Public Property Get leftx() As Integer
leftx = Label1.Left
End Property
'修改Click事件
Private Sub Command1_Click()
Me.Caption = Me.leftx
Me.leftx = Me.leftx + 50
RaiseEvent Click
End Sub
'添加一个初始值设置（没有大用处，只是练习）
Private Sub UserControl_Initialize()
Me.Caption = ""
End Sub
开发调试
先单击【工程】/【添加工程】，添加一个测试工程；
关闭 UserControl，这时工具箱中出现 UserControl控件，把它加入到Form1中，就可以运行这个程序了。
如果没有测试工程，也可以调用IE运行。
要在网页上加入这个控件，运行时查看HTML源文件，把下列说明复制下来，粘贴到网页中：
<OBJECT classid="clsid:0C174E17-67F5-11D5-98FB-BCF7F45EF11E">
</OBJECT>
其余的语句运行时自动产生。
安装和发布
对于DLL文件，拷贝到一个目录后，在【运行】中键入：
C:/WINDOWS/SYSTEM/REGSVR32.EXE C:/MYASP/ASPPING.DLL
或在NT中：
C:/WINNT/SYSTEM32/REGSVR32.EXE C:/MYASP/ASPPING.DLL
对于OCX文件，则要安装。步骤是：
1．编制程序（ACTIVEX控件）；
2．在【工程】/【工程。。属性】中选“要求许可证关键字”；
3．编译成OCX文件；
4．打包。
十三 总体结构
用Timer控件控制程序运行
放置控件: Form1:Command1,Timer1
属性设置: 〖Timer1.Interval〗=10 '10ms
代码:
Dim i As Integer
'循环变量
Dim doflag As Boolean
'用户是否按键标志
Sub delay 同前
Private Sub example()
Form1.Print i
delay (500)
i = i + 1
End Sub
Private Sub Command1_Click()
Select Case doflag
Case True
Command1.Caption = "开始"
doflag = False
Cls
Case False
Command1.Caption = "停止"
doflag = True
End Select
End Sub
Private Sub Timer1_Timer() '时钟控件随时检测,如果没有点击
If doflag Then
'Command1(停止),则继续调用example过程
example
End If
End Sub
Private Sub Form_Load()
doflag = False
Command1.Caption = "开始"
End Sub
在过程中调用Form的模式方法
Form2.Show VbModal
在过程中调用Form的后台中断方法
放置控件: Form1:Command1, Form2:Command2
代码:
Private Sub Command1_Click()
Bl = True
Form2.show
Do While Bl do
DoEvents
Loop
End Sub
Private Sub Command2_Click()
Unload Me
Bl = False
End Sub
调用其它窗体中的过程
调用Form2的pp1过程:
Load Form2
Form2.pp1
定时播放提醒声
以下程序每隔10分钟播放提醒声，按COMMAND2停止。
Option Explicit
Dim s1, s2
Dim stopb As Boolean
Sub delay(ss As Long)
Dim start, check
start = Timer
Do
check = Timer
Loop While check < start + ss * 60
End Sub
Private Sub Command1_Click()
Dim i
s1 = "C:/Program Files/Windows Media Player/MPLAYER2.EXE"
s2 = " C:/windows/media/乐曲默认值.wav"
Do While Not stopb
Shell (s1 & s2)
delay 10
DoEvents
Loop
End Sub
Private Sub Command2_Click()
stopb = True
End Sub
Private Sub Form_Load()
stopb = False
End Sub
十四 加密
简单的密码框
放置控件: Form1:Text1,Command1;Form2
属性设置: 〖Form1.Command1.Caption〗=确定
〖Form1.Text1.text〗=""
〖Form2.Command1.Caption〗=Exit
Form1代码:
Private Sub Command1_Click()
If Text1.text = "123" then
'设密码为123
Print "You are right!"
Else
Print "Sorry ! Input again."
Text1.Text = "" '清除以前输入内容
End If
Text1.SetFocus
'焦点重新回到文本框
End Sub
Form2代码:
Private Sub Command1_Click()
End
End Sub
加密Form
放置控件: Form1:Text1,Command1;Form2
属性设置: 〖Form1.Command1.Caption〗=确定
〖Form1.Text1.text〗=""
〖Form2.Command1.Caption〗=Exit
Form1代码:
Dim s1 As Integer
Private Sub Text1_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
If Text1 = "123" Then '密码为123
Form1.Hide
Form2.Show
Else
If s1 = 3 Then '只能试3次
MsgBox ("密码错误,系统退出!")
Unload Me
Else
MsgBox ("输入错!请重新输入密码:")
Text1 = ""
s1 = s1 + 1
End If
End If
End If
End Sub
Private Sub Form_Load()
Text1 = ""
s1 = 1
End Sub
十五 其它编程
调用外部程序
本例用shell调用记事本程序，在其中写入几行字后保存，最后返回VB。
放置控件: Form1:Text1,Command1
代码：
Private Sub Command1_Click()
Shell ("C:/PWIN98/NOTEPAD.EXE"), 1
'AppActivate "无标题 - 记事本"
’指定窗口
SendKeys "The text1 is : ", True
SendKeys "{ENTER}", True
SendKeys Text1, True
SendKeys "%(F)", True
’按Alt+F
SendKeys "X", True
’按X退出记事本
SendKeys "{ENTER}", True
SendKeys "123", True
’输入文件名
SendKeys "{ENTER}", True
SendKeys "Y", True
Unload Me
End Sub
运行时先在文本框中输入一行字，再按Command1，就可以把这行字和前面的提示写到一个名为“123”的文件中了。
调用VB外部程序并传递参数
建立工程2，其中FORM2代码为：
Private Sub Command1_Click()
MsgBox "g2=" & Command()
End Sub
再建立工程1，其中FORM1代码为：
Private Sub Command1_Click()
Shell ("C:/VB/LIAN/工程2.exe cmmm 123456"), 1
MsgBox "ok"
End Sub
动态调整各测站的加权值
工程由FORM0和FORM1组成；FORM0根据选择流域值，再调用FORM1；FORM1先根据流域值查流域代码，根据代码查找测站数，然后动态产生各控件和FORM尺寸。拉动SLIDER控件可以调整各测站的权重。
FORM0：DATA1，COMMAND1，COMBO1
Private Sub Combo1_Click()
Data1.RecordSource = "SELECT * FROM HYDNET WHERE HYDNETNM='" & Combo1 & "'"
Data1.Refresh
SELHYDNET = Data1.Recordset!HYDNETCD
Data1.Recordset.Close
End Sub
Private Sub Command1_Click()
'Form0.Hide
Form1.Show
End Sub
Private Sub Form_Load()
Data1.RecordSource = "HYDNET"
Data1.Refresh
Do While Not Data1.Recordset.EOF
Combo1.AddItem Data1.Recordset!HYDNETNM
Data1.Recordset.MoveNext
Loop
End Sub
FORM1：产生SLIDER1、LABEL2、TEXT1数组（包括第一个控件），再产生一个标题LABEL1、DATA1、COMMAND1、COMMAND2；
Option Explicit
Dim Imax
'控件数（从0开始）
Const Smax = 100 '权重总计
Const Topy = 600 '每个控件间距
Private Sub Command1_Click() '关闭
Unload Me
End Sub
Private Sub Form_Load()
Dim j, Stemp
Data1.RecordSource = "SELECT * FROM RAINSTAT WHERE HYDNETCD='" & SELHYDNET & "'"
Data1.Refresh
Imax = 0
Do While Not Data1.Recordset.EOF
Imax = Imax + 1
Data1.Recordset.MoveNext
Loop
If Imax > 1 And Imax < 21 Then
Data1.Refresh
Label2(0) = Data1.Recordset!RAINSTATNM
If Imax < 10 Then
Form1.Width = 5800
Form1.Height = 4500 + Topy * (Imax - 2)
For j = 1 To Imax - 1
Load Slider1(j)
Slider1(j).Left = 1000
Slider1(j).Top = 1200 + Topy * j
Slider1(j).Visible = True
Load Text1(j)
Text1(j).Left = 4200
Text1(j).Top = 1200 + Topy * j
Text1(j).Visible = True
Data1.Recordset.MoveNext
Load Label2(j)
Label2(j).Left = 240
Label2(j).Top = 1300 + Topy * j
Label2(j).Caption = Data1.Recordset!RAINSTATNM
Label2(j).Visible = True
Next j
Command2.Left = 1400
Command2.Top = 3000 + Topy * (Imax - 2)
Command1.Left = 3300
Command1.Top = 3000 + Topy * (Imax - 2)
Else '如果控件数大于10，则要分2栏
Form1.Width = 11500
Form1.Height = 4500 + Topy * 9
Label1.Left = 4500
For j = 1 To 9
Load Slider1(j)
Slider1(j).Left = 1000
Slider1(j).Top = 1200 + Topy * j
Slider1(j).Visible = True
Load Text1(j)
Text1(j).Left = 4200
Text1(j).Top = 1200 + Topy * j
Text1(j).Visible = True
Data1.Recordset.MoveNext
Load Label2(j)
Label2(j).Left = 240
Label2(j).Top = 1300 + Topy * j
Label2(j).Caption = Data1.Recordset!RAINSTATNM
Label2(j).Visible = True
Next j
For j = 10 To Imax - 1
Load Slider1(j)
Slider1(j).Left = 7000
Slider1(j).Top = 1200 + Topy * (j - 10)
Slider1(j).Visible = True
Load Text1(j)
Text1(j).Left = 10200
Text1(j).Top = 1200 + Topy * (j - 10)
Text1(j).Visible = True
Data1.Recordset.MoveNext
Load Label2(j)
Label2(j).Left = 6240
Label2(j).Top = 1300 + Topy * (j - 10)
Label2(j).Caption = Data1.Recordset!RAINSTATNM
Label2(j).Visible = True
Next j
Command2.Left = 4400
Command2.Top = 2500 + Topy * 9
Command1.Left = 6300
Command1.Top = 2500 + Topy * 9
End If
For j = 0 To Imax - 1
Slider1(j).Max = Smax
Next
Stemp = Int(Smax / Imax)
For j = 0 To Imax - 2
Text1(j) = Stemp
Slider1(j).Value = Stemp
Next
Text1(Imax - 1) = Smax - Stemp * (Imax - 1)
Slider1(Imax - 1) = Smax - Stemp * (Imax - 1)
Else
If Imax < 2 Then
MsgBox "测站数为" & Imax & "，不能设定权重。"
Else '>20
MsgBox "测站数为" & Imax & "，超出程序设置范围，不能设定权重。"
End If
Command2.Enabled = False
Slider1(0).Visible = False
Label2(0).Visible = False
Text1(0).Visible = False
End If
End Sub
Private Sub Slider1_Click(Ix As Integer)
Dim j, S0
Dim Stemp
Dim Sx
S0 = Text1(Ix)
If Imax - Ix < 2 Then
MsgBox "不能改变！"
Slider1(Ix).Value = S0
Exit Sub
End If
Sx = 0
If Ix > 0 Then
For j = 0 To Ix - 1
Sx = Sx + Text1(j)
Next j
End If
Text1(Ix) = Slider1(Ix).Value
If Smax - Sx < Int(Text1(Ix)) Then
MsgBox "超出范围！"
Text1(Ix) = S0
Slider1(Ix) = S0
Else
Stemp = Int((Smax - Sx - Int(Text1(Ix))) / (Imax - 1 - Ix))
MsgBox "stemp=" & Stemp
If Imax - Ix = 0 Then
Text1(Imax - 1) = Stemp
Slider1(Imax - 1).Value = Stemp
Else
For j = Ix + 1 To Imax - 2
Text1(j) = Stemp
Slider1(j) = Stemp
Next j
Text1(Imax - 1) = (Smax - Sx - Int(Text1(Ix))) - Stemp * (Imax - Ix - 2)
Slider1(Imax - 1) = (Smax - Sx - Int(Text1(Ix))) - Stemp * (Imax - Ix - 2)
End If
End If
End Sub
用MSCHART产生图表
在【部件】中使用：
1． MS ADO Data Control 6.0;
2． MS Chart Control 6.0;
3． MS Datalist Control 6.0;
然后建立List(Liststation)、MSChart(ChartDemo)、Combo(ComboYear,ComboChartType)、Label1～Label4，程序为：
Option Explicit
Public iChartType As Integer '当前图表类型
Public cnn As ADODB.Connection
'双击数据点可以更改数据，并反馈到图形上
Private Sub ChartDemo_PointActivated(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)
Dim vtPoint
With ChartDemo
.Column = Series
.Row = DataPoint
vtPoint = InputBox("更改数据点:", , .Data)
If vtPoint <> "" Then
If IsNumeric(vtPoint) Then
.Data = vtPoint
Else
MsgBox "没有有效的数据点!"
End If
End If
End With
End Sub
'单击数据点在Label4上反映该点的值
Private Sub ChartDemo_PointSelected(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)
' 允许用户在序列中通过选择特别的数据点来查阅它的值。
' 数据点的值被显示在名为 lblDatapoint 的标签中。
ChartDemo.Column = Series
ChartDemo.Row = DataPoint
Label4.Caption = "序列的值 " & Series & ", 点 " & DataPoint & " = " & ChartDemo.Data
End Sub
'选择图形类型
Private Sub ComboChartType_click()
Dim i As Integer
Dim strType As String
strType = ComboChartType.Text
Select Case strType
Case "饼图"
iChartType = 14
Case "折线图"
iChartType = 3
Case "立体图"
iChartType = 0
Case "柱状图"
iChartType = 9
End Select
ChartDemo.chartType = iChartType
ComboYear_click
End Sub
'选择年份
Private Sub ComboYear_click()
Dim strYear, strStation As String
Dim i As Integer
Dim arrChartData()
Dim strSql As String
Dim rstChartData As New ADODB.Recordset
strYear = ComboYear.Text
If strYear = "" Then
Exit Sub
End If
ChartDemo.Visible = True
strStation = Liststation.Text
strSql = "select * from addvdata where addvcd='" _
& strStation & "' and year=" & strYear
rstChartData.Open strSql, cnn ', adOpenDynamic, adLockOptimistic
If iChartType = 3 Then
ReDim arrChartData(1 To 12, 1 To 1)
For i = 1 To 12
arrChartData(i, 1) = rstChartData.Fields(i + 1)
Next i
With ChartDemo
.ChartData = arrChartData
.RowCount = 12
.ColumnLabelCount = 12
For i = 1 To 12
.Row = i
.RowLabel = rstChartData.Fields(i + 1).Name
Next i
.ColumnCount = 1
.Column = 1
.ColumnLabel = ""
.Refresh
End With
Else
ReDim arrChartData(1 To 1, 1 To 12)
For i = 1 To 12
arrChartData(1, i) = rstChartData.Fields(i + 1)
Next i
With ChartDemo
.ChartData = arrChartData
.ColumnCount = 12
.ColumnLabelCount = 12
For i = 1 To 12
.Column = i
.ColumnLabel = rstChartData.Fields(i + 1).Name
Next i
.RowCount = 1
.Row = 1
.RowLabel = ""
.Refresh
End With
End If
rstChartData.Close
strSql = ""
End Sub
Private Sub Form_Load()
Dim rst1 As New ADODB.Recordset
Set cnn = New ADODB.Connection
cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Data Source=Demo"
If Err Then
MsgBox "数据库打开失败", vbOKOnly, "提示"
End
End If
ComboChartType.AddItem "饼图"
ComboChartType.AddItem "折线图"
ComboChartType.AddItem "立体图"
ComboChartType.AddItem "柱状图"
rst1.Open "select * from addvdata ", cnn
Do While Not rst1.EOF
Liststation.AddItem rst1!addvcd
rst1.MoveNext
Loop
rst1.Close
ChartDemo.Refresh
End Sub
'测站代码列表
Private Sub ListStation_Click()
Dim strScode As String
Dim rstYear As New ADODB.Recordset
strScode = Liststation.Text
If strScode = "" Then
Exit Sub
End If
ComboYear.Clear
rstYear.Open "select distinct year from addvdata where addvcd='" + strScode + "'", cnn ', adOpenDynamic, adLockOptimistic
Do While Not rstYear.EOF
ComboYear.AddItem rstYear.Fields("year")
rstYear.MoveNext
Loop
rstYear.Close
End Sub
用剪贴板向WORD中添加图形和文字
建立一个COMMAND1和一个PICTURE1，在PICTURE1中添加一幅图。
Option Explicit
Dim objWord As Object
Private Sub Command1_Click()
Const CLASSOBJECT = "Word.Application"
On Error GoTo objError
Set objWord = CreateObject(CLASSOBJECT)
objWord.Visible = True
objWord.Documents.Add
With objWord
.ActiveDocument.paragraphs.Last.Range.Bold = False
.ActiveDocument.paragraphs.Last.Range.Font.Size = 14
.ActiveDocument.paragraphs.Last.Range.Font.Name = "黑体"
.ActiveDocument.paragraphs.Last.Range.Font.colorindex = 0
'.ActiveDocument.paragraphs.Last.Range.Text = Chr(13) & "向WORD中传递数据和图形练习"
End With
Clipboard.Clear
Clipboard.SetData Picture1.Picture
objWord.Selection.Paste
Clipboard.Clear
Clipboard.SetText "通过剪帖板向WORD传递字符"
objWord.Selection.Paste
objWord.PrintPreview = True '打印预览
'objWord.PrintOut
'打印
'objWord.Quit
'结束Word
Exit Sub
objError:
If Err <> 429 Then
MsgBox Str$(Err) & Error$
Set objWord = Nothing
Exit Sub
Else
Resume Next
End If
End Sub
在WORD中产生表格和文字
Private Sub Command3_Click()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
'取消此行最后加上.Quit在后台运行
objWord.Documents.Add
'可以加上路径，打开指定文件
With objWord
.Selection.Font.Name = "黑体"
.Selection.Font.Size = 14
.Selection.Font.Bold = True
.Selection.TypeText Text:="xuewei"
.Selection.Font.Name = "宋体"
.Selection.Font.Size = 10.5
.Selection.Font.Bold = False
.Selection.TypeParagraph '换行
'产生一个2行5列的表格
.ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=2, NumColumns:=5
.Selection.TypeText Text:="12"
.Selection.MoveRight '向右移动光标，移到最后一个后自动到下行的第一个
.Selection.TypeText Text:="34"
.Selection.MoveDown '向下移动光标
.Selection.TypeText Text:="56"
.Selection.MoveDown
.Selection.TypeParagraph
.Selection.TypeText Text:="end"
.Selection.TypeParagraph
End With
End Sub
向WORD中传送SELECT表和CHART控件图形
添加PictureBox控件PicGraph，运行时先使Chart1控件有图形，然后点击Command3。
Private Sub Command3_Click()
Dim intWinState As Integer
Dim objWord As Object
Dim sql, i
Dim str1 As String
Dim Rows1, Columns1
On Error GoTo objError
Set objWord = CreateObject("Word.Application")
With objWord
.Visible = True
.Documents.Add '"c:/My Document/test1.doc"
.Selection.TypeText Text:="表标题"
.Selection.TypeParagraph
.Selection.TypeParagraph
.Selection.MoveUp , Count:=2
.Selection.Style = .ActiveDocument.Styles("标题 1")
.Selection.ParagraphFormat.Alignment = 1
.Selection.MoveDown
.Selection.TypeText Text:="插入表"
.Selection.TypeParagraph
End With
sql = "select * from hydnet"
rst0.Open sql, cnn
i = 0
While Not rst0.EOF
i = i + 1
rst0.MoveNext
Wend
Rows1 = i
Columns1 = rst0.Fields.Count
If i > 0 Then
objWord.ActiveDocument.Tables.Add Range:=objWord.Selection.Range, NumRows:=Rows1, NumColumns:=Columns1
rst0.MoveFirst
While Not rst0.EOF
For i = 0 To rst0.Fields.Count - 1
str1 = rst0.Fields(i)
objWord.Selection.TypeText Text:=str1
objWord.Selection.MoveRight
Next i
rst0.MoveNext
Wend
End If
objWord.Selection.MoveRight , Count:=2
objWord.Selection.TypeText Text:="图形显示"
objWord.Selection.TypeParagraph
objWord.Selection.TypeParagraph
Chart1.EditCopy
PicGraph.Picture = Clipboard.GetData
Clipboard.Clear
Clipboard.SetData PicGraph.Picture
objWord.Selection.Paste
'objWord.PrintPreview = True '打印预览
'objWord.PrintOut
'打印
'objWord.Quit
'结束Word
Set objWord = Nothing
rst0.Close
Exit Sub
objError:
If Err <> 429 Then
MsgBox Str$(Err) & Error$
Set objWord = Nothing
Exit Sub
Else
Resume Next
End If
End Sub
通过剪贴板打印CHART控件图形
添加CommonDialog控件Common1，PictureBox控件PicGraph，运行时先使Chart1控件有图形，然后点击Command30。
Private Sub Command30_Click()
Dim intWinState As Integer
Dim intCopies As Integer
Dim intCopy As Integer
On Error GoTo errPrint
With Common1
.CancelError = True
.ShowPrinter
intCopies = .Copies
End With
'Expand to full screen to get large graph
intWinState = WindowState
WindowState = vbMaximized
Chart1.EditCopy
'Return to prior mode
WindowState = intWinState
PicGraph.Picture = Clipboard.GetData
For intCopy = 1 To intCopies
Printer.Print ""
Printer.PaintPicture PicGraph.Picture, 0, 0
'Add a caption at mid page
Printer.CurrentY = Printer.ScaleHeight / 2
Printer.FontSize = 18
Printer.CurrentX = 1500
'Printer.Print "Northwind Traders - " & frmMDIGraph.Caption
Printer.EndDoc
Next intCopy
errPrint:
Exit Sub
End Sub
写入HTML文件
要引用“Microsoft Word 9.0 Object Library”，然后编程如下：
Private Sub Command1_Click()
Dim objWord As Object
Set objWord = CreateObject("Word.Application")
objWord.Visible = True
objWord.Documents.Add '"c:/My Documents/X2.HTM"
With objWord
.Selection.MoveDown
.Selection.Font.Name = "黑体"
.Selection.Font.Size = 14
.Selection.Font.Bold = True
.Selection.TypeText Text:="xuewei"
.Selection.Font.Name = "宋体"
.Selection.Font.Size = 10.5
.Selection.Font.Bold = False
.Selection.TypeParagraph '换行
'产生一个2行5列的表格
.ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=2, NumColumns:=5
.Selection.TypeText Text:="12"
.Selection.MoveRight '向右移动光标，移到最后一个后自动到下行的第一个
.Selection.TypeText Text:="34"
.Selection.MoveDown '向下移动光标
.Selection.TypeText Text:="56"
.Selection.MoveDown
.Selection.TypeParagraph
.Selection.TypeText Text:="end6"
.Selection.TypeParagraph
.ActiveDocument.SaveAs FileName:="x1.htm", FileFormat:=wdFormatHTML, WritePassword _
:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _
SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _
False
.quit
End With
End Sub
十六 ActiveX 编程
调用简单DLL的例子
本例是一个ActiveX dll编程和调试的例子。实现简单的加法。
（1）建立工程1，其中有Form1:Command1；
（2）建立一个ActiveX dll控件（名为xdll02），类模块xclass2；
（3）在xclass2中代码如下：
Public den As Integer
Public Sub add(num2, num1 As Integer)
den = num1 + num2
End Sub
（4）生成xdll02.dll；
（5）选择【工程】/【引用】，选用xdll02；
（6）在Form1中添加Command1,Text1,Text2,Text3，代码如下：
Public xx1 As New xdll02.xClass2
Private Sub Command1_Click()
xx1.Add Text2, Text1
Text3 = xx1.den
End Sub
Private Sub Form_Load()
Text1 = 2
Text2 = 4
Text3 = 0
End Sub
（7）运行。运行时单击Command1，Text3中出现答案6。
注意，调试时，直接改动ActiveX dll中的代码即可，不需要重新安装dll。
调用DLL的另一个例子
工程1：Form1:Command1
Tingdemo2(ActiveX dll)：Class1,并形成组１。
运行前还要右击工程１，选择【设置为启动】，再引用Tingdemo2。
Class1代码：
Option Explicit
Public Name As String
Private mdtmCreated As Date
Public Property Get created() As Date
created = mdtmCreated
End Property
Public Sub ReverseName()
Dim intCt As Integer
Dim strNew As String
For intCt = 1 To Len(Name)
strNew = Mid$(Name, intCt, 1) & strNew
Next
Name = strNew
End Sub
Private Sub Class_Initialize()
mdtmCreated = Now
MsgBox "Name=" & Name & vbCrLf & "Created:" & created, , "thing initialize"
End Sub
Private Sub Class_Terminate()
MsgBox "Name = " & Name & vbCrLf & "Created:" & created, , "thing terminate"
End Sub
Form1代码：
Option Explicit
Private mth As New tingdemo2.Class1
Private Sub Command1_Click()
MsgBox "Name=" & mth.Name & vbCrLf & "Created:" & mth.created, , "from thing"
End Sub
。。。。。。
Private Sub Form_Load()
mth.Name = InputBox("Enter a name for the Thing:")
End Sub
简单ActiveX控件编程
先打开标准EXE工程，再填加一个ActiveX控件工程，再在Usercontrol1中填加控件如下：
代码：
Private Sub Command1_Click()
If List1.ListIndex >= 0 Then
List2.AddItem List1.List(List1.ListIndex)
List1.RemoveItem (List1.ListIndex)
End If
End Sub
Private Sub Command2_Click()
If List2.ListIndex >= 0 Then
List1.AddItem List2.List(List2.ListIndex)
List2.RemoveItem (List2.ListIndex)
End If
End Sub
Private Sub List1_Click()
Command1.Enabled = True
Command2.Enabled = False
End Sub
Private Sub List2_Click()
Command1.Enabled = False
Command2.Enabled = True
End Sub
Private Sub UserControl_Initialize()
List1.AddItem "AAA"
List1.AddItem "BBB"
List1.AddItem "CCC"
List1.AddItem "DDD"
End Sub
功能为：单击Command1，List1中的选择项右移，单击Command2，List2中的选择项左移；
关闭工程2，在Form1中填加ActiveX控件Control11，就可以运行了。
ActiveX控件的事件和方法
回到Control1，填加一个Command3，再打开菜单中的“ActiveX控件接口向导”，先单击“<<”清除所有选定名称，单击“下一步”，单击“新建”，填加如下表：
公有名称
类型
映射
成员
CtlEnd
Event Command3 Click
Clear1
Method List1 Clear
Add1
Method List1 AddItem
Sub1
Method List1 RemoveItem
完成后，代码变成：
……
Event ctlend() 'MappingInfo=Command3,Command3,-1,Click
'注意！不要删除或修改下列被注释的行！
'MappingInfo=List1,List1,-1,AddItem
Public Sub add1(ByVal Item As String, Optional ByVal Index As Variant)
List1.AddItem Item, Index
End Sub
'注意！不要删除或修改下列被注释的行！
'MappingInfo=List1,List1,-1,RemoveItem
Public Sub sub1(ByVal Index As Integer)
List1.RemoveItem Index
End Sub
'注意！不要删除或修改下列被注释的行！
'MappingInfo=List1,List1,-1,Clear
Public Sub clear1()
List1.Clear
End Sub
Private Sub Command3_Click()
RaiseEvent ctlend
End Sub
再关闭Control1，到Form1中添加Control11，再填加3个按钮如下：
代码为：
Private Sub Command4_Click()
Dim inItem As String
inItem = InputBox("Please input data:")
UserControl11.add1 inItem
End Sub
Private Sub Command5_Click()
Dim ItemNum As String
ItemNum = InputBox("Please input Num:")
UserControl11.sub1 ItemNum
End Sub
Private Sub Command6_Click()
UserControl11.Clear1
End Sub
Private Sub Form_Load()
UserControl11.add1 "new 1"
End Sub
Private Sub UserControl11_ctlend()
End
End Sub
运行后，产生效果为：单击Add，在List1中可以添加一项，单击Sub，在List1中输入序号可以减少一行，单击Clear，清除List1中所有数据，单击Quit退出。
ActiveX属性和事件调用
同前，先产生一个普通工程，再产生一个ActiveX控件工程，其上添加一个Command和Text控件，再打开菜单中的“ActiveX控件接口向导”，先单击“<<”清除所有选定名称，单击“下一步”，单击“新建”，填加如下表：
公有名称
类型
映射
成员
pclick
Event Command1 Click
Text0
Property Text1 Text
完成后，代码变成：
'事件声明:
Event pclick() 'MappingInfo=Command1,Command1,-1,Click
'注意！不要删除或修改下列被注释的行！
'MappingInfo=Text1,Text1,-1,Text
Public Property Get text0() As String
text0 = Text1.Text
End Property
Public Property Let text0(ByVal New_text0 As String)
Text1.Text() = New_text0
PropertyChanged "text0"
End Property
Private Sub Command1_Click()
RaiseEvent pclick
MsgBox Me.text0
‘自己添加
End Sub
'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Text1.Text = PropBag.ReadProperty("text0", "Text1")
End Sub
'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Call PropBag.WriteProperty("text0", Text1.Text, "Text1")
End Sub
其中msgbox一行是另外添加的。再在普通工程的form1中加上这个控件，如下编写：
Private Sub Form_Load()
UserControl11.text0 = "print123"
End Sub
Private Sub UserControl11_pclick()
'Print UserControl11.text0
End Sub
就可以调用ActiveX控件的属性和事件了。
十七 面向对象的编程
调用类模块的对象
本例可以看出一个对象在初始化和释放时的过程。
放置控件: Form1:Command1, Command2, Command3, Command4, Command5,
Class1（类模块）:name=Thing
属性设置:
Class1代码：
Option Explicit
Public Name As String
Private mdtmCreated As Date
Public Property Get created() As Date
created = mdtmCreated
End Property
Public Sub ReverseName()
Dim intCt As Integer
Dim strNew As String
For intCt = 1 To Len(Name)
strNew = Mid$(Name, intCt, 1) & strNew
Next
Name = strNew
End Sub
Private Sub Class_Initialize()
mdtmCreated = Now
MsgBox "Name=" & Name & vbCrLf & "Created:" & created, , "thing initialize"
End Sub
Private Sub Class_Terminate()
MsgBox "Name = " & Name & vbCrLf & "Created:" & created, , "thing terminate"
End Sub
Form1代码：
Option Explicit
'对 Thing 对象的引用。
Private mth As thing
'按钮“Create New Thing”。
Private Sub Command1_Click()
MsgBox "Name=" & mth.Name & vbCrLf & "Created:" & mth.created, , "from thing"
End Sub
'按钮“Reverse the Thing's Name”。
Private Sub Command2_Click()
mth.ReverseName
'通过设置值来单击“Show the Thing”。
Command1.Value = True
End Sub
'新建
Private Sub Command3_Click()
Set mth = New thing
mth.Name = InputBox("Enter a name for new Thing:")
End Sub
'暂存
Private Sub Command4_Click()
Dim thTemp As New thing
thTemp.Name = InputBox("Enter a name for the temporary Thing:")
End Sub
'释放
Private Sub Command5_Click()
Set mth = Nothing
End Sub
Private Sub Form_Load()
Set mth = New thing
mth.Name = InputBox("Enter a name for the Thing:")
End Sub
属性过程编程
用Property Get读属性，Property Let写（改变）属性，Property Set来给一个对象设置引用。
放置控件: Form1:Command1, Command2, Command3
代码:
Private Sizestatus As Boolean
Property Get Sizer() As Boolean
Sizer = Sizestatus
End Property
Property Let Sizer(x As Boolean)
Sizestatus = x
If x = False Then
Width = Width / 1.5
Else
Width = Width * 1.5
End If
End Property
Private Sub Command1_Click()
Sizer = False
End Sub
Private Sub Command2_Click()
Sizer = True
End Sub
Private Sub Command3_Click()
If Sizer = False Then Print "lessen form, Sizer=" & Sizer
If Sizer = True Then Print "larger form, Sizer=" & Sizer
End Sub
注意，在点击Command1时，调用Property Let过程。这时x作为sizer的值，带入进去计算。点击Command2时，调用Property Get过程。
十八 ActiveX控件网络实用编程
建立一个简单的ADO连接
1．在【控制面板】/【ODBC数据源】建立一个文件DSN，如test02.dsn，连接到本地的一个数据库，如C:/My Documents/共享/test1.mdb；
2．在VB中建立一个ActiveX控件工程（Gxue20）和一个用户控件（Uxue20.ctl）；
3．添加部件Microsoft ADO Data Control 6.0，把控件实例ADODC1加到Uxue20上；再添加一个Text1；
4．添加ADODC1属性ConnectionString，单击【。。。】，在对话框中选择【使用连接字符串】，选择test02.dsn，再将生成的字符串的本地地址DBQ=C:/My Documents/共享/test1.mdb….改为服务器地址，如DBQ=//xuewei/共享/test1.mdb…；再将RecordSource属性设为一个表名（如表1）；
5．把Text1绑定到ADODC1的表的“代码”字段上（设DataSource=ADODC1;DataField=代码）；
6．保存工程和控件；
7．使用【外接程序】/【打包和展开向导】，把Gxue20做成一个Internet包，放在一个WEB文件夹中。
8．这时可以在网络上运行自动生成文件Gxue20.htm了。
简单数据库打印
同前，把ADODC1加到Uxue20上；再添加一个Command1；
把上例ADODC1的ConnectinString值复制到程序中，再加上简单打印语句：
Private Sub Command1_Click()
Dim dbq1 As String
Dim pw, ph As Integer
Dim px, py As Integer
Dim temp As String
dbq1 = "DBQ=//xuewei/共享/test1.mdb;DefaultDir=c:/My Documents/共享/t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1
Adodc1.RecordSource = "select * from 表1"
Adodc1.Refresh
pw = 400: ph = 650
px = 20: py = 100
Printer.Scale (0, 0)-(pw, ph)
temp = Adodc1.Recordset(2)
py = py + 30
Printer.CurrentX = px
Printer.CurrentY = py
Printer.Print temp
Printer.EndDoc
MsgBox "打印完毕"
End Sub
程序运行结果，打印一行数据。
数据表直接打印
ActiveX控件制作：
1．新建ActiveX控件工程；
2．添加ADODC1控件和COMMAND1控件；
3．代码：
Option Explicit
Dim pw, ph '纸宽和纸高的坐标
Dim px, py
Dim ti
'报表字段数
Dim wh, ww '字宽和字高
Dim table1 '第一页表格开始高度
Dim daima(100, 3) As String
Dim bnum As Integer
Private Function len1(str As String) As Integer
Dim si, i As Integer
Dim str1 As String
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function len2(s2 As String, si As Integer) As String
Do While len1(s2) > si
s2 = Mid(s2, 1, Len(s2) - 1)
Loop
len2 = s2
End Function
Private Sub finput()
Dim i As Integer
ti = Adodc1.Recordset.Fields.Count
For i = 1 To ti
daima(i, 1) = Adodc1.Recordset.Fields(i - 1).Name
daima(i, 2) = len1(daima(i, 1)) + 2 '表格宽度
daima(i, 3) = Adodc1.Recordset.Fields(i - 1).Name
Next i
End Sub
Private Sub printhead()
Dim pp0, tpp, i
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
pp0 = 20 - (len1(Thead))
tpp = ""
For i = 1 To pp0
tpp = tpp + " "
Next i
Printer.Print tpp & Thead
table1 = 50
End Sub
Private Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)
Dim py1 As Integer
Dim pxm, pxi, px1, bi
Dim daim1, daim2 As String
pxm = 0
'计算报表宽度
For pxi = 1 To ti
pxm = pxm + daima(pxi, 2) * ww
Next
Printer.DrawWidth = 3
Printer.FontSize = 11
Printer.FontBold = True
py = pp1 + (pp3 + 2 - pp2) * wh
'计算报表高度
Printer.Line (0, pp1)-(pxm, pp1)
'打印边框
Printer.Line (pxm, pp1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, pp1)
Printer.DrawWidth = 1
'打印表头
px = 0
For pxi = 1 To ti
daim2 = daima(pxi, 1)
px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = pp1 + Int(0.2 * wh)
Printer.Print daima(pxi, 1) '打印字段名
px = px + daima(pxi, 2) * ww
Printer.Line (px, pp1)-(px, py) '打印竖线
Next
Printer.FontBold = False
py = pp1 + wh
For bi = pp2 To pp3
px = 0
For pxi = 1 To ti
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = daima(pxi, 3)
'Select Case daim1
'Case "序号": daim2 = bi
'打印序号
'Case "空白": daim2 = ""
'打印空白字段
'Case Else: daim2 = Adodc1.Recordset(daim1)
'End Select
If IsNull(Adodc1.Recordset(daim1)) Then
daim2 = ""
Else
daim2 = Adodc1.Recordset(daim1)
End If
Printer.Print len2(daim2, Int(daima(pxi, 2))) '打印字段内容
px = px + daima(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py) '打印横线
py = py + wh
Adodc1.Recordset.MoveNext
Next bi
End Sub
Private Sub printfoot(pp1 As Integer, pp2 As Integer)
'打印页码
px = pw - 300: py = ph - 5 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & pp2 & "
当前页数:" & pp1
End Sub
Private Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Call printframe(p1, p2, p3)
Call printfoot(p4, p5)
End Sub
Private Sub printbody()
Dim page As Integer
'页码数
Dim pi As Integer
Dim p1y As Integer
'第一页记录数
Dim p2y As Integer
'第二页记录数
Dim table2
'第二页起始位置
p2y = 37
table2 = 20
table1 = table1 + wh
p1y = (ph - table1 - 100) / wh
Adodc1.Recordset.MoveFirst
If bnum < p1y + 1 Then
Call printail(table1, 1, bnum, 1, 1) '只有一页
Else
page = Int(((bnum - p1y) / p2y) + 1.9999) '计算页码
Call printail(table1, 1, p1y, 1, page) '打印第一页
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页
Else
Printer.NewPage
Call printail(table2, p1y + 1, bnum, page, page) '打印最后一页
End If
End If
End Sub
Private Sub printp()
Dim sp
'左边距
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
‘开始打印
End Sub
Private Sub Command1_Click()
Dim dbq1
dbq1 = "DBQ=//xuewei/共享/test1.mdb;DefaultDir=c:/My Documents/共享/t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1
Adodc1.RecordSource = Tname
Adodc1.Refresh
bnum = Adodc1.Recordset.RecordCount
finput
printp
MsgBox "打印完毕。共有" & bnum & "条记录"
Adodc1.Recordset.Close
Command1.Enabled = False
End Sub
4．产生Tname和Thead属性的接口；
5．打成INTERNET包；
6．在网页上代码如下：
<HTML>
<HEAD>
<TITLE>Gxue32.CAB</TITLE>
</HEAD>
<BODY>
数据库表格打印示例
<p></p>
<OBJECT ID="Uxue32"
CLASSID="CLSID:0DF80DF0-B268-11D5-9C19-0010D70B5752"
CODEBASE="Gxue32.CAB#version=1,0,0,0" width="79" height="33">
<param name="_ExtentX" value="2090">
<param name="_ExtentY" value="873">
<param name="Tname" value="表1">
<param name="Thead" value="数据简表">
</OBJECT>
</BODY>
</HTML>
数据表格式打印
ActiveX控件制作步骤同上，增加一个Tarray属性，代码：
Option Explicit
Dim pw, ph '纸宽和纸高的坐标
Dim px, py
Dim ti
'报表字段数
Dim wh, ww '字宽和字高
Dim table1 '第一页表格开始高度
Dim daima(100, 3) As String
‘打印数组
Dim tax(100, 2) As String
‘格式数组
Dim bnum As Integer
‘总记录数
Private Function len1(str As String) As Integer
Dim si, i As Integer
Dim str1 As String
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function len2(s2 As String, si As Integer) As String
Do While len1(s2) > si
s2 = Mid(s2, 1, Len(s2) - 1)
Loop
len2 = s2
End Function
Private Function midx(taa) As String
Dim ii As Integer
Dim char1 As String
char1 = Mid(taa, 1, 1)
midx = ""
ii = 1
Do While char1 <> "{" And ii <= Len(taa) + 1
midx = midx & char1
ii = ii + 1
char1 = Mid(taa, ii, 1)
Loop
'If ii = Len(taa) Then midx = taa
'MsgBox "taa=" & taa & " midx=" & midx
End Function
Private Sub toarray(tt)
Dim ii As Integer
Dim tt0
tax(0, 0) = midx(tt)
tt0 = Mid(tt, Len(tax(0, 0)) + 2, Len(tt))
If tax(0, 0) > 0 Then
For ii = 1 To tax(0, 0)
tax(ii, 1) = midx(tt0)
tt0 = Mid(tt0, Len(tax(ii, 1)) + 2, Len(tt0))
tax(ii, 2) = midx(tt0)
tt0 = Mid(tt0, Len(tax(ii, 2)) + 2, Len(tt0))
Next ii
End If
End Sub
Private Sub finput()
Dim i As Integer
toarray (Tarray)
ti = Adodc1.Recordset.Fields.Count
If ti > tax(0, 0) Then ti = tax(0, 0)
For i = 1 To ti
daima(i, 1) = tax(i, 1)
daima(i, 2) = tax(i, 2) '表格宽度
daima(i, 3) = Adodc1.Recordset.Fields(i - 1).Name
Next i
End Sub
Private Sub printhead()
Dim pp0, tpp, i
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
pp0 = 20 - (len1(Thead))
tpp = ""
For i = 1 To pp0
tpp = tpp + " "
Next i
Printer.Print tpp & Thead
table1 = 50
End Sub
Private Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)
Dim py1 As Integer
Dim pxm, pxi, px1, bi
Dim daim1, daim2 As String
pxm = 0
'计算报表宽度
For pxi = 1 To ti
pxm = pxm + daima(pxi, 2) * ww
Next
Printer.DrawWidth = 3
Printer.FontSize = 11
Printer.FontBold = True
py = pp1 + (pp3 + 2 - pp2) * wh
'计算报表高度
Printer.Line (0, pp1)-(pxm, pp1)
'打印边框
Printer.Line (pxm, pp1)-(pxm, py)
Printer.Line (pxm, py)-(0, py)
Printer.Line (0, py)-(0, pp1)
Printer.DrawWidth = 1
'打印表头
px = 0
For pxi = 1 To ti
daim2 = daima(pxi, 1)
px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)
Printer.CurrentX = px + px1 * ww
Printer.CurrentY = pp1 + Int(0.2 * wh)
Printer.Print daima(pxi, 1) '打印字段名
px = px + daima(pxi, 2) * ww
Printer.Line (px, pp1)-(px, py) '打印竖线
Next
Printer.FontBold = False
py = pp1 + wh
For bi = pp2 To pp3
px = 0
For pxi = 1 To ti
Printer.CurrentX = px + 2
Printer.CurrentY = py + Int(0.2 * wh)
daim1 = daima(pxi, 3)
'Select Case daim1
'Case "序号": daim2 = bi
'打印序号
'Case "空白": daim2 = ""
'打印空白字段
'Case Else: daim2 = Adodc1.Recordset(daim1)
'End Select
If IsNull(Adodc1.Recordset(daim1)) Then
daim2 = ""
Else
daim2 = Adodc1.Recordset(daim1)
End If
Printer.Print len2(daim2, Int(daima(pxi, 2))) '打印字段内容
px = px + daima(pxi, 2) * ww
Next pxi
Printer.Line (0, py)-(pxm, py) '打印横线
py = py + wh
Adodc1.Recordset.MoveNext
Next bi
End Sub
Private Sub printfoot(pp1 As Integer, pp2 As Integer)
'打印页码
px = pw - 300: py = ph - 5 * wh
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print "总页数:" & pp2 & "
当前页数:" & pp1
End Sub
Private Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)
Call printframe(p1, p2, p3)
Call printfoot(p4, p5)
End Sub
Private Sub printbody()
Dim page As Integer
'页码数
Dim pi As Integer
Dim p1y As Integer
'第一页记录数
Dim p2y As Integer
'第二页记录数
Dim table2
'第二页起始位置
p2y = 37
table2 = 20
table1 = table1 + wh
p1y = (ph - table1 - 100) / wh
Adodc1.Recordset.MoveFirst
If bnum < p1y + 1 Then
Call printail(table1, 1, bnum, 1, 1) '只有一页
Else
page = Int(((bnum - p1y) / p2y) + 1.9999) '计算页码
Call printail(table1, 1, p1y, 1, page) '打印第一页
If page > 2 Then
For pi = 1 To page - 2
Printer.NewPage
Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)
Next pi
Printer.NewPage
Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页
Else
Printer.NewPage
Call printail(table2, p1y + 1, bnum, page, page) '打印最后一页
End If
End If
End Sub
Private Sub printp()
Dim sp
'左边距
pw = 850: ph = 600
wh = 13
ww = 9
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
End Sub
Private Sub Command1_Click()
Dim dbq1
dbq1 = "DBQ=//xuewei/共享/test1.mdb;DefaultDir=c:/My Documents/共享/t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"
Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1
Adodc1.RecordSource = Tname
Adodc1.Refresh
bnum = Adodc1.Recordset.RecordCount
finput
printp
MsgBox "打印完毕。共有" & bnum & "条记录"
Adodc1.Recordset.Close
Command1.Enabled = False
End Sub
打包后在网页上编程为：
<script language="vbscript">
<!--
Option Explicit
dim ta0(100,2)
Private Function len1(str)
Dim si, i
Dim str1
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function tostring ()
Dim ii
tostring = Ta0(0, 0) & "{"
For ii = 1 To Ta0(0, 0)
If IsNull(Ta0(ii, 1)) Then Ta0(ii, 1) = ""
tostring = tostring & Ta0(ii, 1) & "{"
If IsNull(Ta0(ii, 2)) Then Ta0(ii, 2) = 0
If Ta0(ii, 2) < len1(Ta0(ii, 1)) + 2 Then
Ta0(ii, 2) = len1(Ta0(ii, 1)) + 2
End If
tostring = tostring & Ta0(ii, 2) & "{"
Next
End Function
Private Sub window_onload()
form1.Uxue33.Tname = "注册登记表"
form1.Uxue33.Thead = "取水许可证系统注册登记表"
Ta0(0, 0) = "10"
Ta0(1, 1) = "注册名"
Ta0(1, 2) = "8"
Ta0(2, 1) = "密码"
Ta0(2, 2) = "8"
Ta0(3, 1) = "姓名"
Ta0(3, 2) = "8"
Ta0(4, 1) = "性别"
Ta0(4, 2) = "4"
Ta0(5, 1) = "单位"
Ta0(5, 2) = "16"
Ta0(6, 1) = "注册用途"
Ta0(6, 2) = "11"
Ta0(7, 1) = "电子信箱"
Ta0(7, 2) = "10"
Ta0(8, 1) = "批准"
Ta0(8, 2) = "6"
Ta0(9, 1) = "权限"
Ta0(9, 2) = "6"
Ta0(10, 1) = "取水用途"
Ta0(10, 2) = "10"
'Ta0(11, 1) = "fdsfd"
'Ta0(11, 2) = "8"
'Ta0(12, 1) = "123fdsfd"
'Ta0(12, 2) = "1"
form1.Uxue33.Tarray = tostring
msgbox form1.Uxue33.Tarray
end sub
-->
</script>
<form method="POST" action="" name="form1">
带参数打印示例<p>
<OBJECT ID="Uxue33"
CLASSID="CLSID:8083B900-B2AD-11D5-9C19-0010D70B5752"
CODEBASE="gxue33/Gxue33.CAB#version=1,0,0,0" width="82" height="34">
<param name="_ExtentX" value="2170">
<param name="_ExtentY" value="900">
<param name="Tname" value="0">
<param name="Thead" value="0">
<param name="Tarray" value="0">
</OBJECT>
文件打印
ActiveX控件制作步骤同上，增加Thead属性（传递文件标题）和Tarray属性（传递文件内容，第一个分解元素为文件内容行数）。
代码：
Option Explicit
Dim pw, ph '纸宽和纸高的坐标
Dim px, py
Dim sp
'左边距
Dim table1 '正文开始高度
Dim tax(100, 2) As String
Private Function len1(str As String) As Integer
Dim si, i As Integer
Dim str1 As String
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function midx(taa) As String
Dim ii As Integer
Dim char1 As String
char1 = Mid(taa, 1, 1)
midx = ""
ii = 1
Do While char1 <> "{" And ii <= Len(taa) + 1
midx = midx & char1
ii = ii + 1
char1 = Mid(taa, ii, 1)
Loop
End Function
Private Sub toarray(tt)
Dim ii As Integer
Dim tt0
tax(0, 0) = midx(tt)
tt0 = Mid(tt, Len(tax(0, 0)) + 2, Len(tt))
If tax(0, 0) > 0 Then
For ii = 1 To tax(0, 0)
tax(ii, 1) = midx(tt0)
tt0 = Mid(tt0, Len(tax(ii, 1)) + 2, Len(tt0))
tax(ii, 2) = midx(tt0)
tt0 = Mid(tt0, Len(tax(ii, 2)) + 2, Len(tt0))
'MsgBox tax(ii, 1)
Next ii
End If
End Sub
Private Sub printhead()
Dim pp0, tpp, i
Printer.CurrentX = 150: Printer.CurrentY = 30
Printer.FontSize = 19: Printer.FontBold = True
pp0 = 20 - (len1(Thead))
tpp = ""
For i = 1 To pp0
tpp = tpp + " "
Next i
Printer.Print tpp & Thead
table1 = 70
End Sub
Private Sub printbody()
'打印文字
Dim i
Printer.FontSize = 12: Printer.FontBold = False
px = sp: py = table1
For i = 1 To tax(0, 0)
Printer.CurrentX = px: Printer.CurrentY = py
Printer.Print tax(i, 1)
py = py + 20
Next i
End Sub
Private Sub printp()
pw = 850: ph = 600
sp = 40
Printer.Scale (-sp, 0)-(pw, ph)
printhead
printbody
Printer.EndDoc
End Sub
Private Sub Command1_Click()
toarray (Tarray)
printp
MsgBox "打印完毕"
Command1.Enabled = False
End Sub
网页程序为：
<script language="vbscript">
<!--
Option Explicit
Dim Ta0(100, 2)
Private Function len1(str)
Dim si, i
Dim str1
si = 0
For i = 1 To Len(str)
str1 = Mid(str, i, 1)
If Asc(str1) < 0 Then
si = si + 2
Else
si = si + 1
End If
Next
len1 = si
End Function
Private Function tostring()
Dim ii
tostring = Ta0(0, 0) & "{"
For ii = 1 To Ta0(0, 0)
If IsNull(Ta0(ii, 1)) Then Ta0(ii, 1) = ""
tostring = tostring & Ta0(ii, 1) & "{"
tostring = tostring & " {"
Next
End Function
Private Sub window_onload()
form1.Uxue34.Thead = "取水许可证通知书"
Ta0(0, 0) = 8
Ta0(1, 1) = "北京市第9水厂："
Ta0(2, 1) = "
你的取水许可证申请已经通过，请于近期前来我局领取取水许可证。"
Ta0(3, 1) = " "
Ta0(4, 1) = " "
Ta0(5, 1) = "
北京市水利局水资源处"
Ta0(6, 1) = " "
Ta0(7, 1) = "电话：66666666
EMAIL ：ziyuan@jwcb.gov.cn"
Ta0(8, 1) = "地址：海淀区翠微路甲3号 经办人：孟虹"
'Ta0(9, 1) = ""
'Ta0(10, 1) = ""
form1.Uxue34.Tarray = tostring
'MsgBox Uxue34.Tarray
End Sub
-->
</script>
<form method="POST" action="" name="form1">
<OBJECT ID="Uxue34"
CLASSID="CLSID:6502D511-B37F-11D5-9C19-0010D70B5752"
CODEBASE="Gxue34.CAB#version=1,0,0,0" width="82" height="34">
<param name="_ExtentX" value="2170">
<param name="_ExtentY" value="900">
<param name="Tarray" value="0">
<param name="Thead" value="0">
</OBJECT>
十九
编程实例
数据库冗余记录删除
'操作步骤：
'1.运行本程序，输入数据库组名、数据库名；
'2.输入判断冗余的主键的字段序号，第一个为0；
'3.输入表名；
'4.点击“删除”，可以在数据表中删除所有冗余的记录。
如图添加控件：
Option Explicit
Dim cnn As ADODB.Connection
'数据库连接
Dim Rst1 As ADODB.Recordset
Dim Rst2 As ADODB.Recordset
Private Sub Command1_Click()
Dim i As Long
'delete records number
Dim j As Long
'records series number
Dim si As String
Dim ts As String
'mast key value
Dim ti As Integer
'mast key position
Dim pi As Long
'progressBar value
Dim ri As Long
'records number
Dim rj As Long
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
ti = Text1.Text
ri = 0
While Not Rst2.EOF
Rst2.MoveNext
ri = ri + 1
Wend
i = 0
j = 1
pi = 0
rj = 0
ProgressBar1.Max = ri + 1
ProgressBar1.Min = 0
Rst2.MoveFirst
While Not Rst2.EOF
ts = Rst2.Fields(ti)
If tfind(ts, ti, j, Rst2) Then
Rst2.Delete
i = i + 1
j = j - 1
End If
Rst2.MoveNext
j = j + 1
rj = rj + 1
ProgressBar1.Value = rj
Wend
MsgBox "一共删除了" & i & "条记录。"
End Sub
Function tfind(ii As String, tti As Integer, jj As Long, rst As ADODB.Recordset) As Boolean
Dim bll As Boolean
Dim i As Long
tfind = False
bll = True
i = 0
rst.MoveNext
While Not rst.EOF And bll
If rst.Fields(tti) = ii Then
tfind = True
bll = False
End If
rst.MoveNext
Wend
rst.MoveFirst
For i = 0 To jj - 2
rst.MoveNext
Next i
End Function
Private Sub Command2_Click()
End
End Sub
Private Sub Command3_Click()
Dim si As String
si = "数据库冗余数据删除工具,by xuewei,04/20/2003"
frmSplash.Show
End Sub
Private Sub Form_Load()
Text1.Text = 0
Text3.Text = "biao2"
Text4.Text = "temp"
Text5.Text = "xue01"
End Sub
9857
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
