VB6常用方法汇编

使用静态变量

放置控件:  Form1:Label1,Command1

属性设置: cLabel1.Autosize= true

代码:

Private Sub Command1_Click()

  Static stflag As Boolean  '使用静态变量来保存变量值

  If stflag = False Then

    Label1.Font.Size = 14

    stflag = True

  Else

    Label1.Font.Size = 9

    stflag = False

  End If

End Sub

创建对象

放置控件:  Form1:Command1,text1

代码:

Private Sub Command1_Click()

  Dim t1 As TextBox

  Set t1 = Form1.Text1

  If t1.Text = 0 Then

    t1.BackColor = 0

    t1.ForeColor = 255

  End If

End Sub

 

       运行时，只要在Text1中写入0，点击Command1，Text1框就变色了。

如不用t1对象，则程序中t1.BackColor要写成form1.text1.BackColor，比较麻烦。

 

自定义方法和属性

放置控件:  Form1:Command1,text1

代码:

Public tsize As Integer  '定义属性

Public Sub textlarge()   '定义方法

  Text1.Width = Text1.Width * 1.1

  Text1.Height = Text1.Height * 1.1

  Text1.FontSize = Text1.FontSize + tsize

End Sub

 

Private Sub Command1_Click()

  Form1.tsize = 4

  Form1.textlarge

End Sub

遍历控件集合

放置控件:  Form1:Label1,Command1,text1,list1

代码:

Private Sub Form_Load()

  Dim myc1 As Control

  For Each myc1 In Controls

    List1.AddItem myc1.Name

  Next myc1

End Sub

 

集合寻址

放置控件:  Form1:Label1,Command1,text1,list1

代码:

Private Sub Command1_Click()

  Text1 = Controls(3).Left

  'Text1 = Controls("label1").Left

  'Text1 = Controls!label1.Left

End Sub

代码换行和并行

变量：

  a1 = 2: a2 = 3: a3 = 4  '并行

  b1 = a1 + a2 + _        '换行

    a3

 

对于字符串：

  s1 = “sadd” & c1 & “qwer”   '联接

  s1 = “sadd” & c1 & “qwer” & _  '换行

       “fjkgjgj06”

打印和显示换行

  s1 = ”fjdkkjd” & vbcrlf & “iioknno”

强迫变量声明

       Option Explicit

还可以在菜单【工具】‖【选项】(编辑器)中选[要求变量声明]，自动在每个模块上加Option Explicit

查找字符串显示长度

Public Function len1(str As String) As Integer  ‘公用函数

  Dim si, i As Integer

  Dim str1 As String

  si = 0

  For i = 1 To Len(str)

    str1 = Mid(str, i, 1)

    If Asc(str1) < 0 Then

      si = si + 2             ‘汉字长度为2

    Else

      si = si + 1

    End If

  Next

  len1 = si

End Function

截取字符串定长

Public Function len2(s2 As String, si As Integer) As String

  Do While len1(s2) > si

    s2 = Mid(s2, 1, Len(s2) - 1)

  Loop

  len2 = s2

End Function

截取并补齐定长字符串

Public Function len3(s2 As String, si As Integer) As String

  If len1(s2) > si Then

   Do While len1(s2) > si

    s2 = Mid(s2, 1, Len(s2) - 1) ‘长了截断

   Loop

  Else

   Do While len1(s2) < si

     s2 = s2 & " "               ‘短了用空格补齐

   Loop

  End If

  len3 = s2

End Function

模糊查找

Sub shumlook(ByVal shu2 As String)

  Dim shu3 As String

shu3 = Mid(shu3, 1, Len(shu2))

If shu3 = shu2 Then

 

End if

End Sub

清除字符串的所有空格

Function Trimk(cc0)

  Dim i, j, s1

  j = Len(cc0)

  i = 1

  While i < j + 1

    s1 = Mid(cc0, i, 1)

    'MsgBox "s1=" & s1 & ";"

    If s1 = " " Or s1 = "　" Then

      cc0 = Mid(cc0, 1, i - 1) + Mid(cc0, i + 1, j)

      i = i - 1

      'MsgBox "cc0=" & cc0

    End If

    i = i + 1

  Wend

  Trimk = cc0

End Function

读取当前日期和时间

放置控件:  Form1:Text1,Text2，Command1

代码:

Private Sub Command1_Click()

  Dim d1 As Date

  d1 = Date

  Text1 = d1   '显示如00-6-24

  d1 = Time

  Text2 = d1   '显示如10:30:23

End Sub

输入日期并计算

放置控件:  Form1:Text1,Text2，Command1

代码:

Private Sub Command1_Click()

  Dim d1 As Date

  d1 = Text1

  d1 = d1 - 100

  Text2 = d1

  Text1 = Weekday(d1)

End Sub

 

运行时先在Text1中输入日期(如00-5-30)，再点击Command1，则在Text2中显示输入日期100天前的日期，并在Text1中显示该日期为星期几。

返回年、月、日、时、分、秒的函数为year,month,day,hour,minute,second。

       注意Weekday返回1代表星期天，2代表星期一，7代表星期六。

初始化事件和终止事件

当调用一个窗体时，一般首先引发initialize事件，再引发load事件。但只是引用窗体上数据或过程时，可能不引发load事件。只有当调用控件时，才引发load。

       当终止窗体时，先引发unload事件，再引发terminate事件。但只用unload form1时，并不能引发terminate事件，这时窗体中的过程和变量仍然可以引用。只有用set form1=nothing才能引发ternimate事件。

不定长数组

先定义数组Dim array1 ( )

使用时再用ReDim ( 3, 9 )

或 ReDim (1 to 3, 1 to 9 )

用FORMAT决定数据格式

1．日期和时间

以系统设置的长日期格式返回当前系统日期。

Print Format(Date, "Long Date")   ‘返回2001年10月29日

MyStr = Format(MyTime, "h:m:s")   ' 返回 "17:4:23"。

MyStr = Format(MyTime, "hh:mm:ss AMPM")   ' 返回 "05:04:23 PM"。

MyStr = Format(MyDate, "dddd, mmm d yyyy")   ' 返回 "Wednesday, Jan 27 1993"。

  2．数字

MyStr = Format(5459.4, "##,##0.00")   ' 返回 "5,459.40"。

MyStr = Format(334.9, "###0.00")   ' 返回 "334.90"。

MyStr = Format(0.5, "0.00%")   ' 返回 "50.00%"。

简化：如aa = 1235432 / 3

Print Format(aa, "0.000")   ‘返回411810.667

整数：Print Format(123, "00000")    ‘返回00123

  3.字符

小写：MyStr = Format("HELLO", "<")   ' 返回 "hello"。

大写：MyStr = Format("This is it", ">")   ' 返回 "THIS IS IT"。

如果没有指定格式，则返回原字符串。

MyStr = Format(23)   ' 返回 "23"。

记录变量

先在模块（如Module1）中定义：

Type QipuRec

   qx As Integer

   qy As Integer

   qColor As string

End Type

再在Form1中添加：

Dim QiShu(1 To 400) As QipuRec

就可以引用QiShu.qx，QiShu.qy了。

 

二  常用控件

调用不同的Form

放置控件:  Form1:Command1,Command2; Form2:Command1

属性设置: 〖Form1.Command1.Caption〗= 进入Form2

          〖Form1.Command2.Caption〗= 退出

          〖Form2.Command1.Caption〗= 返回Form1

Form1代码:

Private Sub Command1_Click()

  Form2.Show

End Sub

 

Private Sub Command2_Click()

  End

End Sub

Form2代码

Private Sub Command1_Click()

  Form2.Hide

  Form1.Show

End Sub

用OptionButton单选

放置控件:  Form1:Option1,Option2,Option3,Label1

属性设置: 〖Option1.Caption〗=BASIC

          〖Option2.Caption〗=PASCAL

          〖Option3.Caption〗=C

代码:

Private Sub Option1_Click()

  Label1.Caption="BASIC"

End Sub

Private Sub Option2_Click()

  Label1.Caption="PASCAL"

End Sub

Private Sub Option3_Click()

  Label1.Caption="C"

End Sub

用Check复选

放置控件:  Form1:Text1,Check1,Check2

属性设置: 〖Text1.text〗=字体演示

代码:

Private Sub  Check1_Click()

  If Check1.Value＝1 then     '选中

    Text1.FontSize＝14        '字体为14号,大字

  Else                        '取消

    Text1.FontSize=9          '字体为9号,普通字

  End If

End Sub

 

Private Sub Check2_Click()

  If  Check2.Value=1 then

    Text1.FontItalic=True       '设斜体

  Else

    Text1.FontItalic=False      '恢复正常

  End If

End Sub

选择ComboBox表值

放置控件: Form1:Combo1(ComboBox)

代码:

Private Sub Combo1_Click()

  s1 = Combo1.Text

  Print "您选中的是: ";s1

End Sub

 

Private Sub Form_Load()

  Combo1.AddItem "初中"

  Combo1.AddItem "高中"

  Combo1.AddItem "大学"

End Sub

ListBox从程序赋值

放置控件: Form1:list1(ListBox),label1

代码:

Private Sub Form_Load()

  List1.AddItem "a1"       '用AddItem方法赋值

  List1.AddItem "a2"

  List1.AddItem "a3"

End Sub

 

Private Sub List1_Click()

  Select Case List1.ListIndex      'ListIndex值为0,1,2

    Case 0: Label1.Caption = "ok1"

    Case 1: Label1.Caption = "ok2"

    Case 2: Label1.Caption = "ok3"

  End Select

End Sub

使用MsgBox双向选择

放置控件: Form1:Command1

属性设置:〖Command1.Caption〗=Exit

代码:

Private Sub Command1_Click()

  myexit = MsgBox("确实想退出吗?", VbOkCancel, "退出")

  If myexit = VbOk Then

Unload Me

  Else

    Debug.Print “放弃退出”

  End If

End Sub

用InputBox输入数值

放置控件: Form1:Command1

属性设置:〖Command1.Caption〗=开始

代码:

Private Sub Command1_Click()

  Dim string1 As String

  Dim int1 As Integer

  string1 = InputBox("Input")

  int1 = Val(string1)  

  '可直接用int1 = Val(InputBox("input"))

  Print "int1="; int1

End Sub

复杂InputBox输入

Private Sub Command1_Click()

  qs = 1.2

  qs1 = 1.2

  ts1 = "2001-2002年乡及乡以上工业增长" & qs & "%，修改后按‘确定’"

  s1 = Val(InputBox(ts1, "计算修改", qs1))

  If s1 <> "" And s1 <> "0" Then

    MsgBox "2002年乡及乡以上工业用水=" & s1 * 123 & "亿立方米。"

  Else

    MsgBox "放弃修改。"

  End If

End Sub

用Timer作定时器

放置控件:  Form1:Text1,Timer1

属性设置: 〖Timer1.Interval〗=1000  '1000ms

代码:

Private Sub Timer1_Timer()

  If Text1.Text <> "10:02:00" Then

    Text1.Text = Time

  Else                             '时间到

    Text1.Text = "OK"

    Timer1.Enabled = False         '不再显示时间

  End If

End Sub

用Timer编制延时程序

放置控件:  Form1:Command1,Timer1

属性设置: 〖Timer1.Interval〗=10  '10ms

代码:

Sub delay(ss As Integer)    '延时过程

  Dim start, check

  start = Timer

  Do

    check = Timer

  Loop While check < start + ss * 0.001

End Sub

 

Private Sub Command1_Click()

  Command1.Caption = "test1"

  delay (1000)

  Command1.Caption = "test2"

  delay (2000)

  Unload Me                 '退出

End Sub

使用File控件

Private Sub Form_Load()

  File1.Pattern = “*.txt”

  File1.Path = “C:/fxfx/kfb”

End Sub

 

如果使用目录列表控件Dir1，则可以用

         File1.Path = Dir1

接可以联动使用。

使用COMMONDIALOG控件

在部件的控件中打开Microsoft Common Dialog Control 6.0 (SP)，再添加CommonDialog1、Command1和Text1控件。运行时打开文件对话框，并将选中的文件显示在文本框中。

Private Sub Command1_Click()

  On Error GoTo errhandler

  CommonDialog1.Filter = "All Files(*.*)|*.*|Text Files(*.txt)|*.txt"

  CommonDialog1.FilterIndex = 1 ‘缺省为All Files

  CommonDialog1.ShowOpen

  Text1 = CommonDialog1.FileName

  Exit Sub

errhandler:

  Exit Sub

End Sub

 

CommonDialog控件还可以显示颜色对话框（CommonDialog1.showcolor），字体对话框（CommonDialog1.showfont），打印对话框（CommonDialog1.printer），显示帮助对话框（用CommonDialog1.HelpFile=”C:/Windows/Cadio.hlp”设置，用CommonDialog1.ShowHelp调用）。

取消窗体的按钮组

Form1.ControlBox = False

使用Microsoft Flex Grid 6.0控件绑定数据库

直接添加后设置即可；

 

运行时动态改变控件数组

先在FORM中添加一个COMBO控件，再复制一个成为控件数组，把COMBO1（1）删除，再把COMBO1（0）移到左上角，添加一个COMMAND在右边，编码如下：

Private Sub Command1_Click()

  Unload Combo1(5)            ‘去掉一个控件

End Sub

 

Private Sub Form_Load()

  c1y = 600

  For i = 1 To 5                ‘增加一组控件

    Load Combo1(i)

    Combo1(i).Top = c1y

    Combo1(i).Left = 100

    c1y = c1y + 500

    Combo1(i).Visible = True

  Next

End Sub

StatusBar使用

在部件的控件中打开Microsoft Common Dialog Control 6.0 (SP)，再添加Statusbar控件。右击添加窗格，并调整宽度。

添加文字时程序为：

StatusBar1.Panels(1).text = "比例  1 : " & Format$(sbScaleBar1.RFScale, "###,###,###,###,###")

VbModal调用方式

采用VbModal方式调用FORM，可以在其运行完成后在执行下一语句，如：

frmTip.Show vbModal

MsgBox TipType

如果在frmTip中设定TipType=100，则可以显示出这个值来。

ProgressBar的使用

在部件的控件中打开Microsoft Windows Common Control 6.0，再添加ProgressBar控件。

编程时，要先设ProgressBar1.Max（一般为最大循环数加1）和ProgressBar1.Min（一般为0），再在循环中加上一个和循环数同步的变量，如si，再用

ProgressBar1.Value = si

就可以实现进程条的结果了。

在FOR循环中的例子为：

Private Sub Command1_Click()

  Dim i As Long

  Dim j As Long

  Dim si As Long

  si = 0

  ProgressBar1.Max = 10001

  ProgressBar1.Min = 0

  For i = 0 To 10000

    For j = 0 To 1000

      a = "sdf"

    Next j

    si = si + 1

    ProgressBar1.Value = si

  Next i

  MsgBox "end"

End Sub

 

在数据库操作中的例子为：

ProgressBar1.Max = ri + 1        ‘ri为全部记录数；

  ProgressBar1.Min = 0

  Rst2.MoveFirst

  While Not Rst2.EOF

    ……

    rj = rj + 1

    ProgressBar1.Value = rj

  Wend

 

三  控件编程基本方法

控件输入位置和聚焦

放置控件:  Form1:Text1,Command1

代码:

Private Sub Command1_Click()

  Text1.SelStart = 3  '光标在第3个位置

  Text1.SetFocus  '使焦点回到Text1

End Sub

使用容器控件

容器控件有：Frame，PictureBox和ToolBar。

使用容器控件包容其它控件的方法有：

1．先产生容器控件，在其上画其它控件；

2．把已有控件剪贴到容器控件上；

3．用程序 Command1.Container = Frame1

用一键来回设置

放置控件:  Form1:Command1,List1

代码:

Private Sub Command1_Click()

  If Bzl then

List1.Visible = True

        Command1.Cption = “Exit”

Bzl = false

  Else

List1.Visible = False

Command1.Caption = “Display”

Bzl = True

  End If

End Sub

 

Private Sub Form_Load()

  Bzl = Ture

  List1.Visiblae = False

  Command1.Caption = “Display”

End Sub

列表控件的选择属性

以List1 的属性为例，列表类控件如List,Combo,File,Dir等均可使用：

1．选中第I项               List1.Selected(i)  （True）

2．返回第I项内容   List1.List(i)

3．返回列表总项数   List1.ListCount

4．返回最近一次点击位置  List1.ListIndex

 

注意：I均从零开始。

列表控件的全选

  For i = 0 To File1.ListCount - 1

    File1.Selected(i) = True

  Next

列表控件的部份选择

  Dim fscount, i, j

  Dim fs1(100) As String

  j = 0

  For i = 0 To File1.ListCount - 1

    If File1.Selected(i) Then

      fs1(j) = File1.List(i)

      j = j + 1

    End If

  Next

  fscount = j

使用TreeView控件产生目录

在【部件】中选择“Microsoft Windows Common Control 6.0（SP3）”，就可以打开一组控件，有Tabstrip、Toolbar、Statusbar、Progressbar、Treeview、Listview、Imagelist、Slider、Imagecombo。

把Treeview1和Imagelist1加入窗体；

右击Imagelist1，打开属性页，添加图形；

右击Treeview1，打开属性页，在【图像列表】中选择Imagelist1，还可以改变自目录的缩进；

改变Treeview1属性Linestyle为1；

添加代码：

Private Sub TreeView1_NodeClick(ByVal Node As MSComctlLib.Node)

  Select Case Node.Key

    Case "fx1"

      Hyperlink.NavigateTo ("http://b4x5d1/faexcise/fa1/default1.asp")

    Case "fx2"

      Hyperlink.NavigateTo ("http://b4x5d1/faexcise/fa1/create1.asp")

  End Select

End Sub

 

Private Sub UserDocument_Initialize()

  Dim mynode As Node

  Set mynode = TreeView1.Nodes.Add(, , "fx", "发行系统", 2)

  Set mynode = TreeView1.Nodes.Add(, , "cb", "出版系统", 2)

  Set mynode = TreeView1.Nodes.Add(, , "cw", "财务系统", 2)

  Set mynode = TreeView1.Nodes.Add(, , "bw", "编务系统", 2)

  Set mynode = TreeView1.Nodes.Add(, , "xt", "系统管理", 2)

  '二级目录

  Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx1", "批销", 3)

  Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx2", "样书", 3)

  Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx3", "发行管理", 3)

  Set mynode = TreeView1.Nodes.Add("fx", tvwChild, "fx4", "查询", 3)

  mynode.EnsureVisible

End Sub

 

四  错误处理

使用监视窗口调试的例子

放置控件:  Form1:Command1

属性设置: 〖Command1.Caption〗=开始计算

代码:

Private Sub Command1_Click()

  n = 4

  'm = 1

  For i = 1 To n

    m = m * i

  Next i

  Print "m="; m

End Sub

    选【调试】‖【添加监视】进入后，在【表达式】中写入ｍ，然后点击【确定】。这时屏幕下方出现了含有ｍ的监视窗口。再重复以上过程，把n也加入到监视窗口。

    按F8键进行单步调试（即每按一下F8运行一行），逐步检查监视窗口的变量变化。点击【Command1】后，再按F8继续运行。如果屏幕下部先出现【立即】窗口，则把它关掉，再从菜单上选取【窗口】‖【监视窗口】把监视窗口调出来。

用InputBox输入数值时的错误处理

发生错误时继续调用InputBox，直到正确。

Private Sub Command1_Click()

  Dim s11 As Integer

  Dim s2 As String

  On Error GoTo head

head1:

  s2 = InputBox("请输入单价:")

  If s2 <> "" Then

    s11 = s2

  End If

  Exit Sub

head:

  MsgBox "输入错！请重新输入"

  Resume head1

End Sub

用Resume Next处理错误

发生错误时退出Command1.

Private Sub Command1_Click()

Dim s11 as Integer

Dim s2 As String

  On Error GoTo head

  s2 = InputBox("请输入单价:")

  If s2 <> "" Then

    s11 = s2

  End If

  Exit Sub

head:

  MsgBox "输入错！请重新输入"

  Resume Next

End Sub

用Text控件输入数值时的错误处理

Private Sub Command1_Click()

  Dim i1 As Integer

  On Error GoTo handle

  i1 = Text1

  MsgBox "输入正确,i1=" & i1

  Exit Sub

handle:

  MsgBox "输入错误!"

  Text1 = ""

  Exit Sub

End Sub

 

Private Sub Form_Load()

  Text1 = ""

End Sub

用输入窗体时的错误处理

放置控件: Form1:Command1, Form2:Command1,Text1,Module1

Module1代码:

Public i1 As Integer

 

Form1代码:

Private Sub Command1_Click()

  Form2.Show vbModal

  MsgBox "输入完成,i1=" & i1

End Sub

 

Form2代码:

Private Sub Command1_Click()

  On Error GoTo handle

  i1 = Text1

  MsgBox "输入正确,i1=" & i1

  Unload Me

  Exit Sub

handle:

  MsgBox "输入错误!"

  Text1 = ""

  Exit Sub

End Sub

 

Private Sub Form_Load()

  Text1 = ""

End Sub

显示错误信息

On Error Resume Next   ' 改变错误处理的方式。

Err.Clear

Err.Raise 6   ' 生成一个溢出（Overflow）的错误。

' 检查错误代号，显示相关错误信息。

If Err.Number <> 0 Then

   Msg = "Error # " & Str(Err.Number) & " was generated by " _

         & Err.Source & Chr(13) & Err.Description

   MsgBox Msg, , "Error", Err.Helpfile, Err.HelpContext

End If

 

五  打印

用Currentx、y指定Print位置

放置控件: Form1:Command1,command2,text1

代码:

Dim g1, g2 As Integer

Private Sub Command1_Click()

  g1 = g1 + 200

  Cwrite

End Sub

 

Private Sub Command2_Click()

  g2 = g2 + 200

  Cwrite

End Sub

 

Sub Cwrite()

  Cls                   '清除上次字符串

  CurrentX = g1

  CurrentY = g2

  Print "Position test."

End Sub

用Printer方法编程打印

1．设页面坐标

pw = 400: ph = 650

      Printer.Scale (0, 0)-(pw, ph)

       注：以上设置只能设页面坐标，不能设置页面大小。要设置页面大小到Windows/打印机/属性/中去设置。对于标准连续打印纸，设Letter。

2．设字体

Printer.FontName = “黑体”     

Printer.FontSize = 10           '5号字

Printer.FontBold = True         '粗体

3．打印位置

Printer.CurrentX = 110

Printer.CurrentY = 30

4．打印数据

Printer.Print "中国水利水电出版社入库单"

Printer.Print "单号: " & tnum

5．画表格线

