vb学习

 
使用静态变量
放置控件: 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
    选【调试】‖【添加监视】进入后,在【表达式】中写入m,然后点击【确定】。这时屏幕下方出现了含有m的监视窗口。再重复以上过程,把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,并形成组1。
运行前还要右击工程1,选择【设置为启动】,再引用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
 
 
已标记关键词 清除标记
©️2020 CSDN 皮肤主题: 大白 设计师:CSDN官方博客 返回首页