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
程序运行结果，打印一行数据。