Printer.DrawWidth = 3              '线宽

Printer.Line (20,20) – (300,300)

6．打印份数

Printer.Copies = 2

7．换页

Printer.NewPage

8．打印开始

Printer.EndDoc

 

注意:只要使用Printer方法，不管是否用Printer.EndDoc，程序运行完时均要打印。

改变页面位置

如用          Printer.Scale (0, 0)-(pw, ph)

增大左边界           Printer.Scale (-50, 0)-(pw, ph)

整体左移      Printer.Scale (-50, 0)-(pw-50, ph)

增大上边界           Printer.Scale (0, -50)-(pw, ph)

增大下边界           Printer.Scale (0, 0)-(pw, ph+50)

整体下移      Printer.Scale (0, -50)-(pw, ph-50)

直接用printer打印表格

Private Sub cmdprint_Click()

Dim n As Integer

Dim rs As New ADODB.Recordset

rs.Open "SELECT * FROM jggz", "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:/jggz/jggz.mdb;Persist Security Info=False", adOpenStatic, adLockPessimistic

n = 0

rs.MoveFirst

Form1.Print "┌────┬────┐"

While Not rs.EOF

    Printer.Print "│" & rs.Fields("姓名").Value; Tab(11); "│"; rs.Fields("课时工资"); Tab(21); "│"

   

    rs.MoveNext

    n = n + 1

    If n / 5 = Int(n / 5) Or rs.EOF Then

        Printer.Print "└────┴────┘"

        Printer.Print "┌────┬────┐"

    Else

        Printer.Print "├────┼────┤"

    End If

Wend

Printer.Print "└────┴────┘"

rs.Close

End Sub

附件1：制表符号区位对照

区位	0904	0906	0916	0920	0924	0940	0948
符号	─	│	┌	┐	└	┤	┬
区位	0956	0964	0905	0907	0919	0931	0939
符号	┴	┼	━	┃	┏	┛	┣
区位	0947	0955	0963	0979	0936	0959
符号	┫	┳	┻	╋	┠	┷

 

 

 

六  绘图

使用Pset画点

放置控件:  Form1:Command1

属性设置: 〖Command1.Caption〗=开始

代码:

Private Sub Command1_Click()

  Const pi = 3.14159

  Dim x0, y0 As Single

  Dim x1, y1 As Integer

  x0 = 0

  Do While x0 <= 4 * pi          '画两个相位

    y0 = Sin(x0)

    x1 = x0 * 400                '放大400倍

    y1 = y0 * 400 + 1000

    PSet (x1, y1)                '画点

    x0 = x0 + 0.01               '步长为0.01

  Loop

End Sub

使用Line画线

放置控件:  Form1:Command1

属性设置: 〖Command1.Caption〗=开始画图

代码:

Private Sub Command1_Click()

  Line (100, 100)-(1000, 1000)

  Line -(0, 500)          '第一点缺省采用当前点，即（1000，1000）

  Line -(100, 100)        '完成一个三角形

End Sub

使用Line擦除线段

放置控件:  Form1:Command1,Command2

属性设置: 〖Command1.Caption〗=画线,〖Command2.Caption〗=擦除

代码:

Private Sub Command1_Click()

  DrawMode = 1

  Line (0, 0)-(1000, 1000)

End Sub

 

Private Sub Command2_Click()

  DrawMode = 7

  Line (0, 0)-(1000, 1000), BackColor

End Sub

使用Circle画弧

放置控件:  Form1:Command1

属性设置: 〖Command1.Caption〗=开始画图

代码:

Private Sub Command1_Click()

  Const Pi = 3.1416

  Circle (1000, 1000), 500, , 0, Pi  '画一个从0度到π(180)度的弧

End Sub

用鼠标画园饼并擦除

放置控件:  Form1

代码:

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Static x0, y0 As Integer         '保存上一个鼠标位置的参数

  FillStyle = 0                    '设置填充模式

  Circle (x0, y0), 200, BackColor  '擦除上一个园饼

  Refresh                          '重画

  DrawMode = 1                     '绘图方式还原

  Circle (X, Y), 200

  x0 = X                           '保存当前鼠标位置

  y0 = Y

  DrawMode = 7                     '使用XOR绘图方式准备擦图

End Sub

 

如果要在已有背景上擦除，用以下程序：

Private Sub Command1_Click()

  DrawMode = 1

  Line (0, 0)-(1000, 1000)

End Sub

 

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

  Static x0, y0 As Integer         '保存上一个鼠标位置的参数

  FillStyle = 0                    '设置填充模式

  DrawMode = 7                     '使用XOR绘图方式准备擦图

  Circle (x0, y0), 200, BackColor  '擦除上一个园饼

  Refresh                          '重画

  Command1_Click

  DrawMode = 1                     '绘图方式还原

  Circle (X, Y), 200

  x0 = X                           '保存当前鼠标位置

  y0 = Y

End Sub

用PictureBox做简单的动画

放置控件:  Form1:Picture1,Picture2,Picture3,Command1,timer1

属性设置: 〖Picture1.Autosize〗=true,〖Picture1.Picture〗=bfly1.bmp

          〖Picture2.Autosize〗=true,〖Picture2.Picture〗=bfly2.bmp

          〖Picture3.Autosize〗=true

          〖Command1.Caption〗=开始

          〖timer1.Interval〗=10

注意:bmp文件从c:/program files/microsoft visual/msdn98/98vs/vcr/选取

代码:

Option Explicit

Sub delay(ss As Integer)     '延时程序,ss单位为毫秒(ms)

  Dim start, check

  start = Timer

  Do

    check = Timer

  Loop While check < start + ss * 0.001

End Sub

 

Private Sub Command1_Click()

  Dim i As Integer

  For i = 1 To 10                        '蝴蝶扇动10下翅膀

    Picture3.Picture = Picture1.Picture  '显示图1

    delay (100)                          '延时100毫秒

    Picture3.Picture = Picture2.Picture  '显示图2

    delay (100)

  Next i

End Sub

用PictureBox做动画(用DoEvents中断)

放置控件:  Form1:P1,P2,P3(PictureBox),Command1,Command2,timer1

属性设置: 〖P1.Autosize〗=true,〖P1.Picture〗=bfly1.bmp

          〖P2.Autosize〗=true,〖P2.Picture〗=bfly2.bmp

          〖P3.Autosize〗=true

          〖Command1.Caption〗=开始

          〖Command2.Caption〗=退出,〖Command2.Visible〗=False

          〖timer1.Interval〗=10

          〖Form1.BackColor〗=白   '从调色板上选取

注意:bmp文件从c:/program files/microsoft visual/msdn98/98vs/vcr/选取

代码:

Option Explicit

Sub delay(ss As Integer)

  Dim start, check

  start = Timer

  Do

    check = Timer

  Loop While check < start + ss * 0.001

End Sub

 

Sub flying()                '飞翔过程

  Const d1 = 30

  P3.Picture = P1.Picture

  delay (d1)

  P3.Picture = P2.Picture

  delay (d1)

End Sub

 

Private Sub Command1_Click()

  Dim mx0, my0 As Integer     '随机产生的x,y方向的步长

  Dim mx, my As Integer       '转换方向后的步长

  Dim k As Integer            '步长系数

  Dim bl As Integer           '中断检测计数

 

  k = 400

  mx0 = k * Rnd: my0 = k * Rnd '赋初始值

  mx = mx0: my = my0

  

  Do

    Command1.Visible = False

    If P3.Left < 0 Then                     '如果碰到左边界

      mx0 = k * Rnd: my0 = k * Rnd          '向右飞

      mx = mx0: my = 2 * (my0 - k / 2)

    End If

    If P3.Left > Form1.Width - P3.Width Then '如果碰到右边界

      mx0 = k * Rnd: my0 = k * Rnd           '向左飞

      mx = -mx0: my = 2 * (my0 - k / 2)

    End If

    If P3.Top < 0 Then                       '如果碰到上边界

      mx0 = k * Rnd: my0 = k * Rnd           '向下飞

      mx = 2 * (mx0 - k / 2): my = my0

    End If

    If P3.Top > Form1.Height - P3.Height Then '如果碰到下边界

      mx0 = k * Rnd: my0 = k * Rnd            '向上飞

      mx = 2 * (mx0 - k / 2): my = -my0

    End If

 

    P3.Picture = LoadPicture           '清除上一幅图

    P3.Move P3.Left + mx, P3.Top + my  '按设定的步长移动

    flying                             '调用飞翔过程

    Form1.Refresh                      '重画

   

    bl = bl + 1                        '中断程序

    If bl > 100 Then                   '设飞动100次中断1次

      Command2.Visible = True          '显示"退出"按钮

      Refresh

      delay (3000)                     '停3秒等待用户点击"退出"按钮

      DoEvents                         '中断处理

      Command2.Visible = False         '如用户没有选退出,再将按钮隐藏

      bl = 0                           '重新计数

    End If

  Loop Until 1 = 2                     '无限循环

End Sub

 

Private Sub Command2_Click()

  End

End Sub

用Image做复杂一点的动画

放置控件:  Form1:P1,P2,P3(Image),Command1,timer1

属性设置: 〖P1.Stretch〗=true,〖P1.Picture〗=bfly1.bmp

          〖P2.Stretch〗=true,〖P2.Picture〗=bfly2.bmp

          〖P3.Stretch〗=true

          〖timer1.Interval〗=10

          〖Form1.BackColor〗=白   '从调色板上选取

注意:bmp文件从c:/program files/microsoft visual/msdn98/98vs/vcr/选取

代码:

Option Explicit             '强制变量说明

Dim mx0, my0 As Integer     '随机产生的x,y方向的步长

Dim mx, my As Integer       '转换方向后的步长

Dim k As Integer            '步长系数

Dim doflag As Boolean       '检测Command1的Click的标记

 

Sub delay(ss As Integer)    '延时过程

  Dim start, check

  start = Timer

  Do

    check = Timer

  Loop While check < start + ss * 0.001

End Sub

 

Sub flying()                         '飞翔过程

  Const d1 = 40

  p3.Picture = LoadPicture           '清除上一幅图

  p3.Move p3.Left + mx, p3.Top + my  '按设定的步长移动

 

  p3.Picture = p1.Picture            '显示第一幅图

  Refresh

  delay (d1 * 3)

  p3.Picture = p2.Picture            '显示第二幅图

  Refresh

  delay (d1)

End Sub

 

Sub fly_direction()

  If p3.Left < 0 Then                     '如果碰到左边界

    mx0 = k * Rnd: my0 = k * Rnd          '向右随机方向飞

    mx = mx0: my = 2 * (my0 - k / 2)

  End If

  If p3.Left > Form1.Width - p3.Width Then '如果碰到右边界

    mx0 = k * Rnd: my0 = k * Rnd           '向左随机方向飞

    mx = -mx0: my = 2 * (my0 - k / 2)

  End If

  If p3.Top < 0 Then                       '如果碰到上边界

    mx0 = k * Rnd: my0 = k * Rnd           '向下随机方向飞

    mx = 2 * (mx0 - k / 2): my = my0

  End If

  If p3.Top > Form1.Height - p3.Height Then '如果碰到下边界

    mx0 = k * Rnd: my0 = k * Rnd            '向上随机方向飞

    mx = 2 * (mx0 - k / 2): my = -my0

  End If

  flying                             '调用飞翔过程

End Sub

 

Private Sub Command1_Click()

  Select Case doflag

    Case True

      Command1.Caption = "开始"

      doflag = False

      Cls

    Case False

      Command1.Caption = "停止"

      doflag = True

      mx0 = k * Rnd: my0 = k * Rnd    '赋初始值

      mx = mx0: my = my0

   End Select

End Sub

 

Private Sub Form_Load()

  k = 600

  doflag = False

End Sub

 

Private Sub Timer1_Timer()  '时钟控件随时检测,如果没有点击

  If doflag Then            'Command1(停止),则继续调用动画程序

    fly_direction

  End If

End Sub

 

七  报表

用数据库控件产生简单的数据报表

放置控件: Form1:Data1,Command1

属性设置: 〖Data1.DatabseName〗="Nwind.mdb",〖Data1.Recordsource〗=categories

说明:1.Data1中可设置任何普通数据库

     2.输出报表到一个.txt文件,可以在WORD或其它编辑软件中编辑.

     3.编辑时设行距为零(WORD中设固定值=10磅).

代码:

Option Explicit

Dim f1 As Field                '字段变量

Dim fi As Integer              '字段数

Dim pagerow As Integer         '每页行数

Dim rptcaption As String       '报表标题字符串

Dim repage As Integer          '报表页数

Dim repfield() As Integer      '字段宽度数组

Dim maxwidth as integer        '最大字段宽度

Dim repwidth As Integer        '报表总宽

Dim leftspace As Integer       '报表左边起始位置

Dim chi As Integer             '中文字符数

 

Function len1(str1 As String) As Integer

'返回字符串绝对长度(如len1("你好!")=5)

  Dim l1 As String

  Dim i, ln1 As Integer

  len1 = 0

  For i = 1 To Len(str1)

    l1 = Mid$(str1, i, 1)

    If Asc(l1) < 0 Then         '中文字符

      ln1 = 2

    Else

      ln1 = 1

    End If

    len1 = len1 + ln1

  Next i

End Function

 

Sub CreateRptField()           

'比较字段名和字段长度,决定字段宽度并计算报表总宽

  ReDim repfield(fi) As Integer   '使用变长数组 

  Dim fname, fsize As Integer    

  Dim fi1 As Integer

  repwidth = leftspace + 2

  For fi1 = 0 To fi - 1

    Set f1 = Data1.Recordset.Fields(fi1)

    fname = Int((len1(f1.Name) + 1) / 2 + 0.5) * 2

    fsize = Int((f1.Size + 1) / 2 + 0.5) * 2

    If fsize > maxwidth Then fsize = maxwidth '限定字段宽度

    If fname > fsize Then

      repfield(fi1) = fname

    Else

      repfield(fi1) = fsize

    End If

    repwidth = repwidth + repfield(fi1) + 2

  Next fi1

End Sub

 

Sub repline(str1, str2, str3, str4 As String) '打印表线

  Dim fi1, fi2 As Integer

  Dim rl As Integer

  For fi1 = 1 To leftspace

    Print #1, " ";

  Next fi1

  Print #1, str1;

  For fi2 = 1 To Int(repfield(0) / 2)

    Print #1, str2;

  Next fi2

  For fi1 = 1 To fi - 1

    Print #1, str3;

    For fi2 = 1 To Int(repfield(fi1) / 2)

      Print #1, str2;

    Next fi2

  Next fi1

  Print #1, str4

End Sub

 

Sub rptheadline(str1 As String)   '打印标题和页码

  Dim start, fi1 As Integer

  Print #1,

  If Int(repwidth / 2) - Int(len1(str1) / 2) > 10 + leftspace Then

    start = Int(repwidth / 2) - Int(len1(str1) / 2) + leftspace

    For fi1 = 1 To start

      Print #1, " ";

    Next fi1

    Print #1, str1, "      -"; repage; "-"

  Else

    For fi1 = 1 To leftspace

      Print #1, " ";

    Next fi1

    Print #1, str1, "      -"; repage; "-"

  End If

  Print #1,

End Sub

 

Function leftstr(str1 As String, fsize As Integer) As String

'返回字符串str1左边fsize(绝对长度)长子串

  If len1(str1) <= fsize Then

    leftstr = str1

  Else

    Do While len1(str1) > fsize

      str1 = Left$(str1, Len(str1) - 1)

    Loop

    leftstr = str1

  End If

End Function

 

Function checkfield(str1 As Variant, int1 As Integer) As String

'检查记录变量str1的类型,并使它的绝对长度不超过int1

  Dim str2 As String

  If IsNull(Data1.Recordset(f1.SourceField)) Then '处理空记录

    checkfield = ""

  ElseIf f1.Type = 11 Then                    '处理binary类型记录

    checkfield = ""

  Else

    str2 = str1                               '强制转换为string

    checkfield = leftstr(str2, int1)

  End If

End Function

 

Sub rpthead()                                 '打印表头

  Dim fi1, ti, chi As Integer

  Call repline("┏", "━", "┳", "┓")

  For fi1 = 1 To leftspace

    Print #1, " ";

  Next fi1

  ti = leftspace + 1

  For fi1 = 0 To fi - 1

    Print #1, "┃";

    Set f1 = Data1.Recordset.Fields(fi1)             '取出当前字段

    ti = ti + repfield(fi1) + 2

    chi = len1(f1.SourceField) - Len(f1.SourceField) '设置打印变换

    ti = ti - chi - 1                                '设置打印变换

    Print #1, f1.SourceField; Tab(ti);               '打印当前字段名

  Next fi1

  Print #1, "┃"

  Call repline("┣", "━", "╇", "┫")

End Sub

 

Sub rptrecord()                                   '打印记录行             

  Dim fi1, ti As Integer

  Dim temp As String                              '记录内容

  For fi1 = 1 To leftspace                        '以下先打印第一字段

    Print #1, " ";

  Next fi1

  Print #1, "┃";

  ti = leftspace + 3

  Set f1 = Data1.Recordset.Fields(0)              '取出第一个字段

  ti = ti + repfield(0)

  temp = checkfield(Data1.Recordset(f1.SourceField), repfield(0))

  chi = len1(temp) - Len(temp)                    '设置打印变换

  ti = ti - chi - 1                               '设置打印变换

  Print #1, temp; Tab(ti);                        '打印记录内容

  For fi1 = 1 To fi - 1                           '以下打印其余字段

    Print #1, "│";

    Set f1 = Data1.Recordset.Fields(fi1)

    ti = ti + repfield(fi1) + 2

    temp = checkfield(Data1.Recordset(f1.SourceField), repfield(fi1))

    chi = len1(temp) - Len(temp)                  '设置打印变换

    ti = ti - chi - 1                             '设置打印变换

    Print #1, temp; Tab(ti);

  Next fi1

  Print #1, "┃"

End Sub

 

Sub repform()                                   '打印报表

  Dim li As Integer                             '报表行数变量

  Dim pbl As Boolean                            '表行类型标记

  repage = 1

  li = 1

  pbl = True

  Do While Not Data1.Recordset.EOF             

    If pbl Then                                 '表行为起始行,要打印表头

      Call rptheadline(rptcaption)

      Call rpthead

      pbl = False

    Else                                        '表行为普通记录

      Call repline("┠", "─", "┼", "┨")

    End If

    Call rptrecord

         

    li = li + 1

    If li = pagerow Then                        '到达页尾

      Call repline("┗", "━", "┷", "┛")

      Print #1,

      repage = repage + 1

      li = 1

      pbl = True                                '设置起始行标记

    End If

    Data1.Recordset.MoveNext                    '移动到下一记录

  Loop

  If Not pbl Then                               '全报表完时打印表底线

    Call repline("┗", "━", "┷", "┛")

    Print #1,

  End If

End Sub

 

Private Sub Command1_Click()                    '主程序

  Open "test.txt" For Output As #1              '打开报表文件

  leftspace = 0                                 '设置报表左边距

  fi = Data1.Recordset.Fields.Count             '找到当前记录集的字段数

  Call CreateRptField                           '决定每个字段宽度

  rptcaption = "报  表  示  例"                 '给出标题

  maxwidth=10                                   '给出最大字段宽度

  pagerow = 20                                  '给出每页行数

  Call repform                                  '打印报表

  Close #1                                      '关闭报表文件

End Sub

用数据库打印报表

放置控件:  Form1:Command1,Command2

说明：读mdb数据库rst1打印表格，表格参数在daima数组中。

代码：

Option Explicit

Dim pw, ph '纸宽和纸高的坐标

Dim px, py

Dim ti   '报表字段数

Dim wh, ww  '字宽和字高

Dim table1  '第一页表格开始高度

Dim daima(100, 3) as String 

 

Sub finput()

  ti = 7

  daima(1, 1) = "序号"

  daima(1, 2) = 6           '表格宽度

  daima(1, 3) = "序号"

 

  daima(2, 1) = "代码"

  daima(2, 2) = 8

  daima(2, 3) = "scode"      '字段名

 

  daima(3, 1) = "库位号"

  daima(3, 2) = 8

  daima(3, 3) = "skwh"

 

  daima(4, 1) = "书名"

  daima(4, 2) = 36

  daima(4, 3) = "sname"

 

  daima(5, 1) = "单价"

  daima(5, 2) = 8

  daima(5, 3) = "sdanjia"

 

  daima(6, 1) = "出版日期"

  daima(6, 2) = 10

  daima(6, 3) = "syear"

 

  daima(7, 1) = "备注"

  daima(7, 2) = 10

  daima(7, 3) = "空白"

 End Sub

 

Sub printhead()

  Printer.CurrentX = 150: Printer.CurrentY = 30

  Printer.FontSize = 19: Printer.FontBold = True

  Printer.Print "中国水利水电出版社业务清单"

  table1 = 50

End Sub

 

Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)

  Dim py1 As Integer

  Dim pxm, pxi, px1, bi

  Dim daim1, daim2 As String

 

  pxm = 0                           '计算报表宽度

  For pxi = 1 To ti

    pxm = pxm + daima(pxi, 2) * ww

  Next

 

  Printer.DrawWidth = 3

  Printer.FontSize = 11

  Printer.FontBold = True

  py = pp1 + (pp3 + 2 - pp2) * wh      '计算报表高度

 

  Printer.Line (0, pp1)-(pxm, pp1)     '打印边框

  Printer.Line (pxm, pp1)-(pxm, py)

  Printer.Line (pxm, py)-(0, py)

  Printer.Line (0, py)-(0, pp1)

 

  Printer.DrawWidth = 1                '打印表头

  px = 0

  For pxi = 1 To ti

    daim2 = daima(pxi, 1)

    px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)

    Printer.CurrentX = px + px1 * ww

    Printer.CurrentY = pp1 + Int(0.2 * wh)

    Printer.Print daima(pxi, 1)                  '打印字段名

    px = px + daima(pxi, 2) * ww

    Printer.Line (px, pp1)-(px, py)              '打印竖线

  Next

 

  Printer.FontBold = False

  py = pp1 + wh

  For bi = pp2 To pp3

    px = 0

    For pxi = 1 To ti

      Printer.CurrentX = px + 2

      Printer.CurrentY = py + Int(0.2 * wh)

      daim1 = daima(pxi, 3)

      Select Case daim1

        Case "序号": daim2 = bi                 '打印序号

        Case "空白": daim2 = ""                 '打印空白字段

        Case Else: daim2 = rst1(daim1)

      End Select

      Printer.Print len2(daim2, Int(daima(pxi, 2)))  '打印字段内容

      px = px + daima(pxi, 2) * ww

    Next pxi

    Printer.Line (0, py)-(pxm, py)                   '打印横线

    py = py + wh

    rst1.MoveNext

  Next bi

  End Sub

 

Sub printfoot(pp1 As Integer, pp2 As Integer)        '打印页码

  px = pw - 300: py = ph - 5 * wh

  Printer.CurrentX = px: Printer.CurrentY = py

  Printer.Print "总页数:" & pp2 & "    当前页数:" & pp1

End Sub

 

Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)

  Call printframe(p1, p2, p3)

  Call printfoot(p4, p5)

End Sub

 

Sub printbody()

  Dim page As Integer     '页码数

  Dim pi As Integer

  Dim p1y As Integer      '第一页记录数

  Dim p2y As Integer      '第二页记录数

  Dim table2              '第二页起始位置

 

  p2y = 37

  table2 = 20

  table1 = table1 + wh

  p1y = (ph - table1 - 100) / wh

 

  rst1.MoveFirst

  If bnum < p1y + 1 Then

    Call printail(table1, 1, bnum, 1, 1)         '只有一页

  Else

    page = Int(((bnum - p1y) / p2y) + 1.9999)    '计算页码

    Call printail(table1, 1, p1y, 1, page)       '打印第一页

    If page > 2 Then

      For pi = 1 To page - 2

        Printer.NewPage

        Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)

      Next pi

      Printer.NewPage

      Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页

    Else

      Printer.NewPage

      Call printail(table2, p1y + 1, bnum, page, page)  '打印最后一页

    End If

  End If

End Sub

 

Sub printp()

  Dim sp    ‘左边距

  pw = 850: ph = 600

  wh = 13

  ww = 9

  sp = 40     Printer.Scale (-sp, 0)-(pw, ph)

  printhead

  printbody

  Printer.EndDoc

End Sub

 

Private Sub Command1_Click()

  bnum = rst1.RecordCount

  finput

  printp

End Sub

 

Private Sub Command3_Click()

  Unload Me

End Sub

 

Private Sub Form_Load()

  Dim str1, strcnn

  strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _

  "Data Source=" & fpath1 & "shukux.mdb"

  Set cnn2 = New ADODB.Connection

  cnn2.Open strcnn

  Set rst1 = New ADODB.Recordset

  rst1.CursorType = adOpenKeyset

  rst1.LockType = adLockOptimistic

  rst1.Open "shu00", cnn2, , , adCmdTable

End Sub

用数据库转数组打印报表

放置控件:  Form1:Command1,Command3

说明：读mdb数据库转数组打印表格，daima数组放表格参数,dai1数组放纪录参数。

代码：

Option Explicit

Dim pw, ph, px, py As Integer

Dim ti   '报表字段数

Dim wh, ww  'word height and width

Dim table1  '第一页表格起始位置

Dim dai1(400, 8) As String

 

Sub finput()

  ti = 7

  daima(1, 1) = "序号"

  daima(1, 2) = 6

  daima(1, 3) = 0

 

  daima(2, 1) = "代码"

  daima(2, 2) = 8

  daima(2, 3) = 1

 

  daima(3, 1) = "库位号"

  daima(3, 2) = 8

  daima(3, 3) = 2

 

  daima(4, 1) = "书名"

  daima(4, 2) = 36

  daima(4, 3) = 3

 

  daima(5, 1) = "单价"

  daima(5, 2) = 8

  daima(5, 3) = 4

 

  daima(6, 1) = "出版日期"

  daima(6, 2) = 10

  daima(6, 3) = 5

 

  daima(7, 1) = "备注"

  daima(7, 2) = 10

  daima(7, 3) = 6

 

End Sub

 

Sub finput2()

  Dim di

  di = 0

  rst1.MoveFirst

  Do While Not rst1.EOF

    di = di + 1

    dai1(di, 0) = di

    dai1(di, 1) = rst1!scode

    dai1(di, 2) = rst1!skwh

    dai1(di, 3) = rst1!sname

    dai1(di, 4) = rst1!sdanjia

    dai1(di, 5) = rst1!syear

    dai1(di, 6) = ""

    rst1.MoveNext

  Loop

End Sub

 

Sub printhead()

  Dim x1, x2, x3

  Printer.CurrentX = 150: Printer.CurrentY = 30

  Printer.FontSize = 19: Printer.FontBold = True

  Printer.Print "中国水利水电出版社业务清单"

  table1 = 50

 

  clh = "k0405"

  x1 = 20: x2 = 270: x3 = 520

  Printer.CurrentX = x1: Printer.CurrentY = table1

  Printer.FontSize = 9: Printer.FontBold = False

  Printer.Print "处理单号: " & clh

  Printer.CurrentX = x2: Printer.CurrentY = table1

  Printer.Print "制单日期: 20" & Now

  Printer.CurrentX = x3: Printer.CurrentY = table1

  Printer.Print "制单人  : "

  table1 = table1 + wh

End Sub

 

Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)

  Dim py1 As Integer

  Dim pxm, pxi, px1, bi

  Dim daim1, daim2 As String

 

  pxm = 0

  For pxi = 1 To ti

    pxm = pxm + daima(pxi, 2) * ww

  Next

  Printer.DrawWidth = 3

  Printer.FontSize = 11

  Printer.FontBold = True

  py = pp1 + (pp3 + 2 - pp2) * wh

  Printer.Line (0, pp1)-(pxm, pp1)

  Printer.Line (pxm, pp1)-(pxm, py)

  Printer.Line (pxm, py)-(0, py)

  Printer.Line (0, py)-(0, pp1)

  Printer.DrawWidth = 1

  px = 0

  For pxi = 1 To ti

    daim2 = daima(pxi, 1)

    px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)

    Printer.CurrentX = px + px1 * ww

    Printer.CurrentY = pp1 + Int(0.2 * wh)

    Printer.Print daima(pxi, 1)

   

    px = px + daima(pxi, 2) * ww

    Printer.Line (px, pp1)-(px, py)

  Next

 

  Printer.FontBold = False

  py = pp1 + wh

  For bi = pp2 To pp3

    px = 0

    For pxi = 1 To ti

      Printer.CurrentX = px + 2

      Printer.CurrentY = py + Int(0.2 * wh)

      daim1 = daima(pxi, 3)

      daim2 = dai1(bi, daim1)

      Printer.Print len2(daim2, Int(daima(pxi, 2)))

      px = px + daima(pxi, 2) * ww

    Next pxi

    Printer.Line (0, py)-(pxm, py)

    py = py + wh

    rst1.MoveNext

  Next bi

End Sub

 

Sub printfoot(pp1 As Integer, pp2 As Integer)

  px = pw - 300: py = ph - 5 * wh

  Printer.CurrentX = px: Printer.CurrentY = py

  Printer.Print "总页数:" & pp2 & "    当前页数:" & pp1

End Sub

 

Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)

  Call printframe(p1, p2, p3)

  Call printfoot(p4, p5)

End Sub

 

Sub printbody()

  Dim page As Integer

  Dim pi As Integer

  Dim p1y As Integer

  Dim p2y As Integer 'first page lines and other page lines

  Dim table2

  p2y = 37 '44

  table2 = 20

  table1 = table1 + wh

  p1y = (ph - table1 - 100) / wh

 

  rst1.MoveFirst

  If bnum < p1y + 1 Then

    Call printail(table1, 1, bnum, 1, 1)

  Else

    page = Int(((bnum - p1y) / p2y) + 1.9999)

    Call printail(table1, 1, p1y, 1, page)

    If page > 2 Then

      For pi = 1 To page - 2

        Printer.NewPage

        Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)

      Next pi

      Printer.NewPage

      Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page)

    Else

      Printer.NewPage

      Call printail(table2, p1y + 1, bnum, page, page)

    End If

  End If

End Sub

 

Sub printp()

  Dim sp

  pw = 850: ph = 600

  wh = 13

  ww = 9

  sp = 40

  Printer.Scale (-sp, 0)-(pw, ph)

  printhead

  printbody

  Printer.EndDoc

End Sub

 

Private Sub Command1_Click()

  bnum = rst1.RecordCount

  finput

  finput2

  printp

End Sub

 

Private Sub Command3_Click()

  Unload Me

End Sub

 

Private Sub Form_Load()

  Dim str1, strcnn

  strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _

  "Data Source=" & fpath1 & "shukux.mdb"

  Set cnn2 = New ADODB.Connection

  cnn2.Open strcnn

  Set rst1 = New ADODB.Recordset

  rst1.CursorType = adOpenKeyset

  rst1.LockType = adLockOptimistic

  rst1.Open "shu00", cnn2, , , adCmdTable

End Sub

用数组打印报表

建立模块Module1：

Dim wh, ww  'word height and width

Dim pw, ph, px, py As Integer

Dim table1  '第一页表格起始位置

Dim pxm     '表宽

 

Sub printhead()

  Dim i

  '计算表宽

  pxm = 0

  For i = 0 To txI - 1

    pxm = pxm + tx(i, 2) * ww

  Next

  '打印标题

  table1 = 0

  For i = 0 To tyI - 1

    Printer.FontName = ty(i, 0)

    Printer.FontSize = ty(i, 1)

    Printer.FontBold = ty(i, 2)

    Printer.CurrentX = ty(i, 3)

    Printer.CurrentY = ty(i, 4)

    Printer.Print ty(i, 5)

    table1 = ty(i, 4)

    '画下划线

    If ty(i, 6) = 1 Then

      Printer.DrawWidth = 2

      Printer.Line (0, table1 + 10)-(pxm, table1 + 10)

    End If

  Next

End Sub

 

Sub printa(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)

  Dim py1 As Integer

  Dim pxi, px1, bi

  Dim daim1, daim2 As String

  

  '打印表格线

  Printer.DrawWidth = 3

  py = p1 + (p3 + 2 - p2) * wh

  Printer.Line (0, p1)-(pxm, p1)

  Printer.Line (pxm, p1)-(pxm, py)

  Printer.Line (pxm, py)-(0, py)

  Printer.Line (0, py)-(0, p1)

 

  '打印表头

  Printer.DrawWidth = 1

  Printer.FontSize = 11

  Printer.FontBold = True

  px = 0

  For pxi = 0 To txI - 1

    daim2 = tx(pxi, 1)

    px1 = Int((tx(pxi, 2) - len1(daim2)) / 2)

    Printer.CurrentX = px + px1 * ww

    Printer.CurrentY = p1 + Int(0.2 * wh)

    Printer.Print tx(pxi, 1)

    px = px + tx(pxi, 2) * ww

    Printer.Line (px, p1)-(px, py)

  Next

 

  '打印表格内容

  Printer.FontBold = False

  py = p1 + wh

  For bi = p2 To p3

    px = 0

    For pxi = 0 To txI - 1

      Printer.CurrentX = px + 2

      Printer.CurrentY = py + Int(0.2 * wh)

      daim1 = tx(pxi, 3)

      daim2 = tz(bi - 1, daim1)

 

      Printer.Print daim2   'len2(daim2, Int(tx(pxi, 2)))

      px = px + tx(pxi, 2) * ww

     

    Next pxi

    Printer.Line (0, py)-(pxm, py)

    py = py + wh

  Next bi

 

  '打印页码

  px = Int(0.6 * pw): py = ph - 7 * wh

  Printer.CurrentX = px: Printer.CurrentY = py

  Printer.Print "总页数:" & p5 & "    当前页数:" & p4

End Sub

 

Sub printbody()

  Dim page As Integer

  Dim pi As Integer

  Dim p1y As Integer

  Dim p2y As Integer 'first page lines and other page lines

  Dim table2

  'p2y = 38

  table2 = 0

  table1 = table1 + wh

  p1y = (ph - table1 - 115) / wh

  p2y = (ph - 115) / wh

  MsgBox p2y

 

  If tzI < p1y + 1 Then

    Call printa(table1, 1, tzI, 1, 1)

  Else

    page = Int(((tzI - p1y) / p2y) + 1.9999)

    Call printa(table1, 1, p1y, 1, page)

    If page > 2 Then

      For pi = 1 To page - 2

        Printer.NewPage

        Call printa(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)

      Next pi

      Printer.NewPage

      Call printa(table2, p1y + (page - 2) * p2y + 1, tzI, page, page)

    Else

      Printer.NewPage

      Call printa(table2, p1y + 1, tzI, page, page)

    End If

  End If

End Sub

 

Sub printp()

  Dim sp

  If tzI < 1 Then Exit Sub

  pw = 850: ph = 600

  wh = 13

  ww = 9

  sp = 40

  Printer.Scale (0, 0)-(pw, ph)

  printhead

  printbody

  Printer.EndDoc

End Sub

 

在其它模块中调用时，只要先给出tx，ty，tz数组值和txI，tyI，tzI，再调用Module1.printp即可。例如：

Sub tabledatax()

  txI = 10              ‘10列

  tx(0, 1) = "序号"     ‘表标题

  tx(0, 2) = 4          ‘表宽(4个字)

  tx(0, 3) = 0          ‘序号

 

  tx(1, 1) = "代码"

  tx(1, 2) = 8

  tx(1, 3) = 1

 

  tx(2, 1) = "库位号"

  tx(2, 2) = 8

  tx(2, 3) = 2

 

  tx(3, 1) = "单价"

  tx(3, 2) = 7

  tx(3, 3) = 3

 

  tx(4, 1) = "书      名"

  tx(4, 2) = 33

  tx(4, 3) = 4

 

  tx(5, 1) = "册数"

  tx(5, 2) = 6

  tx(5, 3) = 5

 

  tx(6, 1) = "码洋"

  tx(6, 2) = 7

  tx(6, 3) = 6

  

  tx(7, 1) = "折扣"

  tx(7, 2) = 5

  tx(7, 3) = 7

 

  tx(8, 1) = "实洋"

  tx(8, 2) = 7

  tx(8, 3) = 8

 

  tx(9, 1) = "包+册"

  tx(9, 2) = 8

  tx(9, 3) = 9

 

End Sub

 

Sub tabledatay()

  Dim px1, px2, px3, py

  Dim wh0

  wh0 = 10

  tyI = 10

  px1 = 20

  px2 = 370

  px3 = 620

   

  ty(0, 0) = "宋体"      ‘字体

  ty(0, 1) = 17          ‘字号

  ty(0, 2) = 1           ‘加粗

  ty(0, 3) = 180         ‘Current X

  ty(0, 4) = 10          ‘Current Y

  ty(0, 5) = "中国水利水电出版社批销业务清单"

  ty(0, 6) = 0           ‘是否加线

 

  py = 30

  ty(1, 0) = "宋体"

  ty(1, 1) = 10

  ty(1, 2) = 0

  ty(1, 3) = px1

  ty(1, 4) = py

  ty(1, 5) = "处理单号: " & clh

  ty(1, 6) = 0

 

  ty(2, 0) = "宋体"

  ty(2, 1) = 10

  ty(2, 2) = 0

  ty(2, 3) = px2

  ty(2, 4) = py

  ty(2, 5) = "制单日期: 20" & ddate

  ty(2, 6) = 0

 

  ty(3, 0) = "宋体"

  ty(3, 1) = 10

  ty(3, 2) = 0

  ty(3, 3) = px3

  ty(3, 4) = py

  ty(3, 5) = "提书单编号: " & numb

  ty(3, 6) = 1                      ‘加下划线

 

  py = py + 20

  ty(4, 0) = "宋体"

  ty(4, 1) = 10

  ty(4, 2) = 0

  ty(4, 3) = px1

  ty(4, 4) = py

  ty(4, 5) = "购货单位: " & len2(uname, 36)

  ty(4, 6) = 0

 

  ty(5, 0) = "宋体"

  ty(5, 1) = 10

  ty(5, 2) = 0

  ty(5, 3) = px2

  ty(5, 4) = py

  ty(5, 5) = "总册数　: " & zce

  ty(5, 6) = 0

 

  ty(6, 0) = "宋体"

  ty(6, 1) = 10

  ty(6, 2) = 0

  ty(6, 3) = px3

  ty(6, 4) = py

  ty(6, 5) = "制单人　: "

  ty(6, 6) = 0

 

  py = py + wh0

  ty(7, 0) = "宋体"

  ty(7, 1) = 10

  ty(7, 2) = 0

  ty(7, 3) = px1

  ty(7, 4) = py

  ty(7, 5) = "地　　址: " & add

  ty(7, 6) = 0

 

  ty(8, 0) = "宋体"

  ty(8, 1) = 10

  ty(8, 2) = 0

  ty(8, 3) = px2

  ty(8, 4) = py

  ty(8, 5) = "总码洋　: " & zma

  ty(8, 6) = 0

 

  ty(9, 0) = "宋体"

  ty(9, 1) = 10

  ty(9, 2) = 0

  ty(9, 3) = px3

  ty(9, 4) = py

  ty(9, 5) = "计算件数: " & zl

  ty(9, 6) = 0

End Sub

 

Sub tabledataz()

  Dim i, bb As Integer, dd1 As Single

  tzI = bnum

  For i = 0 To tzI - 1

    tz(i, 0) = i + 1

    tz(i, 1) = code(i)

    tz(i, 2) = kwh(i)

    tz(i, 3) = Xiao2(danjia(i))

    tz(i, 4) = len2(bname(i), 35)

    tz(i, 5) = " " & shice(i)

    dd1 = danjia(i) * shice(i)

    tz(i, 6) = Xiao2(dd1)

    tz(i, 7) = "0" & bzhe(i)

    dd1 = danjia(i) * shice(i) * bzhe(i)

    tz(i, 8) = Xiao2(dd1)

    bb = Int(shice(i) / bag(i))

    tz(i, 9) = bb & "+" & shice(i) - bb * bag(i) & "(" & bag(i) & ")"

  Next

End Sub

 

Sub print_pxd()

  tabledatax

  tabledatay

  tabledataz

  Module1.printp        ‘调用打印表格模块

End Sub

用REPORT产生报表

1．新建标准工程1；

2．添加数据环境：选择菜单【工程】/【更多ActiveX设计器】/【DataEnvironment】，添加DataEnvironment1；

3．建立ODBC连接：

（1）在【控制面板】/【ODBC数据源】/【系统DNS】中设置数据库连接，如test0；

（2）右击【Connection1】，选择【属性】，出现“数据链接”对话框：

       （3）在“提供者”属性页中选择【…for ODBC Drivers】；

       （4）在“连接”属性页中选择【使用连接字符串】，单击【编译】/【机器数据源】，选中需要的数据连接，如test0，单击【确定】；

       （5）单击【测试连接】，如通过，可以进行下一步；

4．添加连接命令：右击【Connection1】，选择【添加命令】，出现“Command1”;

5．设置连接命令：右击【Command1】，选择【属性】，出现“属性”对话框，设【数据库对象】为【表】，【对象名称】为所需要的表名，如“取水户基本信息表”，单击+号，可以展开表，如图所示：

 

6．添加报表：选择菜单【工程】/【添加DataReport】，添加DataReport1；

7．设置报表连接：在右边的属性面板中设【DataSource】为【DataEnvironment1】，【DataMember】为【Command1】；

8．设置报表数据：把各字段从DataEnvironment1拖到DataReport1，再加以排列；注意：拖动的字段有2块，左边是字段名（可以放在“页标头”栏中），右边是字段值（要放在“细节”栏中）；

9．设置报表标题：右击报表，选择【插入控件】/【标签】，在报表标头栏中放置；还可以在“页注脚”栏中插入页码；

10．设置报表边框：右击报表，选择【插入控件】/【形状】，调整矩形大小，在每个字段和字段名上放置一个复制控件（Shape）；

11．显示报表：在工程的Form1（或UserControl1）中添加一个按钮，在其上添加代码：

DataReport1.Show

然后就可以运行了。运行时既可以显示，也可以打印报表。

 

如建立ActiveX控件，要先建立一个标准EXE工程（用于调试），再建立一个ActiveX控件，在其上如上操作。

 

 

八  数据库控件

用数据库控件实现数据库浏览

放置控件:  Form1:Data1,Combo1,Text1,Text2,Lbel1,Label2,Label3

属性设置: 〖Combo1.Datasource〗=data1

          〖Text1.Datasource〗=data1

          〖Text2.Datasource〗=data1

           其余Text1,Text2,Label1,Label2,Label3的属性见图8.4

                        Data1的RecordsetType属性为0（table）

代码:

Private Sub Form_Load()

  Data1.DatabaseName = "biblio.mdb"       '调入"图书管理数据库"

  Data1.RecordSource = "select distinct STATE from publishers "

  Data1.Refresh

  Do While Not Data1.Recordset.EOF       '给Combo1赋值

    temp = Data1.Recordset("State")

    If IsNull(temp) Then temp = ""

    Combo1.AddItem CStr(temp)

    Data1.Recordset.MoveNext

  Loop

 

  Data1.RecordSource = "publishers"      '改变Recordset为全表

  Data1.Refresh

  Text1.DataField = "name"

  Text2.DataField = "city"

  Combo1.DataField = "state"

End Sub

在控件DATAI中显示总记录和当前记录

先设置全局变量firstflag，并在FormLoad中设为True，

Private Sub Data1_Reposition()          '重新定位记录时显示记录号

  If firstflag Then                     '如果是首次使用

    Data1.Caption = ""                  'data1标题框显示空白

    firstflag = False

  Else                                  '如果不是首次使用，则在

                                        ' data1标题框显示记录号

    Data1.Caption = "总记录数:" & Data1.Recordset.RecordCount _

      & "  当前记录:" & Data1.Recordset.AbsolutePosition + 1

  End If

 

用数据库控件实现数据录入/删除

放置控件:  Form1:Data1;Text1,2;Lbel1,2;Command1,2,3,4,5;Frame1

属性设置:

    Data1:〖DatabseName〗="Nwind.mdb",〖Recordsource〗=products

    Text1:〖Datasource〗=data1,〖Datafield〗=produtID,〖TabIndex〗=0

    Text2:〖Datasource〗=data1,〖Datafield〗=produtName,〖TabIndex〗=1

    Command1:〖Name〗=Cmdadd,〖Caption〗=增加

    Command2:〖Name〗=Cmddelete,〖Caption〗=删除

    Command3:〖Name〗=Cmdexit,〖Caption〗=退出

    Command4:〖Name〗=Cmdupdate,〖Caption〗=确定

    Command5:〖Name〗=Cmdcancel,〖Caption〗=放弃

    Frame1中包含Command4,5

    其余Text1,2,Label1,2和Command1,2,3,4,5的位置属性见图8.5

代码:

Option Explicit

Dim firstflag As Boolean                 '首次使用标记

 

Private Sub Cmdadd_Click()               '增加记录

  Data1.Recordset.AddNew

  Frame1.Visible = True                  '使主按钮组不可见

  Data1.Caption = "记录:" & Data1.Recordset.RecordCount + 1

  Text1.SetFocus

End Sub

 

Private Sub Cmdcancel_Click()           '放弃录入的记录

  Data1.Recordset.CancelUpdate

  Frame1.Visible = False                '使主按钮组可见

  Data1.Recordset.MoveLast              '回到最后一个记录

End Sub

 

Private Sub Cmdupdate_Click()           '确定录入的记录有效

  Data1.Recordset.Update

  Frame1.Visible = False                '使主按钮组可见

  Data1.Recordset.MoveLast              '显示录入内容

End Sub

 

Private Sub Data1_Reposition()          '重新定位记录时显示记录号

  If firstflag Then                     '如果是首次使用

    Data1.Caption = ""                  'data1标题框显示空白

    firstflag = False

  Else                                  '如果不是首次使用，则在

                                        ' data1标题框显示记录号

    Data1.Caption = "总记录数:" & Data1.Recordset.RecordCount _

      & "  当前记录:" & Data1.Recordset.AbsolutePosition + 1

  End If

End Sub

 

Private Sub Cmddelete_Click()            '删除

  Data1.Recordset.Delete

  Data1.Recordset.MovePrevious           '回到前一个记录

End Sub

 

Private Sub cmdexit_Click()

  Unload Me

End Sub

 

Private Sub Form_Load()

  firstflag = True                       '首次使用

  Frame1.Visible = False                 '使主按钮组可见

End Sub

几个控件联动的例子

放置控件:  Form1:Data1;Text1,Combo1,List1

属性设置:

    Data1:〖DatabseName〗="db2.mdb",内有测站信息、径流量表等2个表。

 

Private Sub Combo1_Click()

  Dim li, lstr, lstr1

  For li = 1 To List1.ListCount

    List1.Clear

  Next

  Data1.RecordSource = "select 测站代码 from 测站信息 where 测站名称='" & Combo1 & "'"

  Data1.Refresh

  lstr = Data1.Recordset!测站代码

  Data1.RecordSource = "径流量表"

  Data1.Refresh

 

  Do While Not Data1.Recordset.EOF

    lstr1 = Data1.Recordset!测站代码

    If lstr1 = lstr Then

      List1.AddItem Data1.Recordset!测量日期

    End If

    Data1.Recordset.MoveNext

  Loop

End Sub

 

Private Sub List1_Click()

  Dim lstr, sql1

  Data1.RecordSource = "select 测站代码 from 测站信息 where 测站名称='" & Combo1 & "'"

  Data1.Refresh

  lstr = Data1.Recordset!测站代码

  sql1 = "select * from 径流量表 where 测站代码='" & lstr & "' and 测量日期='" & List1 & "'"

  Data1.RecordSource = sql1

  Data1.Refresh

  Text1 = Data1.Recordset!径流量

End Sub

 

Private Sub Form_Load()

  Text1 = ""

  Data1.RecordSource = "测站信息"

  Data1.Refresh

  Combo1 = Data1.Recordset!测站名称

  Do While Not Data1.Recordset.EOF

    Combo1.AddItem Data1.Recordset!测站名称

    Data1.Recordset.MoveNext

  Loop

End Sub

 

注：测量日期是字符型；

使用DATAGRID控件

使用FLEXGRID控件不能连接ADODC数据控件，这时就要用DATAGRID控件了。使用时只要在DATASOURCE属性中设置了ADODC控件名，就可以自动显示整个数据表了。

要取消DATAGRID的改动记录的功能，右击控件，在【属性】中把【允许更新】取消。要使第一个单元数据出现，在【拆分】选项卡中选【锁定】即可。

还可以在界面设计中改变字段名和字体。这时要用【添加】添加字段，然后选取或输入即可。

 

设置MSHFlexGrid每行的颜色

Public Sub SetRowColor(ByRef MSHFlexGrid As Object)
    Dim j, i, objName
    objName = TypeName(MSHFlexGrid)
    If StrConv(Trim(objName), vbUpperCase) <> "MSHFLEXGRID" Then
        Exit Sub
    End If
    MSHFlexGrid.FillStyle = 1
    For i = 1 To MSHFlexGrid.Rows - 1
        MSHFlexGrid.Row = i
        If i Mod 2 = 0 Then
            MSHFlexGrid.Col = 0
            MSHFlexGrid.ColSel = MSHFlexGrid.Cols - 1
            MSHFlexGrid.CellBackColor = &H80FFFF
        End If
    Next i
    MSHFlexGrid.FillStyle = 0
    MSHFlexGrid.Row = 0
    MSHFlexGrid.Col = 0
End Sub

查询结果在DATAGRID控件中的显示

Dim rs1

Private Sub Form_Load()

  Dim fpath2

  'fpath2 = "DBQ=//Sans/office2000/demo/db1.mdb;DefaultDir=c:/VB/demo;Driver = {Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize= 2048;MaxScanRows =8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  fpath2 = "DBQ=c:/vb/demo/db1.mdb;DefaultDir=c:/VB/demo;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize= 2048;MaxScanRows =8;PageTimeou t=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  Adodc1.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2

  Adodc1.RecordSource = "addvdata"

  Adodc1.Refresh

  Do While Not Adodc1.Recordset.EOF

    List1.AddItem Adodc1.Recordset!Year

    Adodc1.Recordset.MoveNext

  Loop

End Sub

 

Private Sub List1_Click()

  Text1 = List1.ListIndex

  Adodc1.Refresh

  Set rs1 = Adodc1.Recordset

  While Not rs1.EOF

    If rs1!Year = List1 Then

      DataGrid1.SelBookmarks.Add rs1.Bookmark

   End If

    rs1.MoveNext

  Wend

  DataGrid1.Scroll 0, -3

End Sub

使用DATAGRID控件的高级实例

本例使用DATAGRID1控件显示前几个月的实际降水量，再用历史数据推算后几个月的降水量，在DATAGRID2控件中显示。最后把全年数据写到第二个表中。

放置控件:  Form1:Command1,Command2,List1,Adodc1,Datagrid1,Adodc2,Datagrid2, Text1等。

 

 

 

'估算当年降水量，并用DATAGRID控件实现显示功能   by Xue Wei 10/20/2001

Option Explicit

Const mmax = 13

Dim mj           '有数据的截止月份

 

'退出

Private Sub Command1_Click()

  '加入前面输入数据

  Dim ii

  Adodc1.RecordSource = "HYDNETDATA1"

  Adodc1.Refresh

  Adodc2.RecordSource = "HYDNETDATA2"

  Adodc2.Refresh

  While Not Adodc2.Recordset.EOF

    For ii = 2 To mj + 1

      Adodc2.Recordset.Fields(ii) = Adodc1.Recordset.Fields(ii)

    Next ii

    Adodc1.Recordset.MoveNext

    Adodc2.Recordset.MoveNext

  Wend

  Unload Me

End Sub

 

'计算本年已有月份降水量的算术平均值

Function CalYp() As Integer

  Dim mi, ii, qi

  'Adodc1.Recordset.MoveFirst

  'While Not Adodc1.Recordset.EOF

    mi = 2

    mj = 0

    qi = 0

    For ii = mi To mmax

      If Not IsNull(Adodc1.Recordset.Fields(ii)) Then

        qi = qi + Adodc1.Recordset.Fields(ii)

        mj = mj + 1

      End If

    Next ii

    CalYp = Int(qi / mj)

    'Adodc1.Recordset.MoveNext

  'Wend

End Function

 

'计算已有月份多年平均降水量的算术平均值

Function CalYd() As Integer

  Dim ii, yd1

  yd1 = 0

  'MsgBox "cal=" & CalYm(1, 2)

  For ii = 1 To mj

    yd1 = yd1 + CalYm(ii, 2)

  Next ii

  CalYd = yd1 / mj

End Function

 

Private Sub Command2_Click()

  Dim ii

  For ii = 0 To 4

    List1.Selected(ii) = True

    CalList1 (List1.List(ii))

  Next ii

End Sub

 

Sub CalList1(Listselected)

  Dim mi, ii, qi

  Dim yp  '当年已有月份降水量的算术平均值

  Dim ym  '月多年平均降水量

  Dim yd  '相应月份多年平均降水量的算术平均值

  Dim yk  '比例系数

  Dim ydn '多年平均降水量

  Dim yy  '估算的当年降水量

  Dim ymj '估算的月降水量

 

  '检查第一个月是否有值

  Adodc1.Recordset.MoveFirst

  If IsNull(Adodc1.Recordset("1月")) Then

    MsgBox "没有当年的前几个月数据，不能进行当年降水量估算"

    Unload Me

  End If

 

  '根据选择的流域名找到所在记录

  While Adodc1.Recordset("流域名") <> Listselected

    Adodc1.Recordset.MoveNext

  Wend

  Adodc2.RecordSource = "HYDNETDATA2"

  Adodc2.Refresh

  While Adodc2.Recordset.Fields(0) <> Adodc1.Recordset("代码")

    Adodc2.Recordset.MoveNext

  Wend

 

  '估算当年降水量

  yp = CalYp

  yd = CalYd

  ydn = CalYdn(2)

  yk = yp / yd

  'yy = Int(ydn * yk)

 

  'Adodc2.Recordset.Fields(mmax + 1) = yy

  Adodc2.Recordset!total = yy

  Adodc2.Recordset.Update

  'MsgBox "yY=" & yy & " mj=" & mj

 

  '估算后续每月降水量

  yy = 0

  For ii = mj + 1 To mmax - 1

    ymj = CalYm(ii, 2) * yk

    yy = yy + ymj

    Adodc2.Recordset.Fields(ii + 1) = ymj

    Adodc2.Recordset.Update

  Next ii

 

  '合计得到估算年降水量

  yy = yy + yp * mj

  Adodc2.Recordset.Fields(mmax + 1) = yy

  Adodc2.Recordset.Update

  Adodc2.Refresh

 

  Adodc2.RecordSource = "select HYDNETDATA2.hydnetcd as 代码,HYDNET.hydnetnm as 流域名 ,HYDNETDATA2.jan as 1月,HYDNETDATA2.feb as 2月,HYDNETDATA2.mar as 3月" & _

    ",HYDNETDATA2.apr as 4月,HYDNETDATA2.may as 5月,HYDNETDATA2.jun as 6月,HYDNETDATA2.jul as 7月,HYDNETDATA2.aug as 8月,HYDNETDATA2.sep as 9月,HYDNETDATA2.oct as 10月" & _

    ",HYDNETDATA2.nov as 11月,HYDNETDATA2.dec as 12月,HYDNETDATA2.total as 年降水量" & _

    " from HYDNETDATA2,HYDNET where HYDNET.hydnetcd= HYDNETDATA2.hydnetcd "   'and HYDNET.hydnetcd='01'"

  Adodc2.Refresh

End Sub

 

Private Sub list1_Click()

  CalList1 (List1)

End Sub

 

Private Sub Form_Load()

  Dim ii, Temp

  Adodc1.ConnectionString = "Provider=MSDASQL.1;Persist Security Info= False;Extended Properties=" & fpath2

  Adodc1.RecordSource = "HYDNETDATA1"

  Adodc1.Refresh

  Text1 = Adodc1.Recordset!year1

 

  Adodc2.ConnectionString = "Provider=MSDASQL.1;Persist Security Info= False;Extended Properties=" & fpath2

  Adodc2.RecordSource = "HYDNETDATA2"

  Adodc2.Refresh

 

  While Not Adodc2.Recordset.EOF

    Adodc2.Recordset.Delete

    Adodc2.Recordset.MoveNext

  Wend

 

  While Not Adodc1.Recordset.EOF

    Adodc2.Recordset.AddNew

    Adodc2.Recordset.Fields(0) = Adodc1.Recordset.Fields(0)

    Adodc2.Recordset.Fields(1) = Adodc1.Recordset.Fields(1)

    Adodc2.Recordset.Update

    Adodc1.Recordset.MoveNext

  Wend

 

  Adodc1.RecordSource = "select HYDNETDATA1.hydnetcd as 代码,HYDNET.hydnetnm as 流域名 ,HYDNETDATA1.jan as 1月,HYDNETDATA1.feb as 2月,HYDNETDATA1.mar as 3月" & _

    ",HYDNETDATA1.apr as 4月,HYDNETDATA1.may as 5月,HYDNETDATA1.jun as 6月,HYDNETDATA1.jul as 7月,HYDNETDATA1.aug as 8月,HYDNETDATA1.sep as 9月,HYDNETDATA1.oct as 10月" & _

    ",HYDNETDATA1.nov as 11月,HYDNETDATA1.dec as 12月,HYDNETDATA1.total as 年降水量" & _

    " from HYDNETDATA1,HYDNET where HYDNET.hydnetcd= HYDNETDATA1.hydnetcd "   'and HYDNET.hydnetcd='01'"

  Adodc1.Refresh

 

  While Not Adodc1.Recordset.EOF

    List1.AddItem Adodc1.Recordset("流域名")

    Adodc1.Recordset.MoveNext

  Wend

 

  Adodc2.Refresh

  Adodc2.RecordSource = "select HYDNETDATA2.hydnetcd as 代码,HYDNET.hydnetnm as 流域名 ,HYDNETDATA2.jan as 1月,HYDNETDATA2.feb as 2月,HYDNETDATA2.mar as 3月" & _

    ",HYDNETDATA2.apr as 4月,HYDNETDATA2.may as 5月,HYDNETDATA2.jun as 6月,HYDNETDATA2.jul as 7月,HYDNETDATA2.aug as 8月,HYDNETDATA2.sep as 9月,HYDNETDATA2.oct as 10月" & _

    ",HYDNETDATA2.nov as 11月,HYDNETDATA2.dec as 12月,HYDNETDATA2.total as 年降水量" & _

    " from HYDNETDATA2,HYDNET where HYDNET.hydnetcd= HYDNETDATA2.hydnetcd "   'and HYDNET.hydnetcd='01'"

  Adodc2.Refresh

 

  Gflag = False

  If GisCD <> "" Then

    Gflag = True

    SetDb

    Set Rst2 = New ADODB.Recordset

    Rst2.Open "select * from HYDNET where trim(hydnetcd)='" & Trim(GisCD) & "'", Cnn

    On Error Resume Next

    Temp = Rst2("hydnetnm")

    If err.Number > 0 Then

      MsgBox "调用错误，返回"

      Unload Me

    End If

    List1.Enabled = False

    CalList1 (Temp)

  End If

End Sub

 

在公用模块中用到代码如下：

Public Const fpath2 = "DBQ=//WEBGIS/share/降水量文件/raindb.mdb;DefaultDir= c:/VB/demo;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN = C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions =0;Threads =3;UID=admin;UserCommitSync=Yes;"

Public Cnn As ADODB.Connection       '数据库连接

Public Rst1 As ADODB.Recordset       '记录集，和set联合使用

Public Rst2 As ADODB.Recordset       '记录集，和set联合使用

Public Const year0 = 1950            '最早记录年份

Public GisCD As String               'GIS调用的计算分区号

Public Gflag As Boolean              '判断是否为GIS调用

 

'连接数据库

Public Sub SetDb()

  Dim fpath2

  Set Cnn = New ADODB.Connection

  fpath2 = "DBQ=//WEBGIS/share/降水量文件/raindb.mdb;DefaultDir= c:/VB/demo;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn; MaxBufferSize =2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID= admin;UserCommitSync=Yes;"

  Cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2

End Sub

 

'月多年平均降水量,ym1为月份数字，ym2为类型：1-测站、2-流域、3-水库、4-区县

Public Function CalYm(ym1, ym2) As Single

  Dim rst0 As New ADODB.Recordset

  Dim Temp, Ti

  SetDb

  Select Case ym2

    Case 2

      rst0.Open "select * from HYDNETDATA", Cnn

      Temp = 0

      Ti = 0

      While Not rst0.EOF

        If IsNull(rst0.Fields(ym1 + 1)) Then rst0.Fields(ym1 + 1) = 0

        Temp = Temp + rst0.Fields(ym1 + 1)

        Ti = Ti + 1

        'MsgBox "TI=" & Ti & " TEMP=" & Temp

        rst0.MoveNext

      Wend

  End Select

  rst0.Close

  CalYm = Int(Temp * 100 / Ti) / 100

End Function

用数据库控件实现图表显示

在FORM上添加选项卡控件SSTAB1，在其中放入MSCHART控件（Chart0,1,2）和MSFLEXGRID (MfGrid0,1,2) 控件：

代码：

Option Explicit

Dim codetype(2) As String

Dim colfield(7) As String

Dim collabel(5) As String

Dim strsum(50)

Dim arrChartData()

 

Private Sub Command1_Click()

  Unload Me

End Sub

 

Private Sub Form_Load()

  '调用公共连接数据库

  SetDb

'选项卡数组

  codetype(0) = "流域"

  codetype(2) = "水库"

  codetype(1) = "区县"

  'GRID横坐标数组

  colfield(1) = "计算面积 "

  colfield(2) = "多年平均降水量  "

  colfield(3) = "多年平均降水总量 "

  colfield(4) = "20%"

  colfield(5) = "50%"

  colfield(6) = "75%"

  colfield(7) = "95%"

         'CHART控件横坐标数组

  collabel(1) = "多年平均降水总量"

  collabel(2) = "20%"

  collabel(3) = "50%"

  collabel(4) = "75%"

  collabel(5) = "95%"

End Sub

 

Private Sub SSTab1_Click(PreviousTab As Integer)

  Dim strsql As String

  Dim i

  Select Case SSTab1.Tab

  '流域表

  Case 0

    Set Rst1 = New ADODB.Recordset

    strsql = "select * from hydnet where hydnetcd in (select hydnetcd from hydnetdata)"

    Rst1.Open strsql, cnn

    ReportSet 0, MfGrid0, Chart0

    Rst1.Close

  '区县表

  Case 1

    Set Rst1 = New ADODB.Recordset

    strsql = "select * from addv where addvcd in (select addvcd from addvdata)"

    Rst1.Open strsql, cnn

    ReportSet 1, mfgrid1, Chart1

    Rst1.Close

  '水库表

  Case 2

    Set Rst1 = New ADODB.Recordset

    strsql = "select * from shuiku where shuikucd in (select shuikucd from shuikudata)"

    Rst1.Open strsql, cnn

    ReportSet 2, mfgrid2, Chart2

    Rst1.Close

  End Select

End Sub

 

'计算和赋值

Sub ReportSet(k, mfgrid, Chart As Object)

  Dim i, j, h

  With mfgrid

    .Col = 0

    .Row = 0

    .Text = codetype(k)

    For i = 1 To 7

      .Col = i

      .ColWidth(i) = 1450

      .Text = colfield(i)

    Next i

  End With

   

  j = 0

  If Rst1.EOF Then

    MsgBox "no data"

    Exit Sub

  Else

    Rst1.MoveFirst

    Do While Not Rst1.EOF

      j = j + 1

      Rst1.MoveNext

    Loop

  End If

 

  ReDim arrChartData(1 To j, 1 To 5)

  Rst1.MoveFirst

  i = 1

  Do While Not Rst1.EOF

      strsum(8) = Rst1.Fields(0) 'code

      '多年平均降水总量计算

      strsum(0) = Rst1.Fields(1) 'name

      strsum(1) = Rst1!area 'area

      strsum(2) = CalYdn2(strsum(8), k + 2)      '调用计算多年平均降水量函数

      strsum(3) = CLng(strsum(2)) * CLng(strsum(1)) / 100000

      strsum(4) = calduoping(strsum(8), strsum(1), 0.2, k)   '调用计算某频率下降水量的函数

      strsum(5) = calduoping(strsum(8), strsum(1), 0.5, k)

      strsum(6) = calduoping(strsum(8), strsum(1), 0.75, k)

      strsum(7) = calduoping(strsum(8), strsum(1), 0.95, k)

      '向CHART控件赋值

      arrChartData(i, 1) = strsum(3)

      arrChartData(i, 2) = strsum(4)

      arrChartData(i, 3) = strsum(5)

      arrChartData(i, 4) = strsum(6)

      arrChartData(i, 5) = strsum(7)

      Chart.ChartData = arrChartData

      '表格显示

      With mfgrid

        .Row = i

         For h = 0 To 7

          .Col = h

          .Text = Format(strsum(h), "0.00")

         Next h

      End With

      i = i + 1

      Rst1.MoveNext

  Loop

    '写CHART右边系列标签

    Chart.RowCount = j

    Chart.ColumnLabelCount = j

    Rst1.MoveFirst

    For i = 1 To j

      Chart.Row = i

      Chart.RowLabel = Rst1.Fields(1)

      Rst1.MoveNext

    Next i

    '写CHART横坐标

    Chart.ColumnCount = 5

    For i = 1 To 5

      Chart.Column = i

      Chart.ColumnLabel = colfield(i + 2)

    Next i

    Chart.Refresh

End Sub

数据库控件卸载

Set Data1.Recordset = Nothing

 

 

九  ADO数据库编程

打开mdb数据库

设置: 在【工程】‖【引用】中选”MS Dao 2.5/3.51 Compatibility Library”

代码:

Public cnn1 As ADODB.Connection

Public rst1 As Recordset

Public rst2 As Recordset

Sub mdbopen()

  Dim strcnn As String

  Text2 = "panx.mdb"

  Fpath2 = “C:/fxfx/pan/”

  strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _

  "Data Source=" & Fpath2 & Text2

  Set cnn1 = New ADODB.Connection

  cnn1.Open strcnn

End Sub

打开dbf数据库

设置: 在【工程】‖【引用】中选”MS Dao 2.5/3.51 Compatibility Library”

代码:

Public cnn2 As ADODB.Connection

Public rst1 As Recordset

Public rst2 As Recordset

Sub dbfopen()

  Dim strcnn As String

  Fpath2 = “C:/fxfx/pan/”

  strcnn = "Provider=MSDASQL.1;Persist Security Info=False;" & _

  "Data Source=FoxPro Files; Initial Catalog=" & fpath2

  Set cnn2 = New ADODB.Connection

  cnn2.Open strcnn

End Sub

连接SQL数据库

Dim cnn As ADODB.Connection       '数据库连接

Dim Rst2 As ADODB.Recordset

 

Private Sub Command1_Click()

  Set cnn = New ADODB.Connection

  si = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=" & _

  Text5.Text & ";Data Source=" & Text4.Text

  cnn.Open si

  Set Rst2 = New ADODB.Recordset

  si = "select * from " & Text3.Text

  Rst2.Open si, cnn, adOpenDynamic, adLockOptimistic   ‘打开一个可写入的表

  ……

End Sub

 

Private Sub Form_Load()

  Text3.Text = "biao2"         ‘表名

  Text4.Text = "temp"          ‘数据库组

  Text5.Text = "xue01"        ‘数据库

End Sub

读数据库

       mdbopen

Set rst1 = New ADODB.Recordset

    rst1.Open "shuku", cnn1

Do While Not rst1.EOF

    If rst1!sdanjia = 100 Then

      List1.AddItem rst1!sname

    End If

    rst1.MoveNext

Loop

rst1.Close

写数据库

mdbopen

Set rst2 = New ADODB.Recordset

rst2.CursorType = adOpenKeyset

rst2.LockType = adLockOptimistic

rst2.Open "shu0", cnn1, , , adCmdTable

Do While Not rst1.EOF

    If rst1!sdanjia < 0 Then

      rst1!sdanjia = 0

  rst1.Update

    End If

    rst1.MoveNext

Loop

 rst2.Close

清数据库

mdbopen

Set rst2 = New ADODB.Recordset

rst2.CursorType = adOpenKeyset

rst2.LockType = adLockOptimistic

rst2.Open "shu0", cnn1, , , adCmdTable

Do While Not rst2.EOF

    rst2.Delete

    rst2.MoveNext

    Loop

把dbf库倒入mdb库

先按照dbf的字段建立mdb数据库，再把两库打开。

  Do While Not rst2.EOF

      rst1.AddNew

      For i = 0 To rst1.Fields.Count - 1

        rst1.Fields(i) = rst2.Fields(i)

      Next i

      rst1.Update

      rst2.MoveNext

  Loop

  rst1.Close

  rst2.Close

使用SQL语言

mdbopen

s1 = “select * from shuku where sdanjia = 100”

Set rst1 = New ADODB.Recordset

    rst1.Open s1, cnn1

Do While Not rst1.EOF

  List1.AddItem rst1!sname

  rst1.MoveNext

Loop

rst1.Close

逆向查询

Rst1.Open "select distinct 雨量测站数据表.年度 from 雨量测站数据表 order by 年度 desc",cnn

添加新记录

SetDb

  Set Rst1 = New ADODB.Recordset

  Rst1.Open "决策信息表", cnn, adOpenKeyset, adLockOptimistic, adCmdTable ‘(1,3,2)

  Rst1.AddNew

  Rst1!决策代码 = JcDaima

  Rst1!注册名 = Zhuce

  Rst1!决策开始时间 = Date

  Rst1.Update

  Set Rst1 = Nothing

其中setdb程序为：

Public Sub SetDb()

  Set cnn = New ADODB.Connection

  fpath3 = "C:/My Documents/decision"

  fpath2 = "DBQ=" & fpath3 & ";DefaultDir=c:/VB/demo;Driver={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize=2048; MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2

End Sub

修改记录

STRN = "select * from 决策信息表 where 决策代码 = '" & JcDaima & "'"

Rst1.Open STRN, cnn, 1, 3

Rst1!Fanwei0 = Fanwei

Rst1!year0 = Dyear

Rst1.Update

Set Rst1 = Nothing

 

 

查找记录公用过程

Public Sub rseek(ss1 As String, ss2 As String, rst As ADODB.Recordset)

Dim bbb

  bbb = True

  rst.MoveFirst                  ‘rst不可为空,否则出现错误

  Do While Not rst.EOF And bbb

    If rst(ss1) = ss2 Then

      bbb = False

    Else

      rst.MoveNext

    End If

  Loop

  If bbb Then

    'MsgBox "没有找到记录!"

    brsl = True

  End If

End Sub

 

调用时，只要用

       rseek(“单价”,”51.5”,rst1)

就可把单价为51.5元的记录（第一个）找到了。

       如果要用brsl 判别是否找到，要先设brsl = False。

       注意，rst不可为空，可用

         If rst1.RecordNum > 0 then rseek(“单价”, ”51.5”, rst1)

加以判别。

 

要多次使用rseek时，速度较慢。这时最好用SQL查询：

    ss1 = "select * from shu0 where scode = '" & rst2!scode & "'"

    Set rst1 = New ADODB.Recordset

    rst1.Open ss1, cnn1

 

查询并修改数据

放置控件:  Form1:Command1(按价格查), Command2(按书名查), Command3(按代码查),List1

代码:

Option Explicit

Dim s11 As Single, s12 As String

 

Sub inputp1()

Dim s2

  s2 = ""

  On Error GoTo head

head1:

  s2 = InputBox("请输入单价:")

  If s2 = "" Then

    MsgBox "按‘确定’放弃"

  Else

    s11 = s2

  End If

  Exit Sub

head:

  MsgBox "输入错！请重新输入"

  Resume head1

End Sub

 

Sub listdelete()

Dim i

  For i = 0 To List1.ListCount - 1

    List1.Clear

  Next

End Sub

 

Sub listshow1()

Dim st, s3, i

  rst1.MoveFirst

  i = 1

  Do While Not rst1.EOF

    If rst1!sdanjia = s11 Then

      s3 = len3(str(i), 8) & len3(rst1!scode, 10) & len3(rst1!sname, 42) & _

      "   " & len3(str(s11), 8) & len3(rst1!syear, 12) & len3(rst1!skwh, 12) & len3(rst1!sbag, 6)

      List1.AddItem s3

      i = i + 1

    End If

    rst1.MoveNext

  Loop

  If (i = 1) Then

    MsgBox "没找到！"

  End If

End Sub

 

Private Sub Command1_Click()

  inputp1

  listdelete

  If s11 <> 0 Then

    listshow1

  End If

End Sub

 

Sub listshow2()

Dim st, s3, i

  rst1.MoveFirst

  i = 1

  Do While Not rst1.EOF

    st = Mid(Trim(rst1!sname), 1, Len(s12))

    If st = s12 Then

      s3 = len3(str(i), 8) & len3(rst1!scode, 10) & len3(rst1!sname, 42) & _

      "   " & len3(rst1!sdanjia, 8) & len3(rst1!syear, 12) & len3(rst1!skwh, 12) & len3(rst1!sbag, 6)

      List1.AddItem s3

      i = i + 1

    End If

    rst1.MoveNext

  Loop

  If i = 1 Then

    MsgBox "没找到！"

  End If

End Sub

 

Sub inputp2()

Dim s2

  s12 = ""

  s2 = InputBox("请输入书名的前几个字:")

  If s2 = "" Then

    MsgBox "按‘确定’放弃"

  Else

    s12 = s2

  End If

End Sub

 

 

Private Sub Command2_Click()

  inputp2

  listdelete

  If s12 <> "" Then

    listshow2

  End If

End Sub

 

Sub listshow3()

Dim st, s3, i

  rst1.MoveFirst

  i = 1

  Do While Not rst1.EOF

    st = Mid(Trim(rst1!scode), 1, Len(s12))

    If st = s12 Then

      s3 = len3(str(i), 8) & len3(rst1!scode, 10) & len3(rst1!sname, 42) & _

      "   " & len3(rst1!sdanjia, 8) & len3(rst1!syear, 12) & len3(rst1!skwh, 12) & len3(rst1!sbag, 6)

      List1.AddItem s3

      i = i + 1

    End If

    rst1.MoveNext

  Loop

  If i = 1 Then

    MsgBox "没找到！"

  End If

End Sub

 

Sub inputp3()

Dim s2

  s12 = ""

  s2 = InputBox("请输入代码的前几个字:")

  If s2 = "" Then

    MsgBox "按‘确定’放弃"

  Else

    s12 = s2

  End If

End Sub

 

 

Private Sub Command3_Click()

  inputp3

  listdelete

  If s12 <> "" Then

    listshow3

  End If

End Sub

 

Private Sub Command4_Click()

  cnn1.Close

  Unload Me

End Sub

 

Private Sub List1_Click()

  Dim li1, s1, s2

  li1 = Mid(List1, 9, 8)

  s1 = InputBox("请输入书" & Trim(li1) & "的新库位号 : ")

  If s1 = "" Then

    MsgBox "未输入库位号，请重新输入。"

    Exit Sub

  Else

    Call rseek("scode", Trim(li1), rst1)

    s2 = rst1!skwh

    rst1!skwh = s1

    rst1.Update

    rst2.AddNew

    rst2!knum = tnum

    rst2!kdate = Date

    rst2!kcode = rst1!scode

    rst2!kh1 = s2

    rst2!kh2 = s1

    rst2.Update

  End If

  rst1.Close

  rst2.Close

  cnn1.Close

 

  Load fkuweip

  fkuweip.pp1

  MsgBox ("本次入库单处理完毕。按“确定”退出")

  Unload Me

End Sub

 

Private Sub Form_Load()

Dim strcnn

Dim it As Integer

Dim k, s2

  strcnn = "Provider=Microsoft.Jet.OLEDB.3.51;Persist Security Info=False;" & _

  "Data Source=" & fpath1 & "shukux.mdb"

  Set cnn1 = New ADODB.Connection

  cnn1.Open strcnn

 

  Set rst1 = New ADODB.Recordset

  rst1.CursorType = adOpenKeyset

  rst1.LockType = adLockOptimistic

  rst1.Open "shu0", cnn1, , , adCmdTable

  Set rst2 = New ADODB.Recordset

  rst2.CursorType = adOpenKeyset

  rst2.LockType = adLockOptimistic

  rst2.Open "kwh", cnn1, , , adCmdTable

 

  If rst2.RecordCount < 1 Then

    tnum = "K00001"

  Else

    rst2.MoveLast

    s2 = rst2!knum

    s2 = Mid(s2, 2, 6)

    s2 = Trim(str(Int(s2) + 1))

    Do While Len(s2) < 5

      s2 = "0" + s2

    Loop

    tnum = "K" & s2

  End If

End Sub

连接远程数据库

1．用ADODC控件连接远程数据库

用文件DSN连接，建立连接后，再添加一个ADODC控件，一个List1控件，程序如下：

Private Sub Form_Load()

   fpath2 = "DBQ=//Sans/office2000/demo/db1.mdb;DefaultDir=c:/VB/demo;Driver = {Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize = 2048;MaxScanRows =8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

   Adodc1.ConnectionString = "Provider=MSDASQL.1;Persist Security Info=False; Extended Properties=" & fpath2

   Adodc1.RecordSource = "addvdata"

   Adodc1.Refresh

   Do While Not Adodc1.Recordset.EOF

      List1.AddItem Adodc1.Recordset!addvcd

      Adodc1.Recordset.MoveNext

   Loop

End Sub

2．用程序连接远程数据库

在【工程】‖【引用】中选”MS Dao 2.5/3.51 Compatibility Library”和“MS ADO 2,0 Library”，再添加一个List1控件，程序如下：

Public Cnn As ADODB.Connection

Private Sub Form_Load()

  Dim strcnn, fpath2

   Dim rst1 As New ADODB.Recordset

   Set Cnn = New ADODB.Connection

  

   fpath2 = "DBQ=//Sans/office2000/demo/db1.mdb;DefaultDir=c:/VB/demo;Driver = {Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize = 2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

   Cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2

   rst1.Open "select * from addvdata ", Cnn

   Do While Not rst1.EOF

      List1.AddItem rst1!addvcd

      rst1.MoveNext

   Loop

   rst1.Close

End Sub

数据录入实例

这是一个在几个控件选择（测站和年度）条件下用TEXT进行录入，如果该记录有值，进入UPDATE状态，如果没有值，进入ADDNEW状态。最后的总和可以输入，也可以计算。按【确认】可以根据计算结果提示用户输入的总和相差太大（超过5%），然后写入数据库，并使测站翻到下一个。

'测站年度数据录入

Option Explicit

Dim RainstatCd As String

Dim flag As Boolean       '判断记录是否有值

 

Private Sub cmdcancel_Click(Index As Integer)

  combo_year_Click

End Sub

 

Private Sub cmdexit_Click()

  Unload Me

End Sub

 

Private Sub cmdjisuan_Click(Index As Integer)

  Dim i As Integer

  Dim txtbox As TextBox

  For Each txtbox In Me.Text1

    If txtbox.Text = "" Then

    txtbox.Text = "0"

    End If

  Next

  Text1(12) = "0"

  For i = 0 To 11

    Text1(12) = Val(Text1(12)) + Val(Text1(i))

  Next i

  Text1(12).SetFocus

End Sub

 

Private Sub cmdSubmit_Click(Index As Integer)

  Dim i As Integer

  Dim sum As Long

  Dim txtbox As TextBox

 

  On Error GoTo err

  For Each txtbox In Me.Text1

    If txtbox.Text = "" Then

      txtbox.Text = "0"

    End If

  Next

 

  sum = 0

  For i = 0 To 11

    sum = sum + Val(Text1(i))

  Next i

  If sum = 0 Then

    MsgBox "没有数据不能提交", , "提示"

    Exit Sub

  End If

 

  If (sum - Val(Text1(12))) / sum > 0.05 Or (Val(Text1(12)) - sum) / sum > 0.05 Then

    If MsgBox("年降水量与各月累加相差5%,是否修正？", vbQuestion + vbYesNo, "提示") = vbYes Then

      Text1(12).Text = Trim(Str$(sum))

      Text1(12).SetFocus

      Exit Sub

    End If

  End If

 

  Set Rst2 = New ADODB.Recordset

  Set Rst1 = New ADODB.Recordset

  Rst1.Open "select rainstat.* from rainstat where rainstat.rainstatnm='" & Combo_nm.Text & " ' ", Cnn

  RainstatCd = Rst1("rainstatcd")

  Rst1.Close

 

  'Cnn.BeginTrans

  If flag = False Then

    Rst2.Open "select * from statdata", Cnn, adOpenStatic, adLockOptimistic

    'Rst2.MoveLast

    Rst2.AddNew

  Else

    Rst2.Open "select * from statdata where rainstatcd='" & RainstatCd & "' and year1=" & Val(combo_year), Cnn, adOpenStatic, adLockOptimistic

  End If

 

  Rst2("rainstatcd") = RainstatCd

  Rst2("year1") = combo_year

  For i = 0 To 12

    Rst2.Fields(i + 2) = Text1(i).Text

  Next i

  Rst2.Update

  'rst2.Requery

  'Cnn.CommitTrans

   

  If Combo_nm.ListIndex < Combo_nm.ListCount - 1 Then

    Combo_nm.ListIndex = Combo_nm.ListIndex + 1

  Else

    Combo_nm.ListIndex = 0

  End If

 

  If Gflag Then

    'MsgBox "gflag=" & Gflag

    Unload Me

    Exit Sub

  Else

    CalEnter2 Combo_nm.List(Combo_nm.ListIndex)    '换到下一个测站

  End If

  

  Text1(0).SetFocus

  Exit Sub

err:

  MsgBox err.Description

 

End Sub

 

Private Sub combo_nm_Change()

  'combo_year_Click

End Sub

 

Private Sub combo_nm_Click()

  combo_year_Click

End Sub

 

Private Sub combo_year_Click()

  Dim i

  flag = False

  Set Rst1 = New ADODB.Recordset

  Rst1.Open "select * from rainstat where rainstatnm='" & Combo_nm & "'", Cnn

  Set Rst2 = New ADODB.Recordset

  Rst2.Open "select * from statdata where rainstatcd='" & Rst1!RainstatCd & "' and year1=" & Val(combo_year), Cnn

 

  i = 0

  While Not Rst2.EOF

    i = i + 1

    Rst2.MoveNext

  Wend

 

  If i > 0 Then

    Rst2.MoveFirst

    RainstatCd = Rst2("rainstatcd")

    flag = True

    For i = 0 To 12

      If Not IsNull(Rst2.Fields(i + 2)) Then

        Text1(i) = Rst2.Fields(i + 2)

      Else

        Text1(0) = ""

      End If

    Next i

  Else

    For i = 0 To 12

      Text1(i) = ""

    Next i

    flag = False

  End If

  Rst1.Close

  Rst2.Close

End Sub

 

Sub CalEnter2(RainName)

  Combo_nm = RainName

  combo_year_Click

End Sub

 

Private Sub Form_Load()

  Dim j As Integer

  Dim Temp

  SetDb

 

  Set Rst2 = New ADODB.Recordset

  Rst2.Open "RAINSTAT", Cnn

 

  While Not Rst2.EOF

    Combo_nm.AddItem Rst2("rainstatnm")

    Rst2.MoveNext

  Wend

 

  combo_year = Year(Date) - 1

  For j = year0 To Year(Date) - 1

    combo_year.AddItem j

  Next j

 

  Rst2.MoveFirst

  Temp = Rst2("rainstatnm")

  Combo_nm.ListIndex = 0

 

  '从外部调用这个FORM

  Gflag = False

  If GisCD <> "" Then

    Gflag = True

    Set Rst2 = New ADODB.Recordset

    Rst2.Open "select * from RAINSTAT where trim(rainstatcd)='" & Trim(GisCD) & "'", Cnn

    On Error Resume Next

    Temp = Rst2("rainstatnm")

    If err.Number > 0 Then

      MsgBox "调用错误，返回"

      Unload Me

    End If

    Combo_nm.Enabled = False

  End If

  'Rst2.Close

  CalEnter2 Temp

End Sub

 

Private Sub Text1_KeyPress(Index As Integer, KeyAscii As Integer)

  Dim strvalid As String

  strvalid = "0123456789."

  If KeyAscii > 26 Then

    If InStr(strvalid, Chr(KeyAscii)) = 0 Then

      KeyAscii = 0

    End If

  End If

 

  If KeyAscii = 13 Then

    If Index < 11 Then

      Text1(Index + 1).SetFocus

    End If

   

    If Index = 11 Then

      cmdjisuan(0).SetFocus

    End If

   

    If Index = 12 Then

      cmdSubmit(1).SetFocus

    End If

  End If

End Sub

 

程序还用到公用模块代码：

Public Rst1 As ADODB.Recordset       '记录集，和set联合使用

Public Rst2 As ADODB.Recordset       '记录集，和set联合使用

Public Const year0 = 1950            '最早记录年份

Public GisCD As String               'GIS调用的计算分区号

Public Gflag As Boolean              '判断是否为GIS调用

 

Public Sub SetDb()

  Dim fpath2

  Set Cnn = New ADODB.Connection

  fpath2 = "DBQ=//WEBGIS/share/降水量文件/raindb.mdb;DefaultDir=c:/VB/demo;Drive r={Microsoft Access Driver (*.mdb)};DriverId=281;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test00.dsn;MaxBufferSize=2048;MaxScanRows =8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  Cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Extended Properties=" & fpath2

End Sub

 

十  文件处理

用open方法读文件

open s1 for input as #1

do while not eof(1)

  line input #1, s2

  msgbox s2

loop

close #1

用open方法写文件

重写

open s1 for output as #1

print #1, s2

close #1

附加

open s1 for append as #1

print #1, s2

close #1

用FSO对象读写文件

使用FSO对象前要引用Microsoft Scripting Runtime

  Dim fso As New FileSystemObject

  Dim ts1, ts2 As TextStream

  Set ts1 = fso.OpenTextFile(fs1, ForReading)

  Set ts2 = fso.OpenTextFile(fs2, ForWriting)

  i = 0

  Do While Not ts1.AtEndOfStream

    s0 = ts1.ReadLine

    ts2.WriteLine s0

    i = i + 1

  Loop

  m = i

  ts1.Close

  ts2.Close

删除文件

Dim fso As New FileSystemObject

fso.DeleteFile fname1

或

Set File2 = fso.GetFile(t1)

File2.Delete

文件更名

把文件t1换名变成t2

t1 = "c:/logs/station.dbf..dbf"

  t2 = "c:/logs/station1.dbf"

  If fso.FileExists(t1) Then

    Set File2 = fso.GetFile(t1)

    If Not fso.FileExists(t2) Then

      File2.Move t2

    End If

  Else

    MsgBox "数据库文件" & t1 & "不存在！"

    End

  End If

复制文件

把文件t1复制成t2

t1 = "c:/logs/station.dbf..dbf"

  t2 = "c:/logs/station1.dbf"

  If fso.FileExists(t1) Then

    Set File2 = fso.GetFile(t1)

    If Not fso.FileExists(t2) Then

      File2.Copy t2

    End If

  Else

    MsgBox "数据库文件" & t1 & "不存在！"

    End

  End If

删除过期文件

添加File1控件，用来管理所有文件。先要设File1.Path

For i = 0 To File1.ListCount - 1

  fn = File1.Path + "/" + File1.List(i)

  Set File2 = fso.GetFile(fn)

  tt = File2.DateLastModified

  If today - tt > 10 Then          ‘删除10天前的文件

    File2.Delete

  End If

Next

 

十一  收发E-mail

发送E-mail

调用: 【部件】下的Microsoft MAPI Control 6.0

放置控件:  Form1:Command1, MAPISession1, MAPIMessages1

属性设置: 〖MAPISession1.名称〗=MAPIS，〖MAPIMessages1.名称〗=MAPIM

说明: 1. MAPISession控件用来进行联接和登录，MAPIMessages控件用来进行收发E-mail的操作。

       2. 发送时向MAPIMessages.MsgNoteText输入E-mail内容。要输入多行，用MAPIMessages.MsgNoteText = line1 & vbCrLf & line2 即可。

代码:

Private Sub Command1_Click()

  With MAPIS

    .DownLoadMail = True    '使用开机下载

    .LogonUI = True           '发送地址不对时可以手工设置

    .SignOn                 '建立会话

  End With

  With MAPIM

    .SessionID = MAPIS.SessionID      '用SessionID指定对话序列号,缺省为0

    .Compose                          '写新消息

    .RecipAddress = "shuku@waterpub.com.cn"  '写收件人地址

    .AddressResolveUI = True                 '使用验证方式

    .ResolveName                             '验证收件人地址

    .MsgSubject = "head"                     '写E-mail主题

    .MsgNoteText = "text"                    '写E-mail内容

    .Send                          '发送

  End With             

  MAPIS.SignOff                    '结束会话

  MsgBox ("发送完毕。")

End Sub

接收E-mail

调用: 【部件】下的Microsoft MAPI Control 6.0

放置控件:  Form1:Command1, MAPISession1, MAPIMessages1,Text1,Text2,Text3

属性设置: 〖MAPISession1.名称〗=MAPIS，〖MAPIMessages1.名称〗=MAPIM

说明:：1．本例为接收一份E-mail的例子；

          2．要先打开Outlook Express，并自动接受了邮件。程序从Outlook Express的收件箱中读取信件。

代码:  

Private Sub Command1_Click()

  With MAPIS

    .DownLoadMail = True    '使用开机下载

    .LogonUI = True           '发送地址不对时可以手工设置

    .SignOn                 '建立会话

  End With

  With MAPIM

    .SessionID = MAPIS.SessionID   '用SessionID指定对话序列号,缺省为0

    .Fetch                         '取信

    Text3 = .MsgCount              '信件数量

    Text1 = .MsgSubject            '主题

    Text2 = .MsgNoteText           '内容

    '.Delete                       '取后删除

  End With

  MAPIS.SignOff                    '结束会话

End Sub

接收多封E-mail

放置控件和属性设置同前。

要先打开Outlook Express，并自动接受了邮件。程序从Outlook Express的收件箱中读取信件。

  Dim i

  Fpath3 = “C:/asp/temp/”

  With MAPIS

    .DownLoadMail = True

    .LogonUI = True

    .SignOn

  End With

  With MAPIM

    .SessionID = MAPIS.SessionID

.Fetch

    For i = 0 To .MsgCount - 1

      .MsgIndex = i

      s1 = fpath3 & .MsgSubject

      Open s1 For Output As #1

      Print #1, .MsgNoteText

      Close #1

    Next

    For i = 0 To .MsgCount - 1

  .Delete

    Next

  End With

  MAPIS.SignOff

选择发送多封E-mail

放置控件和属性设置同前,增加Fiel1控件。

利用拨号上网时，要先打开Outlook Express，并已拨号上网，这样速度较快。否则每发送一封要拨一次号。

Option Explicit

Dim fscount, i, j

Dim fs1(200) As String

Dim fso As New FileSystemObject

Dim File2 As File

 

Function disfile(ss1 As String)

  Dim sk

  disfile = ""

  Open File1.Path & "/" & ss1 For Input As #1

  Do While Not EOF(1)

    Line Input #1, sk

    disfile = disfile & sk & vbCrLf

  Loop

  Close #1

End Function

 

Sub MAPIsend()

  Dim fs2 As String

  With MAPIS

    .DownLoadMail = False

    .LogonUI = True

    .SignOn

  End With

  With MAPIM

    .SessionID = MAPIS.SessionID

    .Compose

    For i = 0 To fscount - 1

      '.MsgIndex = i

      .RecipAddress = "wrf@waterpub.com.cn"

      .AddressResolveUI = True

      .ResolveName

      fs2 = fs1(i)

      'fs2 = "4bu0020.ppp"

      .MsgSubject = fs2

      .MsgNoteText = disfile(fs2)

      .Send

    Next i

  End With

  MsgBox "发送完毕"

End Sub

 

Sub mfilemove()

Dim fname1

  For i = 0 To fscount - 1

    fname1 = File1.Path & "/" & fs1(i)

    'MsgBox fname1

    fso.DeleteFile fname1

  Next

End Sub

 

Private Sub Command1_Click()

  j = 0

  For i = 0 To File1.ListCount - 1

    If File1.Selected(i) Then

      fs1(j) = File1.List(i)

      j = j + 1

    End If

  Next

  fscount = j

 

  If fscount < 1 Then

    MsgBox "没有要发送的文件！"

    Exit Sub

  Else

    For i = 0 To fscount - 1

      fs1(i) = File1.List(i)

    Next i

  End If

 

  MAPIsend

  Mfilemove

  MAPIS.SignOff

  Unload Me

End Sub

 

Private Sub Command2_Click()

  Unload Me

End Sub

 

Private Sub Form_Load()

  Fpath1=”c:/fxfx/kfb/”

  File1.Path = fpath1 & "email"

End Sub

 

十二  ActiveX控件

建立简单的ActiveX控件

这是一个显示时间的例子。

1．新建一个ActiveX控件工程

放置控件:  UserControl1:Frame1,Timer1，Label1(小时)，Label2(分)，Label3(秒)，使框架包容其它控件

属性设置: 〖Timer1.Interval〗=100  'ms

代码:

Private Sub Timer1_Timer()

  Label1.Caption = Hour(Time) & ";"

  Label2.Caption = Minute(Time) & ";"

  Label3.Caption = Second(Time)

End Sub

 

Private Sub UserControl_Initialize()

  Label1.Caption = Hour(Time) & ";"

  Label2.Caption = Minute(Time) & ";"

  Label3.Caption = Second(Time)

End Sub

然后保存文件，并生成OCX文件。

2．新建一个标准EXE工程，单击【工程】/【部件】，找到刚才生成的“工程1”部件，把它选中，然后从工具箱中把它添加到Form1中。这时就可以看见这个控件已经在运行了。然后就可以发布使用这个控件了。

改进ActiveX控件的接口

       在【外接程序】/【外接程序管理器】中选择“ActiveX接口向导”的加载，再打开向导对话框，按照提示去做即可。

发布和应用ActiveX控件

       在【外接程序】/【外接程序管理器】中选择“打包和展开向导”的加载，再打开向导对话框，选择【打包】，再选择【Internet】,在选项中选择“发布到没有VB的计算机上”，然后就可以在指定的文件夹中产生一个CAB文件，可以安装到其它计算机上使用。

       这时还产生了一个同名的HTML文件，把其上的OBJECT代码拷贝下来，放到其它网页上，就可以在网上应用这个控件了。

建立一个复杂一点的例子

这是一个添加新的属性和方法的例子。

新建一个ActiveX控件工程，放置控件:  UserControl1:command1,label1。

打开“ActiveX接口向导”，只选择caption（对应label1）和click（对应Command1），再新建一个属性leftx（对应label1）。

这时在UserControl1自动产生了几段代码，修改如下，然后再用下节的调试方法来进行在线调试。

 

'设置leftx的属性（用let和get分别设置赋值和被赋值的情况）

Public Property Let leftx(ByVal New_leftx As Integer)

  Label1.Left = New_leftx

  PropertyChanged "leftx"

End Property

'注意！不要删除或修改下列被注释的行！

'MemberInfo=7,0,0,0

Public Property Get leftx() As Integer

  leftx = Label1.Left

End Property

'修改Click事件

Private Sub Command1_Click()

  Me.Caption = Me.leftx

  Me.leftx = Me.leftx + 50

  RaiseEvent Click

End Sub

'添加一个初始值设置（没有大用处，只是练习）

Private Sub UserControl_Initialize()

  Me.Caption = ""

End Sub

开发调试

先单击【工程】/【添加工程】，添加一个测试工程；

关闭 UserControl，这时工具箱中出现 UserControl控件，把它加入到Form1中，就可以运行这个程序了。

如果没有测试工程，也可以调用IE运行。

要在网页上加入这个控件，运行时查看HTML源文件，把下列说明复制下来，粘贴到网页中：

<OBJECT classid="clsid:0C174E17-67F5-11D5-98FB-BCF7F45EF11E">

</OBJECT>

其余的语句运行时自动产生。

安装和发布

对于DLL文件，拷贝到一个目录后，在【运行】中键入：

C:/WINDOWS/SYSTEM/REGSVR32.EXE C:/MYASP/ASPPING.DLL

或在NT中：

C:/WINNT/SYSTEM32/REGSVR32.EXE C:/MYASP/ASPPING.DLL

对于OCX文件，则要安装。步骤是：

1．编制程序（ACTIVEX控件）；

2．在【工程】/【工程。。属性】中选“要求许可证关键字”；

3．编译成OCX文件；

4．打包。

 

十三  总体结构

用Timer控件控制程序运行

放置控件:  Form1:Command1,Timer1

属性设置: 〖Timer1.Interval〗=10  '10ms

代码:

 

Dim i As Integer       '循环变量

Dim doflag As Boolean    '用户是否按键标志

Sub delay 同前

 

Private Sub example()

  Form1.Print i

  delay (500)

  i = i + 1

End Sub

 

Private Sub Command1_Click()

  Select Case doflag

    Case True

      Command1.Caption = "开始"

      doflag = False

      Cls

    Case False

      Command1.Caption = "停止"

      doflag = True

   End Select

End Sub

 

Private Sub Timer1_Timer()  '时钟控件随时检测,如果没有点击

  If doflag Then            'Command1(停止),则继续调用example过程

    example

  End If

End Sub

 

Private Sub Form_Load()

  doflag = False

  Command1.Caption = "开始"

End Sub

在过程中调用Form的模式方法

Form2.Show VbModal

在过程中调用Form的后台中断方法

放置控件:  Form1:Command1, Form2:Command2

代码:

Private Sub Command1_Click()

  Bl = True

  Form2.show

  Do While Bl do

    DoEvents

  Loop

End Sub

 

Private Sub Command2_Click()

  Unload Me

  Bl = False

End Sub

调用其它窗体中的过程

调用Form2的pp1过程:

       Load Form2

       Form2.pp1

定时播放提醒声

以下程序每隔10分钟播放提醒声，按COMMAND2停止。

Option Explicit

Dim s1, s2

Dim stopb As Boolean

Sub delay(ss As Long)

  Dim start, check

  start = Timer

  Do

    check = Timer

  Loop While check < start + ss * 60

End Sub

 

Private Sub Command1_Click()

  Dim i

  s1 = "C:/Program Files/Windows Media Player/MPLAYER2.EXE"

  s2 = " C:/windows/media/乐曲默认值.wav"

  Do While Not stopb

    Shell (s1 & s2)

    delay 10

    DoEvents

  Loop

End Sub

 

Private Sub Command2_Click()

  stopb = True

End Sub

 

Private Sub Form_Load()

  stopb = False

End Sub

十四  加密

简单的密码框

放置控件:  Form1:Text1,Command1;Form2

属性设置: 〖Form1.Command1.Caption〗=确定

          〖Form1.Text1.text〗=""

          〖Form2.Command1.Caption〗=Exit

Form1代码:

Private Sub Command1_Click()

  If Text1.text = "123" then       '设密码为123

    Print "You are right!"

  Else

    Print "Sorry ! Input again."

    Text1.Text = ""                 '清除以前输入内容

  End If

  Text1.SetFocus             '焦点重新回到文本框

End Sub

 

Form2代码:

Private Sub Command1_Click()

  End

End Sub

加密Form

放置控件:  Form1:Text1,Command1;Form2

属性设置: 〖Form1.Command1.Caption〗=确定

          〖Form1.Text1.text〗=""

          〖Form2.Command1.Caption〗=Exit

Form1代码:

Dim s1 As Integer

Private Sub Text1_KeyPress(KeyAscii As Integer)

  If KeyAscii = 13 Then

    If Text1 = "123" Then    '密码为123

      Form1.Hide

      Form2.Show

    Else

      If s1 = 3 Then         '只能试3次

        MsgBox ("密码错误,系统退出!")

        Unload Me

      Else

        MsgBox ("输入错!请重新输入密码:")

        Text1 = ""

        s1 = s1 + 1

      End If

    End If

  End If

End Sub

 

Private Sub Form_Load()

  Text1 = ""

  s1 = 1

End Sub

十五  其它编程

调用外部程序

本例用shell调用记事本程序，在其中写入几行字后保存，最后返回VB。

放置控件:  Form1:Text1,Command1

代码：

Private Sub Command1_Click()

  Shell ("C:/PWIN98/NOTEPAD.EXE"), 1

  'AppActivate "无标题 - 记事本"        ’指定窗口

  SendKeys "The text1 is : ", True

  SendKeys "{ENTER}", True

  SendKeys Text1, True

  SendKeys "%(F)", True             ’按Alt+F

  SendKeys "X", True                ’按X退出记事本

  SendKeys "{ENTER}", True

  SendKeys "123", True              ’输入文件名

  SendKeys "{ENTER}", True

  SendKeys "Y", True

  Unload Me

End Sub

运行时先在文本框中输入一行字，再按Command1，就可以把这行字和前面的提示写到一个名为“123”的文件中了。

调用VB外部程序并传递参数

建立工程2，其中FORM2代码为：

Private Sub Command1_Click()

  MsgBox "g2=" & Command()

End Sub

再建立工程1，其中FORM1代码为：

Private Sub Command1_Click()

  Shell ("C:/VB/LIAN/工程2.exe cmmm 123456"), 1

  MsgBox "ok"

End Sub

 

动态调整各测站的加权值

工程由FORM0和FORM1组成；FORM0根据选择流域值，再调用FORM1；FORM1先根据流域值查流域代码，根据代码查找测站数，然后动态产生各控件和FORM尺寸。拉动SLIDER控件可以调整各测站的权重。

FORM0：DATA1，COMMAND1，COMBO1

Private Sub Combo1_Click()

  Data1.RecordSource = "SELECT * FROM HYDNET WHERE HYDNETNM='" & Combo1 & "'"

  Data1.Refresh

  SELHYDNET = Data1.Recordset!HYDNETCD

  Data1.Recordset.Close

End Sub

 

Private Sub Command1_Click()

  'Form0.Hide

  Form1.Show

End Sub

 

Private Sub Form_Load()

  Data1.RecordSource = "HYDNET"

  Data1.Refresh

  Do While Not Data1.Recordset.EOF

    Combo1.AddItem Data1.Recordset!HYDNETNM

    Data1.Recordset.MoveNext

  Loop

End Sub

 

FORM1：产生SLIDER1、LABEL2、TEXT1数组（包括第一个控件），再产生一个标题LABEL1、DATA1、COMMAND1、COMMAND2；

Option Explicit

Dim Imax         '控件数（从0开始）

Const Smax = 100 '权重总计

Const Topy = 600 '每个控件间距

 

Private Sub Command1_Click()  '关闭

  Unload Me

End Sub

 

Private Sub Form_Load()

  Dim j, Stemp

 

  Data1.RecordSource = "SELECT * FROM RAINSTAT WHERE HYDNETCD='" & SELHYDNET & "'"

  Data1.Refresh

  Imax = 0

  Do While Not Data1.Recordset.EOF

    Imax = Imax + 1

    Data1.Recordset.MoveNext

  Loop

 

  If Imax > 1 And Imax < 21 Then

    Data1.Refresh

    Label2(0) = Data1.Recordset!RAINSTATNM

    If Imax < 10 Then

      Form1.Width = 5800

      Form1.Height = 4500 + Topy * (Imax - 2)

      For j = 1 To Imax - 1

        Load Slider1(j)

        Slider1(j).Left = 1000

        Slider1(j).Top = 1200 + Topy * j

        Slider1(j).Visible = True

     

        Load Text1(j)

        Text1(j).Left = 4200

        Text1(j).Top = 1200 + Topy * j

        Text1(j).Visible = True

     

        Data1.Recordset.MoveNext

        Load Label2(j)

        Label2(j).Left = 240

        Label2(j).Top = 1300 + Topy * j

        Label2(j).Caption = Data1.Recordset!RAINSTATNM

        Label2(j).Visible = True

      Next j

      Command2.Left = 1400

      Command2.Top = 3000 + Topy * (Imax - 2)

      Command1.Left = 3300

      Command1.Top = 3000 + Topy * (Imax - 2)

    Else                                       '如果控件数大于10，则要分2栏

      Form1.Width = 11500

      Form1.Height = 4500 + Topy * 9

      Label1.Left = 4500

      For j = 1 To 9

        Load Slider1(j)

        Slider1(j).Left = 1000

        Slider1(j).Top = 1200 + Topy * j

        Slider1(j).Visible = True

     

        Load Text1(j)

        Text1(j).Left = 4200

        Text1(j).Top = 1200 + Topy * j

        Text1(j).Visible = True

     

        Data1.Recordset.MoveNext

        Load Label2(j)

        Label2(j).Left = 240

        Label2(j).Top = 1300 + Topy * j

        Label2(j).Caption = Data1.Recordset!RAINSTATNM

        Label2(j).Visible = True

      Next j

     

      For j = 10 To Imax - 1

        Load Slider1(j)

        Slider1(j).Left = 7000

        Slider1(j).Top = 1200 + Topy * (j - 10)

        Slider1(j).Visible = True

     

        Load Text1(j)

        Text1(j).Left = 10200

        Text1(j).Top = 1200 + Topy * (j - 10)

        Text1(j).Visible = True

     

        Data1.Recordset.MoveNext

        Load Label2(j)

        Label2(j).Left = 6240

        Label2(j).Top = 1300 + Topy * (j - 10)

        Label2(j).Caption = Data1.Recordset!RAINSTATNM

        Label2(j).Visible = True

      Next j

     

      Command2.Left = 4400

      Command2.Top = 2500 + Topy * 9

      Command1.Left = 6300

      Command1.Top = 2500 + Topy * 9

    End If

   

    For j = 0 To Imax - 1

      Slider1(j).Max = Smax

    Next

   

    Stemp = Int(Smax / Imax)

    For j = 0 To Imax - 2

      Text1(j) = Stemp

      Slider1(j).Value = Stemp

    Next

    Text1(Imax - 1) = Smax - Stemp * (Imax - 1)

    Slider1(Imax - 1) = Smax - Stemp * (Imax - 1)

  Else

    If Imax < 2 Then

      MsgBox "测站数为" & Imax & "，不能设定权重。"

    Else       '>20

      MsgBox "测站数为" & Imax & "，超出程序设置范围，不能设定权重。"

    End If

    Command2.Enabled = False

    Slider1(0).Visible = False

    Label2(0).Visible = False

    Text1(0).Visible = False

  End If

End Sub

 

Private Sub Slider1_Click(Ix As Integer)

  Dim j, S0

  Dim Stemp

  Dim Sx

 

  S0 = Text1(Ix)

  If Imax - Ix < 2 Then

    MsgBox "不能改变！"

    Slider1(Ix).Value = S0

    Exit Sub

  End If

 

  Sx = 0

  If Ix > 0 Then

    For j = 0 To Ix - 1

      Sx = Sx + Text1(j)

    Next j

  End If

 

  Text1(Ix) = Slider1(Ix).Value

  If Smax - Sx < Int(Text1(Ix)) Then

    MsgBox "超出范围！"

    Text1(Ix) = S0

    Slider1(Ix) = S0

  Else

    Stemp = Int((Smax - Sx - Int(Text1(Ix))) / (Imax - 1 - Ix))

    MsgBox "stemp=" & Stemp

    If Imax - Ix = 0 Then

      Text1(Imax - 1) = Stemp

      Slider1(Imax - 1).Value = Stemp

    Else

      For j = Ix + 1 To Imax - 2

        Text1(j) = Stemp

        Slider1(j) = Stemp

      Next j

      Text1(Imax - 1) = (Smax - Sx - Int(Text1(Ix))) - Stemp * (Imax - Ix - 2)

      Slider1(Imax - 1) = (Smax - Sx - Int(Text1(Ix))) - Stemp * (Imax - Ix - 2)

    End If

  End If

End Sub

用MSCHART产生图表

在【部件】中使用：

1．  MS ADO Data Control 6.0;

2．  MS Chart Control 6.0;

3．  MS Datalist Control 6.0;

然后建立List(Liststation)、MSChart(ChartDemo)、Combo(ComboYear,ComboChartType)、Label1～Label4，程序为：

Option Explicit

Public iChartType As Integer  '当前图表类型

Public cnn As ADODB.Connection

 

'双击数据点可以更改数据，并反馈到图形上

Private Sub ChartDemo_PointActivated(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)

  Dim vtPoint

    With ChartDemo

        .Column = Series

        .Row = DataPoint

        vtPoint = InputBox("更改数据点:", , .Data)

        If vtPoint <> "" Then

            If IsNumeric(vtPoint) Then

                .Data = vtPoint

            Else

                MsgBox "没有有效的数据点!"

            End If

        End If

    End With

End Sub

 

'单击数据点在Label4上反映该点的值

Private Sub ChartDemo_PointSelected(Series As Integer, DataPoint As Integer, MouseFlags As Integer, Cancel As Integer)

  ' 允许用户在序列中通过选择特别的数据点来查阅它的值。

    ' 数据点的值被显示在名为 lblDatapoint 的标签中。

    ChartDemo.Column = Series

    ChartDemo.Row = DataPoint

    Label4.Caption = "序列的值 " & Series & ", 点 " & DataPoint & " = " & ChartDemo.Data

End Sub

 

'选择图形类型

Private Sub ComboChartType_click()

   Dim i As Integer

   Dim strType As String

   strType = ComboChartType.Text

   Select Case strType

   Case "饼图"

      iChartType = 14

   Case "折线图"

      iChartType = 3

   Case "立体图"

      iChartType = 0

   Case "柱状图"

      iChartType = 9

   End Select

   ChartDemo.chartType = iChartType

   ComboYear_click

End Sub

 

'选择年份

Private Sub ComboYear_click()

   Dim strYear, strStation As String

   Dim i As Integer

   Dim arrChartData()

   Dim strSql As String

   Dim rstChartData As New ADODB.Recordset

  

   strYear = ComboYear.Text

   If strYear = "" Then

      Exit Sub

   End If

   ChartDemo.Visible = True

   strStation = Liststation.Text

   strSql = "select * from addvdata where addvcd='" _

           & strStation & "' and year=" & strYear

   rstChartData.Open strSql, cnn ', adOpenDynamic, adLockOptimistic

  

   If iChartType = 3 Then

      ReDim arrChartData(1 To 12, 1 To 1)

      For i = 1 To 12

         arrChartData(i, 1) = rstChartData.Fields(i + 1)

      Next i

      With ChartDemo

         .ChartData = arrChartData

         .RowCount = 12

         .ColumnLabelCount = 12

         For i = 1 To 12

            .Row = i

            .RowLabel = rstChartData.Fields(i + 1).Name

         Next i

         .ColumnCount = 1

         .Column = 1

         .ColumnLabel = ""

         .Refresh

      End With

   Else

      ReDim arrChartData(1 To 1, 1 To 12)

      For i = 1 To 12

         arrChartData(1, i) = rstChartData.Fields(i + 1)

      Next i

      With ChartDemo

         .ChartData = arrChartData

         .ColumnCount = 12

         .ColumnLabelCount = 12

         For i = 1 To 12

            .Column = i

            .ColumnLabel = rstChartData.Fields(i + 1).Name

         Next i

         .RowCount = 1

         .Row = 1

         .RowLabel = ""

         .Refresh

      End With

   End If

   rstChartData.Close

   strSql = ""

End Sub

 

Private Sub Form_Load()

   Dim rst1 As New ADODB.Recordset

   Set cnn = New ADODB.Connection

   cnn.Open "Provider=MSDASQL.1;Persist Security Info=False;Data Source=Demo"

   If Err Then

      MsgBox "数据库打开失败", vbOKOnly, "提示"

      End

   End If

   ComboChartType.AddItem "饼图"

   ComboChartType.AddItem "折线图"

   ComboChartType.AddItem "立体图"

   ComboChartType.AddItem "柱状图"

  

   rst1.Open "select * from addvdata ", cnn

   Do While Not rst1.EOF

      Liststation.AddItem rst1!addvcd

      rst1.MoveNext

   Loop

   rst1.Close

   ChartDemo.Refresh

End Sub

 

'测站代码列表

Private Sub ListStation_Click()

   Dim strScode As String

   Dim rstYear As New ADODB.Recordset

   strScode = Liststation.Text

   If strScode = "" Then

      Exit Sub

   End If

   ComboYear.Clear

   rstYear.Open "select distinct year from addvdata where addvcd='" + strScode + "'", cnn ', adOpenDynamic, adLockOptimistic

   Do While Not rstYear.EOF

      ComboYear.AddItem rstYear.Fields("year")

      rstYear.MoveNext

   Loop

   rstYear.Close

End Sub

 

 

 

 

用剪贴板向WORD中添加图形和文字

建立一个COMMAND1和一个PICTURE1，在PICTURE1中添加一幅图。

Option Explicit

Dim objWord As Object

Private Sub Command1_Click()

  Const CLASSOBJECT = "Word.Application"

  On Error GoTo objError

  Set objWord = CreateObject(CLASSOBJECT)

  objWord.Visible = True

  objWord.Documents.Add

 

  With objWord

    .ActiveDocument.paragraphs.Last.Range.Bold = False

    .ActiveDocument.paragraphs.Last.Range.Font.Size = 14

    .ActiveDocument.paragraphs.Last.Range.Font.Name = "黑体"

    .ActiveDocument.paragraphs.Last.Range.Font.colorindex = 0

    '.ActiveDocument.paragraphs.Last.Range.Text = Chr(13) & "向WORD中传递数据和图形练习"

  End With

 

  Clipboard.Clear

  Clipboard.SetData Picture1.Picture

  objWord.Selection.Paste

  Clipboard.Clear

  Clipboard.SetText "通过剪帖板向WORD传递字符"

  objWord.Selection.Paste

  objWord.PrintPreview = True '打印预览

  'objWord.PrintOut   '打印

  'objWord.Quit    '结束Word

  Exit Sub

 

objError:

  If Err <> 429 Then

    MsgBox Str$(Err) & Error$

    Set objWord = Nothing

    Exit Sub

  Else

    Resume Next

  End If

End Sub

在WORD中产生表格和文字

Private Sub Command3_Click()

  Dim objWord As Object

  Set objWord = CreateObject("Word.Application")

  objWord.Visible = True                     '取消此行最后加上.Quit在后台运行

  objWord.Documents.Add                    '可以加上路径，打开指定文件

  With objWord

    .Selection.Font.Name = "黑体"

    .Selection.Font.Size = 14

    .Selection.Font.Bold = True

    .Selection.TypeText Text:="xuewei"

    .Selection.Font.Name = "宋体"

    .Selection.Font.Size = 10.5

    .Selection.Font.Bold = False

    .Selection.TypeParagraph               '换行

    '产生一个2行5列的表格

    .ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=2, NumColumns:=5

    .Selection.TypeText Text:="12"

    .Selection.MoveRight                   '向右移动光标，移到最后一个后自动到下行的第一个

    .Selection.TypeText Text:="34"

    .Selection.MoveDown                    '向下移动光标

    .Selection.TypeText Text:="56"

    .Selection.MoveDown

    .Selection.TypeParagraph

    .Selection.TypeText Text:="end"

    .Selection.TypeParagraph

  End With

End Sub

向WORD中传送SELECT表和CHART控件图形

添加PictureBox控件PicGraph，运行时先使Chart1控件有图形，然后点击Command3。

Private Sub Command3_Click()

  Dim intWinState As Integer

  Dim objWord As Object

  Dim sql, i

  Dim str1 As String

  Dim Rows1, Columns1

 

  On Error GoTo objError

  Set objWord = CreateObject("Word.Application")

  With objWord

    .Visible = True

    .Documents.Add   '"c:/My Document/test1.doc"

    .Selection.TypeText Text:="表标题"

    .Selection.TypeParagraph

    .Selection.TypeParagraph

    .Selection.MoveUp , Count:=2

    .Selection.Style = .ActiveDocument.Styles("标题 1")

    .Selection.ParagraphFormat.Alignment = 1

    .Selection.MoveDown

    .Selection.TypeText Text:="插入表"

    .Selection.TypeParagraph

  End With

 

  sql = "select * from hydnet"

  rst0.Open sql, cnn

  i = 0

  While Not rst0.EOF

    i = i + 1

    rst0.MoveNext

  Wend

  Rows1 = i

  Columns1 = rst0.Fields.Count

 

  If i > 0 Then

    objWord.ActiveDocument.Tables.Add Range:=objWord.Selection.Range, NumRows:=Rows1, NumColumns:=Columns1

    rst0.MoveFirst

    While Not rst0.EOF

      For i = 0 To rst0.Fields.Count - 1

        str1 = rst0.Fields(i)

        objWord.Selection.TypeText Text:=str1

        objWord.Selection.MoveRight

      Next i

      rst0.MoveNext

    Wend

  End If

 

  objWord.Selection.MoveRight , Count:=2

  objWord.Selection.TypeText Text:="图形显示"

  objWord.Selection.TypeParagraph

  objWord.Selection.TypeParagraph

 

  Chart1.EditCopy

  PicGraph.Picture = Clipboard.GetData

  Clipboard.Clear

  Clipboard.SetData PicGraph.Picture

  objWord.Selection.Paste

  'objWord.PrintPreview = True '打印预览

  'objWord.PrintOut   '打印

  'objWord.Quit    '结束Word

  Set objWord = Nothing

  rst0.Close

  Exit Sub

 

objError:

  If Err <> 429 Then

    MsgBox Str$(Err) & Error$

    Set objWord = Nothing

    Exit Sub

  Else

    Resume Next

  End If

End Sub

通过剪贴板打印CHART控件图形

添加CommonDialog控件Common1，PictureBox控件PicGraph，运行时先使Chart1控件有图形，然后点击Command30。

Private Sub Command30_Click()

   Dim intWinState As Integer

   Dim intCopies As Integer

   Dim intCopy As Integer

  

   On Error GoTo errPrint

   With Common1

      .CancelError = True

      .ShowPrinter

      intCopies = .Copies

   End With

  

   'Expand to full screen to get large graph

   intWinState = WindowState

   WindowState = vbMaximized

   Chart1.EditCopy

   'Return to prior mode

   WindowState = intWinState

   PicGraph.Picture = Clipboard.GetData

   For intCopy = 1 To intCopies

      Printer.Print ""

      Printer.PaintPicture PicGraph.Picture, 0, 0

      'Add a caption at mid page

      Printer.CurrentY = Printer.ScaleHeight / 2

      Printer.FontSize = 18

      Printer.CurrentX = 1500

      'Printer.Print "Northwind Traders - " & frmMDIGraph.Caption

      Printer.EndDoc

   Next intCopy

errPrint:

   Exit Sub

End Sub

写入HTML文件

要引用“Microsoft Word 9.0 Object Library”，然后编程如下：

Private Sub Command1_Click()

  Dim objWord As Object

  Set objWord = CreateObject("Word.Application")

  objWord.Visible = True

  objWord.Documents.Add '"c:/My Documents/X2.HTM"

  With objWord

    .Selection.MoveDown

    .Selection.Font.Name = "黑体"

    .Selection.Font.Size = 14

    .Selection.Font.Bold = True

    .Selection.TypeText Text:="xuewei"

    .Selection.Font.Name = "宋体"

    .Selection.Font.Size = 10.5

    .Selection.Font.Bold = False

    .Selection.TypeParagraph               '换行

    '产生一个2行5列的表格

    .ActiveDocument.Tables.Add Range:=.Selection.Range, NumRows:=2, NumColumns:=5

    .Selection.TypeText Text:="12"

    .Selection.MoveRight                   '向右移动光标，移到最后一个后自动到下行的第一个

    .Selection.TypeText Text:="34"

    .Selection.MoveDown                    '向下移动光标

    .Selection.TypeText Text:="56"

    .Selection.MoveDown

    .Selection.TypeParagraph

    .Selection.TypeText Text:="end6"

    .Selection.TypeParagraph

    .ActiveDocument.SaveAs FileName:="x1.htm", FileFormat:=wdFormatHTML, WritePassword _

        :="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:=False, _

        SaveNativePictureFormat:=False, SaveFormsData:=False, SaveAsAOCELetter:= _

        False

    .quit

  End With

End Sub

 

 

十六  ActiveX 编程

调用简单DLL的例子

本例是一个ActiveX dll编程和调试的例子。实现简单的加法。

（1）建立工程1，其中有Form1:Command1；

（2）建立一个ActiveX dll控件（名为xdll02），类模块xclass2；

（3）在xclass2中代码如下：

Public den As Integer

Public Sub add(num2, num1 As Integer)

  den = num1 + num2

End Sub

（4）生成xdll02.dll；

（5）选择【工程】/【引用】，选用xdll02；

（6）在Form1中添加Command1,Text1,Text2,Text3，代码如下：

Public xx1 As New xdll02.xClass2

Private Sub Command1_Click()

  xx1.Add Text2, Text1

  Text3 = xx1.den

End Sub

 

Private Sub Form_Load()

  Text1 = 2

  Text2 = 4

  Text3 = 0

End Sub

（7）运行。运行时单击Command1，Text3中出现答案6。

注意，调试时，直接改动ActiveX dll中的代码即可，不需要重新安装dll。

调用DLL的另一个例子

工程1：Form1:Command1

Tingdemo2(ActiveX dll)：Class1,并形成组１。

运行前还要右击工程１，选择【设置为启动】，再引用Tingdemo2。

Class1代码：

Option Explicit

Public Name As String

Private mdtmCreated As Date

 

Public Property Get created() As Date

  created = mdtmCreated

End Property

 

Public Sub ReverseName()

  Dim intCt As Integer

  Dim strNew As String

  For intCt = 1 To Len(Name)

    strNew = Mid$(Name, intCt, 1) & strNew

  Next

  Name = strNew

End Sub

 

Private Sub Class_Initialize()

  mdtmCreated = Now

  MsgBox "Name=" & Name & vbCrLf & "Created:" & created, , "thing initialize"

End Sub

 

Private Sub Class_Terminate()

  MsgBox "Name = " & Name & vbCrLf & "Created:" & created, , "thing terminate"

End Sub

 

Form1代码：

Option Explicit

Private mth As New tingdemo2.Class1

 

Private Sub Command1_Click()

  MsgBox "Name=" & mth.Name & vbCrLf & "Created:" & mth.created, , "from thing"

End Sub

。。。。。。

 

Private Sub Form_Load()

  mth.Name = InputBox("Enter a name for the Thing:")

End Sub

简单ActiveX控件编程

先打开标准EXE工程，再填加一个ActiveX控件工程，再在Usercontrol1中填加控件如下：

代码：

Private Sub Command1_Click()

  If List1.ListIndex >= 0 Then

    List2.AddItem List1.List(List1.ListIndex)

    List1.RemoveItem (List1.ListIndex)

  End If

End Sub

 

Private Sub Command2_Click()

  If List2.ListIndex >= 0 Then

    List1.AddItem List2.List(List2.ListIndex)

    List2.RemoveItem (List2.ListIndex)

  End If

End Sub

 

Private Sub List1_Click()

  Command1.Enabled = True

  Command2.Enabled = False

End Sub

 

Private Sub List2_Click()

  Command1.Enabled = False

  Command2.Enabled = True

End Sub

 

Private Sub UserControl_Initialize()

  List1.AddItem "AAA"

  List1.AddItem "BBB"

  List1.AddItem "CCC"

  List1.AddItem "DDD"

End Sub

功能为：单击Command1，List1中的选择项右移，单击Command2，List2中的选择项左移；

关闭工程2，在Form1中填加ActiveX控件Control11，就可以运行了。

ActiveX控件的事件和方法

回到Control1，填加一个Command3，再打开菜单中的“ActiveX控件接口向导”，先单击“<<”清除所有选定名称，单击“下一步”，单击“新建”，填加如下表：

公有名称	类型	映射	成员
CtlEnd	Event	Command3	Click
Clear1	Method	List1	Clear
Add1	Method	List1	AddItem
Sub1	Method	List1	RemoveItem

完成后，代码变成：

……

Event ctlend() 'MappingInfo=Command3,Command3,-1,Click

 

'注意！不要删除或修改下列被注释的行！

'MappingInfo=List1,List1,-1,AddItem

Public Sub add1(ByVal Item As String, Optional ByVal Index As Variant)

  List1.AddItem Item, Index

End Sub

 

'注意！不要删除或修改下列被注释的行！

'MappingInfo=List1,List1,-1,RemoveItem

Public Sub sub1(ByVal Index As Integer)

  List1.RemoveItem Index

End Sub

 

'注意！不要删除或修改下列被注释的行！

'MappingInfo=List1,List1,-1,Clear

Public Sub clear1()

  List1.Clear

End Sub

 

Private Sub Command3_Click()

  RaiseEvent ctlend

End Sub

 

再关闭Control1，到Form1中添加Control11，再填加3个按钮如下：

代码为：

Private Sub Command4_Click()

  Dim inItem As String

  inItem = InputBox("Please input data:")

  UserControl11.add1 inItem

End Sub

 

Private Sub Command5_Click()

  Dim ItemNum As String

  ItemNum = InputBox("Please input Num:")

  UserControl11.sub1 ItemNum

End Sub

 

Private Sub Command6_Click()

  UserControl11.Clear1

End Sub

 

Private Sub Form_Load()

  UserControl11.add1 "new 1"

End Sub

 

Private Sub UserControl11_ctlend()

  End

End Sub

 

运行后，产生效果为：单击Add，在List1中可以添加一项，单击Sub，在List1中输入序号可以减少一行，单击Clear，清除List1中所有数据，单击Quit退出。

ActiveX属性和事件调用

同前，先产生一个普通工程，再产生一个ActiveX控件工程，其上添加一个Command和Text控件，再打开菜单中的“ActiveX控件接口向导”，先单击“<<”清除所有选定名称，单击“下一步”，单击“新建”，填加如下表：

公有名称	类型	映射	成员
pclick	Event	Command1	Click
Text0	Property	Text1	Text

完成后，代码变成：

'事件声明:

Event pclick() 'MappingInfo=Command1,Command1,-1,Click

 

'注意！不要删除或修改下列被注释的行！

'MappingInfo=Text1,Text1,-1,Text

Public Property Get text0() As String

  text0 = Text1.Text

End Property

 

Public Property Let text0(ByVal New_text0 As String)

  Text1.Text() = New_text0

  PropertyChanged "text0"

End Property

 

Private Sub Command1_Click()

  RaiseEvent pclick

  MsgBox Me.text0     ‘自己添加

End Sub

 

'从存贮器中加载属性值

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)

 

  Text1.Text = PropBag.ReadProperty("text0", "Text1")

End Sub

 

'将属性值写到存储器

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)

 

  Call PropBag.WriteProperty("text0", Text1.Text, "Text1")

End Sub

 

其中msgbox一行是另外添加的。再在普通工程的form1中加上这个控件，如下编写：

Private Sub Form_Load()

  UserControl11.text0 = "print123"

End Sub

 

Private Sub UserControl11_pclick()

  'Print UserControl11.text0

End Sub

 

就可以调用ActiveX控件的属性和事件了。

 

十七  面向对象的编程

调用类模块的对象

本例可以看出一个对象在初始化和释放时的过程。

放置控件:  Form1:Command1, Command2, Command3, Command4, Command5,

                Class1（类模块）:name=Thing

属性设置:

Class1代码：

Option Explicit

Public Name As String

Private mdtmCreated As Date

 

Public Property Get created() As Date

  created = mdtmCreated

End Property

 

Public Sub ReverseName()

  Dim intCt As Integer

  Dim strNew As String

  For intCt = 1 To Len(Name)

    strNew = Mid$(Name, intCt, 1) & strNew

  Next

  Name = strNew

End Sub

 

Private Sub Class_Initialize()

  mdtmCreated = Now

  MsgBox "Name=" & Name & vbCrLf & "Created:" & created, , "thing initialize"

End Sub

 

Private Sub Class_Terminate()

  MsgBox "Name = " & Name & vbCrLf & "Created:" & created, , "thing terminate"

End Sub

 

Form1代码：

Option Explicit

'对 Thing 对象的引用。

Private mth As thing

 

'按钮“Create New Thing”。

Private Sub Command1_Click()

  MsgBox "Name=" & mth.Name & vbCrLf & "Created:" & mth.created, , "from thing"

End Sub

 

'按钮“Reverse the Thing's Name”。

Private Sub Command2_Click()

  mth.ReverseName

  '通过设置值来单击“Show the Thing”。

  Command1.Value = True

End Sub

 

'新建

Private Sub Command3_Click()

  Set mth = New thing

  mth.Name = InputBox("Enter a name for new Thing:")

End Sub

 

'暂存

Private Sub Command4_Click()

  Dim thTemp As New thing

  thTemp.Name = InputBox("Enter a name for the temporary Thing:")

End Sub

 

'释放

Private Sub Command5_Click()

  Set mth = Nothing

End Sub

 

Private Sub Form_Load()

  Set mth = New thing

  mth.Name = InputBox("Enter a name for the Thing:")

End Sub

属性过程编程

用Property Get读属性，Property Let写（改变）属性，Property Set来给一个对象设置引用。

放置控件:  Form1:Command1, Command2, Command3

代码:

Private Sizestatus As Boolean

Property Get Sizer() As Boolean

  Sizer = Sizestatus

End Property

 

Property Let Sizer(x As Boolean)

  Sizestatus = x

  If x = False Then

    Width = Width / 1.5

  Else

    Width = Width * 1.5

  End If

End Property

 

Private Sub Command1_Click()

  Sizer = False

End Sub

 

Private Sub Command2_Click()

  Sizer = True

End Sub

 

Private Sub Command3_Click()

  If Sizer = False Then Print "lessen form, Sizer=" & Sizer

  If Sizer = True Then Print "larger form, Sizer=" & Sizer

End Sub

注意，在点击Command1时，调用Property Let过程。这时x作为sizer的值，带入进去计算。点击Command2时，调用Property Get过程。

十八  ActiveX控件网络实用编程

建立一个简单的ADO连接

1．在【控制面板】/【ODBC数据源】建立一个文件DSN，如test02.dsn，连接到本地的一个数据库，如C:/My Documents/共享/test1.mdb；

2．在VB中建立一个ActiveX控件工程（Gxue20）和一个用户控件（Uxue20.ctl）；

3．添加部件Microsoft ADO Data Control 6.0，把控件实例ADODC1加到Uxue20上；再添加一个Text1；

4．添加ADODC1属性ConnectionString，单击【。。。】，在对话框中选择【使用连接字符串】，选择test02.dsn，再将生成的字符串的本地地址DBQ=C:/My Documents/共享/test1.mdb….改为服务器地址，如DBQ=//xuewei/共享/test1.mdb…；再将RecordSource属性设为一个表名（如表1）；

5．把Text1绑定到ADODC1的表的“代码”字段上（设DataSource=ADODC1;DataField=代码）；

6．保存工程和控件；

7．使用【外接程序】/【打包和展开向导】，把Gxue20做成一个Internet包，放在一个WEB文件夹中。

8．这时可以在网络上运行自动生成文件Gxue20.htm了。

简单数据库打印

同前，把ADODC1加到Uxue20上；再添加一个Command1；

把上例ADODC1的ConnectinString值复制到程序中，再加上简单打印语句：

Private Sub Command1_Click()

  Dim dbq1 As String

  Dim pw, ph As Integer

  Dim px, py As Integer

  Dim temp As String

 

  dbq1 = "DBQ=//xuewei/共享/test1.mdb;DefaultDir=c:/My Documents/共享/t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1

  Adodc1.RecordSource = "select * from 表1"

  Adodc1.Refresh

 

  pw = 400: ph = 650

  px = 20: py = 100

  Printer.Scale (0, 0)-(pw, ph)

  temp = Adodc1.Recordset(2)

  py = py + 30

  Printer.CurrentX = px

  Printer.CurrentY = py

  Printer.Print temp

  Printer.EndDoc

  MsgBox "打印完毕"

End Sub

程序运行结果，打印一行数据。

数据表直接打印

ActiveX控件制作：

1．新建ActiveX控件工程；

2．添加ADODC1控件和COMMAND1控件；

3．代码：

Option Explicit

Dim pw, ph '纸宽和纸高的坐标

Dim px, py

Dim ti   '报表字段数

Dim wh, ww  '字宽和字高

Dim table1  '第一页表格开始高度

Dim daima(100, 3) As String

Dim bnum As Integer

 

Private Function len1(str As String) As Integer

  Dim si, i As Integer

  Dim str1 As String

  si = 0

  For i = 1 To Len(str)

    str1 = Mid(str, i, 1)

    If Asc(str1) < 0 Then

      si = si + 2

    Else

      si = si + 1

    End If

  Next

  len1 = si

End Function

 

Private Function len2(s2 As String, si As Integer) As String

  Do While len1(s2) > si

    s2 = Mid(s2, 1, Len(s2) - 1)

  Loop

  len2 = s2

End Function

 

Private Sub finput()

  Dim i As Integer

  ti = Adodc1.Recordset.Fields.Count

  For i = 1 To ti

    daima(i, 1) = Adodc1.Recordset.Fields(i - 1).Name

    daima(i, 2) = len1(daima(i, 1)) + 2        '表格宽度

    daima(i, 3) = Adodc1.Recordset.Fields(i - 1).Name

  Next i

End Sub

 

Private Sub printhead()

  Dim pp0, tpp, i

  Printer.CurrentX = 150: Printer.CurrentY = 30

  Printer.FontSize = 19: Printer.FontBold = True

  pp0 = 20 - (len1(Thead))

  tpp = ""

  For i = 1 To pp0

    tpp = tpp + " "

  Next i

  Printer.Print tpp & Thead

  table1 = 50

End Sub

 

Private Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)

  Dim py1 As Integer

  Dim pxm, pxi, px1, bi

  Dim daim1, daim2 As String

 

  pxm = 0                           '计算报表宽度

  For pxi = 1 To ti

    pxm = pxm + daima(pxi, 2) * ww

  Next

 

  Printer.DrawWidth = 3

  Printer.FontSize = 11

  Printer.FontBold = True

  py = pp1 + (pp3 + 2 - pp2) * wh      '计算报表高度

 

  Printer.Line (0, pp1)-(pxm, pp1)     '打印边框

  Printer.Line (pxm, pp1)-(pxm, py)

  Printer.Line (pxm, py)-(0, py)

  Printer.Line (0, py)-(0, pp1)

 

  Printer.DrawWidth = 1                '打印表头

  px = 0

  For pxi = 1 To ti

    daim2 = daima(pxi, 1)

    px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)

    Printer.CurrentX = px + px1 * ww

    Printer.CurrentY = pp1 + Int(0.2 * wh)

    Printer.Print daima(pxi, 1)                  '打印字段名

    px = px + daima(pxi, 2) * ww

    Printer.Line (px, pp1)-(px, py)              '打印竖线

  Next

 

  Printer.FontBold = False

  py = pp1 + wh

  For bi = pp2 To pp3

    px = 0

    For pxi = 1 To ti

      Printer.CurrentX = px + 2

      Printer.CurrentY = py + Int(0.2 * wh)

      daim1 = daima(pxi, 3)

      'Select Case daim1

        'Case "序号": daim2 = bi                 '打印序号

        'Case "空白": daim2 = ""                 '打印空白字段

        'Case Else: daim2 = Adodc1.Recordset(daim1)

      'End Select

      If IsNull(Adodc1.Recordset(daim1)) Then

        daim2 = ""

      Else

        daim2 = Adodc1.Recordset(daim1)

      End If

     

      Printer.Print len2(daim2, Int(daima(pxi, 2)))  '打印字段内容

      px = px + daima(pxi, 2) * ww

    Next pxi

    Printer.Line (0, py)-(pxm, py)                   '打印横线

    py = py + wh

    Adodc1.Recordset.MoveNext

  Next bi

  End Sub

 

Private Sub printfoot(pp1 As Integer, pp2 As Integer)        '打印页码

  px = pw - 300: py = ph - 5 * wh

  Printer.CurrentX = px: Printer.CurrentY = py

  Printer.Print "总页数:" & pp2 & "    当前页数:" & pp1

End Sub

 

Private Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)

  Call printframe(p1, p2, p3)

  Call printfoot(p4, p5)

End Sub

 

Private Sub printbody()

  Dim page As Integer     '页码数

  Dim pi As Integer

  Dim p1y As Integer      '第一页记录数

  Dim p2y As Integer      '第二页记录数

  Dim table2              '第二页起始位置

 

  p2y = 37

  table2 = 20

  table1 = table1 + wh

  p1y = (ph - table1 - 100) / wh

 

  Adodc1.Recordset.MoveFirst

  If bnum < p1y + 1 Then

    Call printail(table1, 1, bnum, 1, 1)         '只有一页

  Else

    page = Int(((bnum - p1y) / p2y) + 1.9999)    '计算页码

    Call printail(table1, 1, p1y, 1, page)       '打印第一页

    If page > 2 Then

      For pi = 1 To page - 2

        Printer.NewPage

        Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)

      Next pi

      Printer.NewPage

      Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页

    Else

      Printer.NewPage

      Call printail(table2, p1y + 1, bnum, page, page)  '打印最后一页

    End If

  End If

End Sub

 

Private Sub printp()

  Dim sp    '左边距

  pw = 850: ph = 600

  wh = 13

  ww = 9

  sp = 40

  Printer.Scale (-sp, 0)-(pw, ph)

  printhead

  printbody

  Printer.EndDoc       ‘开始打印

End Sub

 

Private Sub Command1_Click()

  Dim dbq1

  dbq1 = "DBQ=//xuewei/共享/test1.mdb;DefaultDir=c:/My Documents/共享/t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1

  Adodc1.RecordSource = Tname

  Adodc1.Refresh

  bnum = Adodc1.Recordset.RecordCount

  finput

  printp

  MsgBox "打印完毕。共有" & bnum & "条记录"

  Adodc1.Recordset.Close

  Command1.Enabled = False

End Sub

 

4．产生Tname和Thead属性的接口；

5．打成INTERNET包；

6．在网页上代码如下：

 

<HTML>

<HEAD>

<TITLE>Gxue32.CAB</TITLE>

</HEAD>

<BODY>

数据库表格打印示例

<p></p>

<OBJECT ID="Uxue32"

CLASSID="CLSID:0DF80DF0-B268-11D5-9C19-0010D70B5752"

CODEBASE="Gxue32.CAB#version=1,0,0,0" width="79" height="33">

<param name="_ExtentX" value="2090">

<param name="_ExtentY" value="873">

<param name="Tname" value="表1">

<param name="Thead" value="数据简表">

</OBJECT>

</BODY>

</HTML>

 

数据表格式打印

ActiveX控件制作步骤同上，增加一个Tarray属性，代码：

Option Explicit

Dim pw, ph '纸宽和纸高的坐标

Dim px, py

Dim ti   '报表字段数

Dim wh, ww  '字宽和字高

Dim table1  '第一页表格开始高度

Dim daima(100, 3) As String   ‘打印数组

Dim tax(100, 2) As String     ‘格式数组

Dim bnum As Integer                   ‘总记录数

 

Private Function len1(str As String) As Integer

  Dim si, i As Integer

  Dim str1 As String

  si = 0

  For i = 1 To Len(str)

    str1 = Mid(str, i, 1)

    If Asc(str1) < 0 Then

      si = si + 2

    Else

      si = si + 1

    End If

  Next

  len1 = si

End Function

 

Private Function len2(s2 As String, si As Integer) As String

  Do While len1(s2) > si

    s2 = Mid(s2, 1, Len(s2) - 1)

  Loop

  len2 = s2

End Function

 

Private Function midx(taa) As String

  Dim ii As Integer

  Dim char1 As String

  char1 = Mid(taa, 1, 1)

  midx = ""

  ii = 1

  Do While char1 <> "{" And ii <= Len(taa) + 1

    midx = midx & char1

    ii = ii + 1

    char1 = Mid(taa, ii, 1)

  Loop

  'If ii = Len(taa) Then midx = taa

  'MsgBox "taa=" & taa & "  midx=" & midx

End Function

 

Private Sub toarray(tt)

  Dim ii As Integer

  Dim tt0

  tax(0, 0) = midx(tt)

 

  tt0 = Mid(tt, Len(tax(0, 0)) + 2, Len(tt))

  If tax(0, 0) > 0 Then

    For ii = 1 To tax(0, 0)

      tax(ii, 1) = midx(tt0)

      tt0 = Mid(tt0, Len(tax(ii, 1)) + 2, Len(tt0))

      tax(ii, 2) = midx(tt0)

      tt0 = Mid(tt0, Len(tax(ii, 2)) + 2, Len(tt0))

    Next ii

  End If

End Sub

 

Private Sub finput()

  Dim i As Integer

  toarray (Tarray)

  ti = Adodc1.Recordset.Fields.Count

  If ti > tax(0, 0) Then ti = tax(0, 0)

  For i = 1 To ti

    daima(i, 1) = tax(i, 1)

    daima(i, 2) = tax(i, 2)      '表格宽度

    daima(i, 3) = Adodc1.Recordset.Fields(i - 1).Name

  Next i

End Sub

 

Private Sub printhead()

  Dim pp0, tpp, i

  Printer.CurrentX = 150: Printer.CurrentY = 30

  Printer.FontSize = 19: Printer.FontBold = True

  pp0 = 20 - (len1(Thead))

  tpp = ""

  For i = 1 To pp0

    tpp = tpp + " "

  Next i

  Printer.Print tpp & Thead

  table1 = 50

End Sub

 

Private Sub printframe(ByVal pp1 As Integer, pp2 As Integer, pp3 As Integer)

  Dim py1 As Integer

  Dim pxm, pxi, px1, bi

  Dim daim1, daim2 As String

 

  pxm = 0                           '计算报表宽度

  For pxi = 1 To ti

    pxm = pxm + daima(pxi, 2) * ww

  Next

 

  Printer.DrawWidth = 3

  Printer.FontSize = 11

  Printer.FontBold = True

  py = pp1 + (pp3 + 2 - pp2) * wh      '计算报表高度

 

  Printer.Line (0, pp1)-(pxm, pp1)     '打印边框

  Printer.Line (pxm, pp1)-(pxm, py)

  Printer.Line (pxm, py)-(0, py)

  Printer.Line (0, py)-(0, pp1)

 

  Printer.DrawWidth = 1                '打印表头

  px = 0

  For pxi = 1 To ti

    daim2 = daima(pxi, 1)

    px1 = Int((daima(pxi, 2) - len1(daim2)) / 2)

    Printer.CurrentX = px + px1 * ww

    Printer.CurrentY = pp1 + Int(0.2 * wh)

    Printer.Print daima(pxi, 1)                  '打印字段名

    px = px + daima(pxi, 2) * ww

    Printer.Line (px, pp1)-(px, py)              '打印竖线

  Next

 

  Printer.FontBold = False

  py = pp1 + wh

  For bi = pp2 To pp3

    px = 0

    For pxi = 1 To ti

      Printer.CurrentX = px + 2

      Printer.CurrentY = py + Int(0.2 * wh)

      daim1 = daima(pxi, 3)

      'Select Case daim1

        'Case "序号": daim2 = bi                 '打印序号

        'Case "空白": daim2 = ""                 '打印空白字段

        'Case Else: daim2 = Adodc1.Recordset(daim1)

      'End Select

      If IsNull(Adodc1.Recordset(daim1)) Then

        daim2 = ""

      Else

        daim2 = Adodc1.Recordset(daim1)

      End If

     

      Printer.Print len2(daim2, Int(daima(pxi, 2)))  '打印字段内容

      px = px + daima(pxi, 2) * ww

    Next pxi

    Printer.Line (0, py)-(pxm, py)                   '打印横线

    py = py + wh

    Adodc1.Recordset.MoveNext

  Next bi

  End Sub

 

Private Sub printfoot(pp1 As Integer, pp2 As Integer)        '打印页码

  px = pw - 300: py = ph - 5 * wh

  Printer.CurrentX = px: Printer.CurrentY = py

  Printer.Print "总页数:" & pp2 & "    当前页数:" & pp1

End Sub

 

Private Sub printail(ByVal p1 As Integer, p2 As Integer, p3 As Integer, p4 As Integer, p5 As Integer)

  Call printframe(p1, p2, p3)

  Call printfoot(p4, p5)

End Sub

 

Private Sub printbody()

  Dim page As Integer     '页码数

  Dim pi As Integer

  Dim p1y As Integer      '第一页记录数

  Dim p2y As Integer      '第二页记录数

  Dim table2              '第二页起始位置

 

  p2y = 37

  table2 = 20

  table1 = table1 + wh

  p1y = (ph - table1 - 100) / wh

 

  Adodc1.Recordset.MoveFirst

  If bnum < p1y + 1 Then

    Call printail(table1, 1, bnum, 1, 1)         '只有一页

  Else

    page = Int(((bnum - p1y) / p2y) + 1.9999)    '计算页码

    Call printail(table1, 1, p1y, 1, page)       '打印第一页

    If page > 2 Then

      For pi = 1 To page - 2

        Printer.NewPage

        Call printail(table2, p1y + (pi - 1) * p2y + 1, p1y + pi * p2y, pi + 1, page)

      Next pi

      Printer.NewPage

      Call printail(table2, p1y + (page - 2) * p2y + 1, bnum, page, page) '打印最后一页

    Else

      Printer.NewPage

      Call printail(table2, p1y + 1, bnum, page, page)  '打印最后一页

    End If

  End If

End Sub

 

Private Sub printp()

  Dim sp    '左边距

  pw = 850: ph = 600

  wh = 13

  ww = 9

  sp = 40

  Printer.Scale (-sp, 0)-(pw, ph)

  printhead

  printbody

  Printer.EndDoc

End Sub

 

Private Sub Command1_Click()

  Dim dbq1

  dbq1 = "DBQ=//xuewei/共享/test1.mdb;DefaultDir=c:/My Documents/共享/t;Driver={Microsoft Access Driver (*.mdb)};DriverId=25;FIL=MS Access;FILEDSN=C:/Program Files/Common Files/ODBC/Data Sources/test03.dsn;MaxBufferSize=2048;MaxScanRows=8;PageTimeout=5;SafeTransactions=0;Threads=3;UID=admin;UserCommitSync=Yes;"

  Adodc1.ConnectionString = "MSDASQL.1;Persist Security Info=False;Extended Properties=" & dbq1

  Adodc1.RecordSource = Tname

  Adodc1.Refresh

  bnum = Adodc1.Recordset.RecordCount

  finput

  printp

  MsgBox "打印完毕。共有" & bnum & "条记录"

  Adodc1.Recordset.Close

  Command1.Enabled = False

End Sub

 

打包后在网页上编程为：

 

<script language="vbscript">

<!--

Option Explicit

dim ta0(100,2)

 

Private Function len1(str)

  Dim si, i

  Dim str1

  si = 0

  For i = 1 To Len(str)

    str1 = Mid(str, i, 1)

    If Asc(str1) < 0 Then

      si = si + 2

    Else

      si = si + 1

    End If

  Next

  len1 = si

End Function

 

Private Function tostring ()

  Dim ii

  tostring = Ta0(0, 0) & "{"

  For ii = 1 To Ta0(0, 0)

    If IsNull(Ta0(ii, 1)) Then Ta0(ii, 1) = ""

    tostring = tostring & Ta0(ii, 1) & "{"

    If IsNull(Ta0(ii, 2)) Then Ta0(ii, 2) = 0

    If Ta0(ii, 2) < len1(Ta0(ii, 1)) + 2 Then

      Ta0(ii, 2) = len1(Ta0(ii, 1)) + 2

    End If

    tostring = tostring & Ta0(ii, 2) & "{"

  Next

End Function

 

Private Sub window_onload()

  form1.Uxue33.Tname = "注册登记表"

  form1.Uxue33.Thead = "取水许可证系统注册登记表"

   

  Ta0(0, 0) = "10"

  Ta0(1, 1) = "注册名"

  Ta0(1, 2) = "8"

  Ta0(2, 1) = "密码"

  Ta0(2, 2) = "8"

  Ta0(3, 1) = "姓名"

  Ta0(3, 2) = "8"

  Ta0(4, 1) = "性别"

  Ta0(4, 2) = "4"

  Ta0(5, 1) = "单位"

  Ta0(5, 2) = "16"

  Ta0(6, 1) = "注册用途"

  Ta0(6, 2) = "11"

  Ta0(7, 1) = "电子信箱"

  Ta0(7, 2) = "10"

  Ta0(8, 1) = "批准"

  Ta0(8, 2) = "6"

  Ta0(9, 1) = "权限"

  Ta0(9, 2) = "6"

  Ta0(10, 1) = "取水用途"

  Ta0(10, 2) = "10"

  'Ta0(11, 1) = "fdsfd"

  'Ta0(11, 2) = "8"

  'Ta0(12, 1) = "123fdsfd"

  'Ta0(12, 2) = "1"

 

  form1.Uxue33.Tarray = tostring

  msgbox form1.Uxue33.Tarray

end sub

-->

</script>

 

<form method="POST" action="" name="form1">

 带参数打印示例<p>

 <OBJECT ID="Uxue33"

CLASSID="CLSID:8083B900-B2AD-11D5-9C19-0010D70B5752"

CODEBASE="gxue33/Gxue33.CAB#version=1,0,0,0" width="82" height="34">

<param name="_ExtentX" value="2170">

<param name="_ExtentY" value="900">

<param name="Tname" value="0">

<param name="Thead" value="0">

<param name="Tarray" value="0">

</OBJECT>

文件打印

ActiveX控件制作步骤同上，增加Thead属性（传递文件标题）和Tarray属性（传递文件内容，第一个分解元素为文件内容行数）。

代码：

Option Explicit

Dim pw, ph '纸宽和纸高的坐标

Dim px, py

Dim sp    '左边距

Dim table1  '正文开始高度

Dim tax(100, 2) As String

 

Private Function len1(str As String) As Integer

  Dim si, i As Integer

  Dim str1 As String

  si = 0

  For i = 1 To Len(str)

    str1 = Mid(str, i, 1)

    If Asc(str1) < 0 Then

      si = si + 2

    Else

      si = si + 1

    End If

  Next

  len1 = si

End Function

 

Private Function midx(taa) As String

  Dim ii As Integer

  Dim char1 As String

  char1 = Mid(taa, 1, 1)

  midx = ""

  ii = 1

  Do While char1 <> "{" And ii <= Len(taa) + 1

    midx = midx & char1

    ii = ii + 1

    char1 = Mid(taa, ii, 1)

  Loop

End Function

 

Private Sub toarray(tt)

  Dim ii As Integer

  Dim tt0

  tax(0, 0) = midx(tt)

 

  tt0 = Mid(tt, Len(tax(0, 0)) + 2, Len(tt))

  If tax(0, 0) > 0 Then

    For ii = 1 To tax(0, 0)

      tax(ii, 1) = midx(tt0)

      tt0 = Mid(tt0, Len(tax(ii, 1)) + 2, Len(tt0))

      tax(ii, 2) = midx(tt0)

      tt0 = Mid(tt0, Len(tax(ii, 2)) + 2, Len(tt0))

      'MsgBox tax(ii, 1)

    Next ii

  End If

End Sub

 

Private Sub printhead()

  Dim pp0, tpp, i

  Printer.CurrentX = 150: Printer.CurrentY = 30

  Printer.FontSize = 19: Printer.FontBold = True

  pp0 = 20 - (len1(Thead))

  tpp = ""

  For i = 1 To pp0

    tpp = tpp + " "

  Next i

  Printer.Print tpp & Thead

  table1 = 70

End Sub

 

Private Sub printbody()        '打印文字

  Dim i

  Printer.FontSize = 12: Printer.FontBold = False

  px = sp: py = table1

  For i = 1 To tax(0, 0)

    Printer.CurrentX = px: Printer.CurrentY = py

    Printer.Print tax(i, 1)

    py = py + 20

  Next i

End Sub

 

Private Sub printp()

  pw = 850: ph = 600

  sp = 40

  Printer.Scale (-sp, 0)-(pw, ph)

  printhead

  printbody

  Printer.EndDoc

End Sub

 

Private Sub Command1_Click()

  toarray (Tarray)

  printp

  MsgBox "打印完毕"

  Command1.Enabled = False

End Sub

 

网页程序为：

<script language="vbscript">

<!--

Option Explicit

Dim Ta0(100, 2)

 

Private Function len1(str)

  Dim si, i

  Dim str1

  si = 0

  For i = 1 To Len(str)

    str1 = Mid(str, i, 1)

    If Asc(str1) < 0 Then

      si = si + 2

    Else

      si = si + 1

    End If

  Next

  len1 = si

End Function

 

Private Function tostring()

  Dim ii

  tostring = Ta0(0, 0) & "{"

  For ii = 1 To Ta0(0, 0)

    If IsNull(Ta0(ii, 1)) Then Ta0(ii, 1) = ""

    tostring = tostring & Ta0(ii, 1) & "{"

    tostring = tostring & " {"

  Next

End Function

 

 

Private Sub  window_onload()

  form1.Uxue34.Thead = "取水许可证通知书"

 

  Ta0(0, 0) = 8

  Ta0(1, 1) = "北京市第9水厂："

  Ta0(2, 1) = "    你的取水许可证申请已经通过，请于近期前来我局领取取水许可证。"

  Ta0(3, 1) = " "

  Ta0(4, 1) = " "

  Ta0(5, 1) = "                                     北京市水利局水资源处"

  Ta0(6, 1) = " "

  Ta0(7, 1) = "电话：66666666           EMAIL ：ziyuan@jwcb.gov.cn"

  Ta0(8, 1) = "地址：海淀区翠微路甲3号  经办人：孟虹"

  'Ta0(9, 1) = ""

  'Ta0(10, 1) = ""

 

  form1.Uxue34.Tarray = tostring

  'MsgBox Uxue34.Tarray

End Sub

-->

</script>

<form method="POST" action="" name="form1">

 

<OBJECT ID="Uxue34"

CLASSID="CLSID:6502D511-B37F-11D5-9C19-0010D70B5752"

CODEBASE="Gxue34.CAB#version=1,0,0,0" width="82" height="34">

<param name="_ExtentX" value="2170">

<param name="_ExtentY" value="900">

<param name="Tarray" value="0">

<param name="Thead" value="0">

</OBJECT>

 

 

十九  编程实例

数据库冗余记录删除

'操作步骤：

'1.运行本程序，输入数据库组名、数据库名；

'2.输入判断冗余的主键的字段序号，第一个为0；

'3.输入表名；

'4.点击“删除”，可以在数据表中删除所有冗余的记录。

如图添加控件：

Option Explicit

Dim cnn As ADODB.Connection       '数据库连接

Dim Rst1 As ADODB.Recordset

Dim Rst2 As ADODB.Recordset

 

Private Sub Command1_Click()

  Dim i As Long    'delete records number

  Dim j As Long    'records series number

  Dim si As String

  Dim ts As String    'mast key value

  Dim ti As Integer   'mast key position

  Dim pi As Long      'progressBar value

  Dim ri As Long      'records number

  Dim rj As Long

 

  Set cnn = New ADODB.Connection

  si = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=" & _

  Text5.Text & ";Data Source=" & Text4.Text

  cnn.Open si

  Set Rst2 = New ADODB.Recordset

  si = "select * from " & Text3.Text

  Rst2.Open si, cnn, adOpenDynamic, adLockOptimistic

  ti = Text1.Text

 

  ri = 0

  While Not Rst2.EOF

    Rst2.MoveNext

    ri = ri + 1

  Wend

 

  i = 0

  j = 1

  pi = 0

  rj = 0

  ProgressBar1.Max = ri + 1

  ProgressBar1.Min = 0

 

  Rst2.MoveFirst

  While Not Rst2.EOF

    ts = Rst2.Fields(ti)

    If tfind(ts, ti, j, Rst2) Then

      Rst2.Delete

      i = i + 1

      j = j - 1

    End If

   

    Rst2.MoveNext

    j = j + 1

    rj = rj + 1

    ProgressBar1.Value = rj

  Wend

  MsgBox "一共删除了" & i & "条记录。"

End Sub

 

Function tfind(ii As String, tti As Integer, jj As Long, rst As ADODB.Recordset) As Boolean

  Dim bll As Boolean

  Dim i As Long

 

  tfind = False

  bll = True

  i = 0

 

  rst.MoveNext

  While Not rst.EOF And bll

    If rst.Fields(tti) = ii Then

      tfind = True

      bll = False

    End If

    rst.MoveNext

  Wend

 

  rst.MoveFirst

  For i = 0 To jj - 2

    rst.MoveNext

  Next i

End Function

 

Private Sub Command2_Click()

  End

End Sub

 

Private Sub Command3_Click()

  Dim si As String

  si = "数据库冗余数据删除工具,by xuewei,04/20/2003"

  frmSplash.Show

End Sub

 

Private Sub Form_Load()

  Text1.Text = 0

  Text3.Text = "biao2"

  Text4.Text = "temp"

  Text5.Text = "xue01"

End Sub