[日积月累]：高级 COM

sunwuliu

Microsoft Visual FoxPro 和高级 COM
高级教程  

--------------------------------------------------------------------------------

概述: 本文解释如何在 Microsoft Visual FoxPro 中以执行接口和事件绑定来利用 COM 功能. 早期版本的 Visual FoxPro 为 COM 服务程序提供早期绑定支持, 但只支持客户端的晚期绑定. 该版本的 Visual FoxPro 增加了客户端早期绑定. 本文讨论服务器端和客户端的相对于晚期绑定的早期绑定的内部工作方式. 另外, 还讨论了 COM 性能和如何使 COM 对象更加显露(more discoverable).

目录
简介
创建一个简单的 Visual FoxPro COM 服务程序
类别库
性能
使用 Visual Basic 作为客户
错误处理
接口
事件绑定
使用 Office XP Smart Tags
Visual FoxPro 回调设计

简介
COM 是开发来允许应用程序作为对象来处理的可以相互调用的对象. 对象关系可以具有多种形式. 最简单的形式是一个调用服务程序对象的客户对象. 更复杂的对象交互包括互相调用的点对点对象.

如果对象先前互相不知道, 则它们需要能描述另一个对象如何可以被自己调用. 对象的事件接口是描述这些回调接口的例子. 事件接口不是由软件对象开发者来实现而是由该对象的的客户端实现的. Microsoft ActiveX 控件以非常复杂的接口提供了一个 COM 对象示例. 位于控件和宿主两处, 这些接口让在宿主端的, 可以实现控件的事件接口的控件的行为就象它的本地控件一样成为可能. 这种结合在开发者手中是极其有用的.

本文以一个对极其有效的 Visual FoxPro COM 服务程序的简单的说明开始. 接着, 将说明类别库 (Type Libraries) 及你能如何读取它们来把一个 COM 对象展现出来, 以及性能和错误处理. 最后, 本文讨论接口和如何实现它们.

一但你可以实现接口, 你的能力开始进入一个事件绑定, 自定义插件和软件体系的新世界.

该讨论的另一个方面包括对象如何相互调用. Visual FoxPro 6.0 使得早期和晚期绑定的客户都可以调用 Visual FoxPro 6.0 服务程序, 但 Visual FoxPro 6.0 只能用晚期绑定来调用报务器. 当前版本的 Visual FoxPro 包括了早期绑定客户调用的能力.

创建一个简单的 Visual FoxPro COM 服务程序

用以下代码创建一个叫做 MYCLASS.PRG 的 PRG 文件:

* 该完整自包含程序将创建一个 COM 服务程序  
* 调用 "myserver.myclass"  
* 这会注销一个可能有的早期实例  
IF PROGRAM() != "MYCLASS"  
   ?"该文件必须名为 'myclass.prg'"  
   return
ENDIF
IF FILE("myclass.dll")  
   DECLARE integer DllUnregisterServer IN myclass.dll  
   DllUnregisterServer()
   CLEAR DLLS  
ENDIF
BUILD PROJECT myserver FROM myclass  
BUILD DLL myserver from myserver recomp  

* 现在测试该 COM 服务程序:  
ox = CreateObject("myserver.myclass")                && 创建服务程序对象  
ox.mydocmd("USE home(1)+'samples\data\customer'")    && 使用一个表  
?ox.myeval("RECCOUNT()")                             && 得到记录数  

DEFINE CLASS myclass AS session OLEPUBLIC  
   PROCEDURE MyDoCmd(cCmd as String) as Variant helpstring "执行一个 VFP 命令"  
      &cCmd              && 只当参数是一个 Fox 命令时执行它  
   FUNCTION MyEval(cExpr as String) helpstring "对一个 VFP 表达式求值"  
      RETURN &cExpr      && 象一个 Fox 表达式一样对它进行求值  
   FUNCTION Error(nError, cMethod, nLine)  
      COMreturnerror(cMethod+'  错误号#='+str(nError,5)+;  
         '  行号='+str(nline,6)+' '+message(),_VFP.ServerName)  
      && 该行绝不会被执行  
ENDDEFINE
一个这样的结构的程序可以创建为 COM 服务程序且不会影响注册表. 注意类定义前的代码只在联编时执行. 联编一个 COM 服务程序会在注册表中自动注册它. 重新联编服务程序时首先会反注册它. 但是, 反注册信息是保存在 PJX 文件中. 如果 PJX 被删除并重新联编, 则在联编一个新项目时注册表中的入口没有被移去.

现在, 你已经创建了你的第一个服务程序. 在 Visual FoxPro 中创建一个服务程序的同时也会创建一个类别库并在系统注册表中写入相关的类别库和文件位置的信息. 创建的过程创建一个名为 myserver.vbr 的文件, 它显示了在服务程序被注册时哪一个注册表键值被修改了.

注意上述代码中使用的 SESSION 基类是 Visual FoxPro 6.0 SP3 新增加的. 它是一个非常轻量级的非可视的且只有 DataSession 属性来使用不同数据工作期的基类. 在创建 COM 服务程序时, FORM 基类也有一个 DataSession 属性, 但它还有许多其它与 COM 服务程序不相关的属性. 另外, 这些属性在默认情况下, 也会写到类别库中, 除非你使它们是受保护的或隐藏的.
类别库

类别库是一个独立的或作为一个 EXE 或 DLL 内部嵌入的资源的文件. 这种与语言无关的发布 COM 对象的接口, 属性和方法的方法可以包含帮助串, 帮助上下文相关 ID, 参数名和成员名 (属性和方法). 如果类别库没有嵌入到 EXE 或 DLL 中, 它的文件扩展名一般是 TLB 或 OLB.

Visual FoxPro 6.0 生成的类别库包含 OLE Public 方法的方法和参数名. 如果在 VCX 中的类的 Description 中有一个描述, 则该描述被作为帮助串放入类别库中.

可以用多种工具来查看类别库. 如, 用 Excel 或 Word 中的对象浏览器, Visual FoxPro 的类浏览器或 Visual C++ 的 OLE Viewer 来查看类别库. 你可以看到类别库可以包含完整的服务程序应用程序的对象模型甚至更多.

在使用一些工具查看类别库时, 要注意到服务程序不能被重建, 因为类别库不能被重写. 另外, 如果一个客户端实例化了服务程序, 它不能被重建. 使用一个过去创建的 DLL 或 EXE 的拷贝是避免该问题的一种办法.

读一个类别库
随同 Visual Studio 分发的类别库阅读工具是 TLBINF32.DLL. TLBINF32.DLL 设计来为多种产品使用, 因此它被写成一个 COM 服务程序. 以下是一些从先前创建的示例服务程序中读取类别库的示例代码.

clear
PUBLIC otlb
otli=NEWOBJECT('tli.tliapplication')
otlb=otli.TypeLibInfoFromFile("myserver.tlb")
*otlb=otli.TypeLibInfoFromFile("tlbinf32.dll")
*otlb=otli.TypeLibInfoFromFile("c:\program files\microsoft office\office\excel9.olb")
?"CoClasses:"
FOR each oCoClass in otlb.CoClasses
   ?"  ",oCoClass.name
   * now each interface associated with this CoClass
   for each oInterface in oCoClass.Interfaces
      ?"     ",oInterface.name
   endfor
endfor

?
?"Interfaces"

FOR each oInterface in otlb.Interfaces
   ?"  ",oInterface.name
ENDFOR
?
?"Interface Members for 1st interface"
FOR each oMember IN otlb.Interfaces(1).Members
   ?"  ", oMember.name
   FOR each oParm in oMember.Parameters
      ?"             ",oParm.name
   ENDFOR
ENDFOR
这些代码首先创建一个 TLB 读取工具的实例然后调用 TypeLibInfoFromFile 方法来载入一个类别库. 库中的项被描述为不同的集合, 它们可以被相当方便地在 Visual FoxPro 用 FOR EACH 语句来操作.

Interface 集合是类别库中的接口描述的集合. 这些接口可以被服务程序或客户程序实现, 如, 在事件的情况下.

CoClass 集合描述可以被客户程序创建的 COM 对象. 默认的被 CoClass 实现的接口是 shown, 连同一个可选的 Event Source 接口一起.

除默认的 CoClass 和 Event 接口外的接口也将描述. 方法是一个客户可以通过一个方法调用来获得这些其它接口. 例如, 可以从一个叫做 GetCell 的方法返回一个 ICell 接口.

也可以在类别库中定义常量. 如, 要从一个 Excel 类别库中得 xlMaximized 这样的常量, 可以检查 otlb.Constants 集合.

一种学习如何使用 TLBINF32.DLL 工具的方法是亲自使用它. 在使用该工具时它将向你展示使用该工具时有用的属性, 方法, 参数等.
性能

性能对于许多人来说意味着许多东西. 在上下文相关的软件和 COM 对象中, 性能意味着更快地得到结果. COM 让一个软件模块与另一个软件模块通信, 因此改进 COM 的将使通信达到更高的性能.

例如, 考虑以下代码:

ox=CreateObject("excel.application")
start = seconds()   
ox.workbooks.add
SET EXCLUSIVE OFF   
USE HOME()+'samples\data\customer'   
ox.visible=1
FOR i= 1 TO RECCOUNT()   
   FOR J = 1 TO FCOUNT()   
      ox.Activesheet.cells(i,j).value = EVAL(FIELD(j))   
   NEXT
   SKIP
NEXT
ox.Workbooks(1).Close(0)   && 关闭工作簿, 放弃修改   
ox=0   && 释放 Excel   
?seconds() - start   
代码用一个表中的值来填充一个 Excel 工作表; 它大概要在作者的机器上要花 30 秒时间来处理 92 条记录(哈哈哈哈，与我的电脑差不多嘛,在我的机器上 30.014 秒).

在试着改进性能时, 必须记住发生了什么并试着指出瓶颈所在.

让工作表在填充完成后才显示而不是预先显示它, 可以减少一些时间. 让 Excel 不是最大化的可以稍稍加快一些速度.

注意大多数时间是花在执行分配单元格的值的单行代码上. 你可以修改该行为以下代码来移去所有对 COM 的调用
oa= EVAL(FIELD(j))
这明显地改变了代码的意图 但使得双循环只花费一秒钟. 这说明 29 秒钟是花费在该行的对 ox.Activesheet.cells 求值的部分.

进一步分析该行, Visual FoxPro 对 ox.Activesheet 进行求值, 并将结果放在一个临时值中. 然后, 该临时值被废弃来获得单元格集合. 表单式中的各个 "." 放到临时值的结果被获取然后被废弃以获得一个新值.

各个 "." 点操作符被废弃事实上是一个 COM 方法对一个返回值的 Excel 方法的反复调用. 首先, IApplication.ActiveSheet 方法被调用, 它返回给 Visual FoxPro 一个对活动的工作簿的临时引用. 然后, 该对象的引用被用于获得单元格集合. 然后, 集合被废弃并使用单元格的索引作为参数来获得一个单一单元格的对象引用. 然后, 该单元格的 value 属性被根本一修正新值 (另一个 COM 反复调用). 这造成了四个重复调用.

获得一个 ox.Activesheet 对象引用前双嵌套循环和使用缓存引用来代替可提高 50 % 的性能.

oa = ox.Activesheet && 获得一个对象引用
FOR i= 1 TO RECCOUNT()
   FOR J = 1 TO FCOUNT()
      oa.cells(i,j).value = EVAL(FIELD(j))
   NEXT
   SKIP
NEXT
因为 Activesheet 在双循环中并没有改变, 你可以在循环前得到一个它的对象引用并缓存它到一个变量. 这减速少了一个反复调用, 使反复调用的总数减少为三个.

反复调用的数量减少了 25 %, 但时间减少了 50 %. 被移去的反复调用与减少的时间是不成比例的. 创建和释放一些临时变量所花费的时间, 一些时间花费在服务程序执行代码上, 其它的因素是非线性的.

注意 前面的代码并非必须使用 Activesheet. 单元格集合也可以从 Iapplication 接口中找到. 在这里使用它们只是为了说明问题.

使用 Visual Basic 作为客户程序

你可以用 Visual Basic 作为客户程序来完成相似的任务.

要使用 Visual Basic 作为一个客户程序

启动 Excel.
选择工具, 选择宏, 选择宏, 并给它取一个名字为 t.
选择创建.
选择工具, 选择引用, 并添加 myserver 类别库到引用中.
这样可以使用 myserver 类别库的信息在宏中被使用.

粘贴以下代码:

Sub t()
Dim ox As New myserver.myclass
ox.mydocmd ("set exclusive off")
ox.mydocmd ("use d:\fox70\test\customer")
n = ox.MyEval("reccount()")
nflds = ox.MyEval("fcount()")
nsecs = ox.MyEval("seconds()")
For i = 1 To n
   For j = 1 To nflds
      cc = "evaluate(field(" & j & "))"
      Application.Sheets(1).Cells(i, j).Value = ox.MyEval(cc)
   Next
   ox.mydocmd ("skip")
Next
MsgBox (ox.MyEval("seconds()") - nsecs)
End Sub
错误处理

试着显示用户界面的服务程序造成了一个为什么在 COM 服务程序中的错误处理是非常重的一个理由, 特别是在 DLL 服务程序中. 如果客户程序调用服务程序中的一个方法造成一些类型的错误, 如文件未找到或拒绝访问, 只在服务程序中显示一个指明错误的提示信息将不是好方法. 开发者可以用 OLE Public 类的 Error 方法来更好地处理这样的错误. Visual FoxPro 6.0 的一个新函数 COMReturnError, 将致使一个 COM Error 对象被创建并返回到 COM 客户程序. 它使用两个参数: Source 和 Description. 你可以在这些参数中放置任何你想放入的串. 以下示例方法可以粘贴来放到先前的 myserver 示例程序中.

FUNCTION Error(nError, cMethod, nLine)
COMreturnerror(cMethod+' 错误号#='+str(nError,5)+' 行号='+str(nline,6)+'
'+message(),_VFP.ServerName)
&& 该行决不会被执行

你可以用以下命令来调用 MyDocmd 方法来调用这个 error 方法:

ox = CreateObject("myserver.myclass") && 创建服务程序对象
?ox.mydocmd("非法命令") && 致使一个错误发生
服务程序中发生的错误被 MyClass::Error 方法捕捉, 它会造成服务程序终止处理并返回带有 Source 和 Description 的 COM Error 对象.

?aerror(myarray)
list memo like myarray
MYARRAY Pub A
( 1, 1) N 1429 ( 1429.00000000)
( 1, 2) C "OLE IDispatch exception code 0 from mydocmd
err#= 16 line= 2 Unrecognized command v
erb.: c:\fox\test\myserver.exe.."
( 1, 3) C "c:\fox\test\myserver.exe"
( 1, 4) C "mydocmd err#= 16 line= 2 Unrecognized
command verb."
( 1, 5) C ""
( 1, 6) N 0 ( 0.00000000)
( 1, 7) N 0 ( 0.00000000)
接口

在运行上, 一个 COM 接口可以认为是一个指向函数地址表的一个指针. 该表有时被称为 vtable, 或虚拟函数表. 接口定义包括了表的入口数, 及相关方法名和表索引, 和各方法调用的函数信号. 信号由参数数量, 参数类型, 和返回值组成.

所有 COM 接口继承自 IUnknown. 这意味着每一个 COM 接口中的 vtable 的最初的三个入口定义为服务程序的执行地址 IUnkown::QueryInterface, IUnkown::AddRef, 和 IUnkown::Release.

当一个接口继承自另一个接口时, 接口的 vtable 继承自第一个接口的 vtable.

双接口是继承自 IDispatch 接口的 COM 接口. IDispatch 接口只有四个方法: GetTypeInfoCount, GetTypeInfo, GetIDsOfNames 和 Invoke. 因此, 最初的七个接口也定义在一个 IDispatch 接口中并且任何其它的接口继承自 IDispatch.

对于先前创建的 earlier, 双接口 IMyClass 看起来如下:

IMyClass
QueryInterface(QI params) (from IUnknown)
Addref (from IUnknown)
Release (from IUnknown)
GetTypeInfoCount() (from IDispatch)
GetTypeInfo() (from IDispatch)
GetIDsOfNames() (from IDispatch)
Invoke() (from IDispatch)
MyDoCmd(cCmd) (from IMyClass)
MyEval(cExpr) (from IMyClass)
假定客户程序想要调用服务程序上的双接口 IApplication 的 Activesheet 方法. 实际调用可能以两种方式进行: 早期和晚期绑定. 早期绑定有时被称为 VTtable 绑定, 因为它的意思是客户程序以直接在 vtable 中查找 Activesheet 地址的方式直接调用服务程序. 该函数地址是 vtable 中的一个比七大的入口. 该函数地址索引是在编译时硬编码到客户程序调用中并且是已经知道的早期绑定. 如果以后的服务程序版本改变了 vtable 顺序, 则早期绑定客户程序将是错误的.

晚期绑定通过 IDispatch 接口调用. 客户程序用串 Activesheet 调用 IDispatch::GetIDsOfNames 来获得该函数的函数 ID. (以后的客户程序调用可以使用该保存的函数 ID.) 客户程序然后封装所有的 Activesheet 参数到一个单个的 DISPPARAMS 结构中, 并且 IDispatch::Invoke 函数被用该函数 ID 和 DISPPARAMS 作为参数调用. 在服务程序端的 IDispatch::Invoke 的执行分解 DISPPARAMS 结构, 进行实际的 Activesheet 调用, 得到返回值, 并将其传递回客户程序.

因为晚期绑定没有硬编码被调用方法的函数索引, 客户程序不必知道被调用方法在编译时的函数索引也可以运行, 即使一个新版本的服务程序重新安排了 vtable 顺序或改变了方法的签名. 但是, 客户程序端的参数封装和客户程序端的解压增加了方法调用的执行时间, 这种情况在早期绑定中是不存在的.

实现接口
实现接口是什么意思呢? 它意味着你检查一个对象的属性, 事件和方法并创建一个新的,具有完全相同的属性, 事件和方法的对象. 这包括所有参数, 参数类型及返回值. 换句话说, 如果一个对象知道如何用一个特定接口调用另一个对象, 则它也知道如何调用任何实现了该特定接口的对象.

实现一个接口允许客户程序在该接口中的每一个方法都可以被调用. 这意味着如果有一个叫做 Foo 的方法

Foo(Parm1 as int, Parm2 as string, parm3 as variant @) as int

则同样的方法签名必须在对象中存在.

在以下的 ADO 示例中, 例如, 如果一个参数被从方法签名中移去, 运行该代码将产生以下信息:

"类不能被实例化因为成员 'RECORDSETEVENTS_WillChangeField' 有着错误的参数数"

相似, 移去一个方法产生另一个错误信息.

正如前面所提及, 接口是在类别库中描述的. Visual FoxPro 7.0 对象浏览器 (在工具菜单中) 允许你查看一个类别库. 如果你从其中拖动一个接口到一个已经在 Visual FoxPro 中打开的 PRG 文件, 则对象浏览器将产生实现接口所必需的方法签名.

事件绑定

执行接口的能力使得一些我们感兴趣的 Microsoft Office 功能变为可能. 该示例执行 Microsoft Outlook, Excel 和 Word 的事件. 正如你从方法名称中所看到的一样, 各个 Office 应用程序提供不同的接口. 当前版本的 Visual FoxPro 的新的 EventBinding 命令让开发者可以绑定一个执行接口到 COM 对象的作为事件源和发布者的 Visual FoxPro 类.

这种事件称为紧密结合事件. 客户程序和服务程序必须相似的相互知道对方, 并且对象间是一一相符的. 一个新的对象模型事件接口称为松散结合事件, 在此情况下一个对象可以发布事件, 且另一个对象可以认同这些事件.

Clear
Clear All   
Public ox As Excel.Application, ;   
ow As Word.Application, ;   
oOutlook As Outlook.Application   

oOutlookEvents= Newobject('OutlookEvents')   

oOutlook = Newobject("Outlook.Application")   
oOutlookEvents.oo = oOutlook   
? "Outlook",Eventhandler( oOutlook, oOutlookEvents)   

oWordEvents = Newobject("WordEvents")   
ow = Newobject("word.application")   
oWordEvents.ow = ow   
?"Word",Eventhandler(ow,oWordEvents)
ow.Visible = .T.   
ow.Activate
ow.Documents.Add

oExcelEvents = Newobject("ExcelEvents")   
oex = Newobject("excel.application")   
oex.Workbooks.Add
?"Excel",Eventhandler(oex, oExcelEvents)   
oex.Visible = .T.   

_Screen.WindowState= 1   

Define Class OutlookEvents As Session OlePublic   
Implements ApplicationEvents In Outlook.Application   
oo = .Null.   
Procedure ApplicationEvents_ItemSend(Item As VARIANT, ;   
CANCEL As LOGICAL) As VOID   
?Program()
m.item.Body=Strtran(m.item.Body,"good","bad") + ;   
CHR(13)+Chr(10)+Transform(Datetime())+" Fox was here!"   
*      if Recipients fails, it could be outlook security   
*      m.item.Recipients.Add("anyone@anywhere.com")   
Procedure ApplicationEvents_NewMail() As VOID   
?Program()
Procedure ApplicationEvents_Reminder(Item As VARIANT) As VOID   
?Program()
Procedure ApplicationEvents_OptionsPagesAdd(Pages As VARIANT) As VOID   
?Program()
Procedure ApplicationEvents_Startup() As VOID   
?Program()
Procedure ApplicationEvents_Quit() As VOID   
?Program()
Procedure Destroy   
?Program()
If !Isnull(This.oo)   
?Eventhandler(This.oo,This,.T.)
Endif
Enddefine

Define Class WordEvents As Custom   
Implements applicationevents2 In "word.application"   
ow = .Null.   
Procedure applicationevents2_startup()   
?Program()
Procedure applicationevents2_quit   
?Program()
Procedure applicationevents2_DocumentBeforeClose(Cancel,Doc)   
?Program()
Procedure DocumentBeforeClose(Cancel,Doc)   
?Program()
Procedure applicationevents2_DocumentBeforePrint(Cancel,Doc)   
?Program()
Procedure applicationevents2_DocumentBeforeSave(Doc,SaveAsUI,Cancel)   
?Program()
Procedure applicationevents2_DocumentChange   
?Program()
Procedure applicationevents2_DocumentOpen(Doc)   
?Program()
Procedure applicationevents2_NewDocument(Doc)   
?Program()
Procedure applicationevents2_WindowActivate(Doc,Wn)   
?Program()
Procedure applicationevents2_WindowBeforeDoubleClick(Sel,Cancel)   
?Program()
Procedure applicationevents2_WindowBeforeRightClick(Sel,Cancel)   
?Program()
Procedure applicationevents2_WindowDeactivate(Doc,Wn)   
?Program()
Procedure applicationevents2_WindowSelectionChange(Sel)   
?Program(),sel.Text
If sel.Start < sel.End   
sel.InsertAfter("Fox!")
*!*         mtmp = sel.text   
*!*         sel.text=STRTRAN(mtmp,"good","Great!")   
Endif
Procedure Destroy   
?Program()
If !Isnull(This.ow)   
?Eventhandler(This.ow,This,.T.)
Endif
Enddefine

Define Class ExcelEvents As Session OlePublic   
Implements AppEvents In "excel.application"   
Procedure AppEvents_NewWorkbook(Wb As VARIANT) As VOID   
?Program()
Procedure AppEvents_SheetSelectionChange(Sh As VARIANT, ;   
Target As VARIANT) As VOID   
Local mtmp,mcell   
mcell = m.target.Cells(1,1)   
If !Isnull(mcell)   
mtmp = m.target.Cells(1,1).Value   
?Program(),Vartype(mtmp)
Do Case   
Case Isnull(mtmp)   
*         m.target.Cells(1,1).Value  = "Fox is great"   
Case Vartype(mtmp)='C'   
m.target.Cells(1,1).Value = ;   
STRTRAN(mtmp,"good","great!")
Case Vartype(mtmp)='N'   
m.target.Cells(1,1).Value = mtmp + 1   
Endcase
Endif
Procedure AppEvents_SheetBeforeDoubleClick(Sh As VARIANT, ;   
Target As VARIANT, Cancel As LOGICAL) As VOID   
?Program()
Procedure AppEvents_SheetBeforeRightClick(Sh As VARIANT, ;   
Target As VARIANT, Cancel As LOGICAL) As VOID   
?Program()
Procedure AppEvents_SheetActivate(Sh As VARIANT) As VOID   
?Program()
Procedure AppEvents_SheetDeactivate(Sh As VARIANT) As VOID   
?Program()
Procedure AppEvents_SheetCalculate(Sh As VARIANT) As VOID   
?Program()
Procedure AppEvents_SheetChange(Sh As VARIANT, Target As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookOpen(Wb As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookActivate(Wb As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookDeactivate(Wb As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookBeforeClose(Wb As VARIANT, ;   
Cancel As LOGICAL) As VOID   
?Program()
Procedure AppEvents_WorkbookBeforeSave(Wb As VARIANT, ;   
SaveAsUI As LOGICAL, Cancel As LOGICAL) As VOID   
?Program()
Procedure AppEvents_WorkbookBeforePrint(Wb As VARIANT, ;   
Cancel As LOGICAL) As VOID   
?Program()
Procedure AppEvents_WorkbookNewSheet(Wb As VARIANT, ;   
Sh As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookAddinInstall(Wb As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookAddinUninstall(Wb As VARIANT) As VOID   
?Program()
Procedure AppEvents_WindowResize(Wb As VARIANT, Wn As VARIANT) As VOID   
?Program()
Procedure AppEvents_WindowActivate(Wb As VARIANT, Wn As VARIANT) As VOID   
?Program()
Procedure AppEvents_WindowDeactivate(Wb As VARIANT, Wn As VARIANT) As VOID   
?Program()
Procedure AppEvents_SheetFollowHyperlink(Sh As VARIANT, ;   
Target As VARIANT) As VOID   
?Program()
Procedure AppEvents_SheetPivotTableUpdate(Sh As VARIANT, ;   
Target As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookPivotTableCloseConnection(Sh As VARIANT, ;   
Target As VARIANT) As VOID   
?Program()
Procedure AppEvents_WorkbookPivotTableOpenConnection(Sh As VARIANT, ;   
Target As VARIANT) As VOID   
?Program()
Enddefine
以下是一个实现 ADO 事件接口的示例. 在这样的情况下, 用户没有与应用程序交互, 致使事件出现象上面的 Office 示例. 在这里, 用户直接用方法调用来直接调用 ADO, 并且 ADO 用它自己的事件接口回调到客户程序.
clear
CLEAR all   
local ox as adodb.recordset   
local oc as ADODB.Connection   
oe = NEWOBJECT("myclass")   
oe2 = NEWOBJECT("myclass")   

oc=NEWOBJECT("adodb.connection")
connstr = "Driver={Microsoft Visual FoxPro Driver};UID=;PWD=;SourceDB=" + ;   
   HOME(1)+"samples\data\testdata.dbc" + ;   
    ";SourceType=DBC;Exclusive=No;BackgroundFetch=No;Collate=Machine;"
*
oc.ConnectionString= connstr   
oc.Open
ox = oc.Execute("select * from customer")   
* Now enable event handling   
?EVENTHANDLER(ox,oe)
?EVENTHANDLER(ox,oe2)

?
?PADR(ox.Fields(0).Value,20)

?EVENTHANDLER(ox,oe2,.f.) && Turn off 2nd obj event handling   
ox.MoveNext
?PADR(ox.Fields(0).Value,20)
ox.MoveNext
CLEAR all   
retu
for i = 0 to ox.Fields.Count-1   
*   ?PADR(ox.Fields(i).Name,20)   
*   ?ox.Fields.value   
endfor

DEFINE CLASS myclass AS session   
   implements RecordsetEvents IN "adodb.recordset"   
*  implements RecordsetEvents IN ;   
*"C:\PROGRAM FILES\COMMON FILES\SYSTEM\ADO\MSADO15.DLL"   
   PROCEDURE Recordsetevents_WillChangeField(cFields AS Number @, ;   
         Fields AS VARIANT @, adStatus AS VARIANT @, ;   
         pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_FieldChangeComplete(;   
         cFields AS Number @, ;   
         Fields AS VARIANT @, pError AS VARIANT @, ;   
         adStatus AS VARIANT @, pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_WillChangeRecord(adReason AS VARIANT @, ;   
         cRecords AS Number @, adStatus AS VARIANT @, ;   
         pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_RecordChangeComplete(adReason AS VARIANT @, ;   
         cRecords AS Number @, pError AS VARIANT @, ;   
         adStatus AS VARIANT @, pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_WillChangeRecordset(adReason AS VARIANT @, ;   
         adStatus AS VARIANT @, pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
      ?adreason,adstatus,precordset.recordcount
   PROCEDURE Recordsetevents_RecordsetChangeComplete(;   
         adReason AS VARIANT @, ;   
         pError AS VARIANT @, adStatus AS VARIANT @, ;   
         pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_WillMove(adReason AS VARIANT @, ;   
         adStatus AS VARIANT @, pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_MoveComplete(adReason AS VARIANT @, ;   
         pError AS VARIANT @, adStatus AS VARIANT @, ;   
         pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_EndOfRecordset(fMoreData AS LOGICAL @, ;   
         adStatus AS VARIANT @, pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_FetchProgress(Progress AS Number @, ;   
         MaxProgress AS Number @, adStatus AS VARIANT @, ;   
         pRecordset AS VARIANT @) AS Void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
   PROCEDURE Recordsetevents_FetchComplete(pError AS VARIANT @, ;   
         adStatus AS VARIANT @, pRecordset AS VARIANT @) AS void   
      ? " "+program() + ' ' + TRANSFORM(DATETIME())   
ENDDEFINE
使用 Office XP Smart Tags
Office XP 包括一个称为 Smart Tags 的能力. 作为一个在公司上班的典型的知识工人, 她可能使用多个计算机应用程序并在各程序中使用相似的主题. 如, 公司可能有一个客户列表, 而且她可能需要 e-mail, 创建文档或电子表格数据, 甚至查看关于客户的网页. 假定在此时, 她正在写一个关于客户 ALFKI 的 e-mail, 并且她必须知道客户的电话号码或信用卡限额. 典型地, 这意味着启动或切换到另一个维护这些信息的应用程序, 查找 ALFKI, 然后转录数据到 e-mail 中.

Smart Tags 技术是一种多个应用程序可以认可文本内的串 (tags) 并可选地向用户提供一种调用菜单以给出有用的信息或执行有用的任务的方法. 一个 ALFKI 的 smart tag 可能不仅提供信用卡限额和地址也可能提供可选的转到客户的网站, 添加到一个事务日记, 启动另一上应用程序, 或甚至拨号电话. 用户甚至可以临时地打入 ALFKI 到任何当前正使用的应用程序, 查找信息, 然后在应用程序中删除该串.

以下是一个 Smart Tags 技术示例, 它识别示例 customer 表中的该客户 ID. Smart Tag 动作动词是表中的字段, 加上一个访问客户网站. 如果应用程序是 Word, 则字段动词将插入字段到 Word 文档. 对于 Excel, 字段值将插入到临近的列中, 且列的宽度也将根据插入的字段宽度调整. 对于 IE, 将显示一个消息框 (注意尽管它是一个 Visual FoxPro DLL, 也可以用 Declare DLL 来调用 MessageBox).

一个 Smart Tag 只是必须在注册表中适当的地方注册它的 ProgID. Smart Tag SDK (可从 Microsoft 网站下载) 给出了关于 Smart Tags 的更多详细资料.

一个 Smart Tag 必须实现两个接口: ISmartTagRecognizer 和 ISmartTagAction. 第一个扫描一个串并在一个 tag 被识别时回调一个分解后的对象. 第二个接口描述可能 的动作和实际执行的动作.

注意 打开任何一个 Office 应用程序将打开一个你的 DLL 的实例; 因此在你关闭应用程序前, 你将不能修改该 DLL.
Logit 方法写到一个 log 文件, 这是一种学习关于接口是如何工作和调试任何代码的有用的技术. 使用一个自动刷新文件改变的编辑器来显示 log 是有用的.

Clear All
Clear
Set Excl Off   
?Program()

*Smart tags in Office XP. Just change the DATAPATH,STAGPATH if necessary   
If Program() != "STAG"   
?"this file MUST BE NAMED 'stag.prg'"   
Endif
#Define STNAME  "MynameSpaceURI#MyLocalName"   
#Define DATAPATH Home(1)+"samples\data\"   
#Define STAGPATH "C:\Program Files\Common Files\Microsoft Shared\Smart Tag\mstag.tlb"   
If .T.   
If File("stag.dll")   
Declare Integer DllUnregisterServer In stag.Dll   
DllUnregisterServer()
Clear Dlls   
Endif
Build Project stag From stag   
Build Mtdll stag From stag recomp   
Strtofile("","d:\t.txt")    && null log file   
Endif

#Define HKEY_CURRENT_USER  -2147483647  && BITSET(0,31)+1   
oFoxReg=Newobject("foxreg", Home(1)+"FFC\registry")   
oFoxReg.OpenKey("Software\Microsoft\Office\Common\Smart Tag\Actions\stag.MyStag", ;   
HKEY_CURRENT_USER, .T.)   
oFoxReg.OpenKey(;
"Software\Microsoft\Office\Common\Smart Tag\Recognizers\stag.MyStag", ;   
HKEY_CURRENT_USER, .T.)   

Define Class MyStag As Session OlePublic   
Implements ISmartTagRecognizer In STAGPATH   
Implements ISmartTagAction In STAGPATH   
Procedure ISmartTagRecognizer_get_ProgId() As String   
logit()
Return   "stag.MyStag"   
Procedure ISmartTagRecognizer_get_Name(LocaleID As Integer) As String   
logit()
Return "VFP NorthWind Customer Recognizer"   
Procedure ISmartTagRecognizer_get_Desc(LocaleID As Integer) As String   
logit()
Return "VFP NorthWind Customer ID Recognizer"   
Procedure ISmartTagRecognizer_get_SmartTagCount() As Integer   
logit()
Return 1   
Procedure ISmartTagRecognizer_get_SmartTagName(;   
SmartTagID As Integer) As String   
logit()
If SmartTagID = 1   
Return STNAME   
Endif
Return ""   
Procedure ISmartTagRecognizer_get_SmartTagDownloadURL(;   
SmartTagID As Integer) As String   
logit()
Return ""   
Procedure ISmartTagRecognizer_Recognize(cText As String, ;   
DataType As Integer, ;   
LocaleID As Integer, RecognizerSite As VARIANT) As VOID   
logit(ctext+' '+Transform(Len(CTEXT)))   
Local i,  mat,cWord,propbag   
i = 1   
Do While i <= Len(cText)   
If Isalpha(Substr(cText,i))   
mst = i   
Do While i <= Len(cText) And ;   
(Isalpha(Substr(cText,i)) Or ;   
ISDIGIT(Substr(cText,i)))
i=i+1
Enddo
If mst # i   
cWord = Substr(cText,mst,i-mst)   
If Seek(cWord,"Customer")   
* Ask for a property bag   
propbag = ;   
RecognizerSite.GetNewPropertyBag()
* Commit the smart tag   
propbag.Write("test","value")
propbag.Write("test2","value2")
RecognizerSite.CommitSmartTag(STNAME, ;   
mst, Len(cWord), propbag)   
propbag=.Null.
Endif
Endif
Endif
i=i+1
Enddo
***********************
Procedure ISmartTagAction_get_ProgId() As String   
logit()
Return "stag.MyStag"   
Procedure ISmartTagAction_get_Name(LocaleID As Integer) As String   
logit()
Return "Customer Actions"   
Procedure ISmartTagAction_get_Desc(LocaleID As Integer) As String   
logit()
Return  "Provides actions for VFP Customer data"   
Procedure ISmartTagAction_get_SmartTagCount() As Integer   
logit()
Return 1   
Procedure ISmartTagAction_get_SmartTagName(SmartTagID As Integer) As String   
logit()
If SmartTagID = 1   
Return STNAME   
Endif
Return ""   
Procedure ISmartTagAction_get_SmartTagCaption(SmartTagID As Integer, ;   
LocaleID As Integer) As String   
logit(Transform(SmartTagID ))   
Return  "Customer Lookup"   
Procedure ISmartTagAction_get_VerbCount(SmartTagName As String) As Integer   
logit(SmartTagName )   
If SmartTagName = STNAME   
Return Fcount()+1   
Endif
Return 0   
Procedure ISmartTagAction_get_VerbID(SmartTagName As String, ;   
VerbIndex As Integer) As Integer   
logit(SmartTagName +', '+ Transform(VerbIndex ))   
Return VerbIndex   
Procedure ISmartTagAction_get_VerbCaptionFromID(VerbID As Integer, ;   
_ApplicationName As String, LocaleID As Integer) As String   
logit(Transform(VerbID )+' '+_ApplicationName +;   
' '+Transform(LocaleID))   
If VerbId <= Fcount()   
Return "View "+Field(VerbID)   
Endif
Return "Visit customer Web site"   
Procedure ISmartTagAction_get_VerbNameFromID(VerbID As Integer) As String   
logit(Transform(VerbID))
If VerbId <= Fcount()   
Return Field(VerbID)   
Endif
Return "Visit Web site"   
Procedure ISmartTagAction_InvokeVerb(VerbID As Integer, ;   
cApplicationName As String, ;   
Target As VARIANT, oProperties As VARIANT, ;   
cText As String, XML As String) As VOID   
logit(Transform(VerbID )+' '+cApplicationName +' '+cText+' ';   
+XML+' '+Transform(oProperties.Count))   
Local i,cProp   
oProperties.Write("iitest","iivalue")
oProperties.Write("iitest2","iivalue2")
For i = 1 To oProperties.Count   
cProp = oProperties.keyfromindex(i-1)   
logit(cProp)
logit(oProperties.Read(cprop))
Endfor
Local fExcel,fWord   
Do Case   
Case capplicationname = "Excel.Application.10"   
fExcel = .T.   
logit(m.target.cells[1,1].Value)
Case capplicationname = "Word.Application.10"   
fWord = .T.   
*         logit(m.target.range   
Endcase
If verbId > Fcount()   
Local oie As internetexplorer.Application   
oie = Newobject("internetexplorer.application")   
oie.navigate2("localhost/"+ctext+".html")
oie.Visible=1
Else
If Seek(cText,"customer")   
Do Case   
Case fExcel   
Target.cells[1,2].Value = ;   
Alltrim(Transform(Evaluate(Field(VerbID))))
Target.Columns(2).ColumnWidth = 25   
Case fWord   
Target.insertAfter(' '+;   
Alltrim(Transform(Evaluate(Field(VerbID)))))
Otherwise
Declare Integer Messagebox In WIN32API ;   
as msgbox ;   
Integer,String,String, Integer   
msgbox(0,;
ALLTRIM(Transform(Evaluate(Field(VerbID)))), ;   
ctext+"="+company,0)
Endcase
Else
logit("not found")   
Endif
Endif
Procedure Init   
logit()
Set Exact On   
Set Exclusive Off   
Set Path To DATAPATH   
Use customer Order cust_id Shared   
Procedure Destroy   
logit()
Procedure MyDoCmd(cCmd As String)   
&cCmd
Procedure MyEval(cExp As String)   
Return &cExp   
Procedure Error(nError, cMethod, nLine)   
logit(Transform(nError)+' '+Transform(nLine)+' '+Message())   
Enddefine
#If .F.   
Define Class STagAction As StagRecognizer OlePublic   
Procedure Error(nError, cMethod, nLine)   
logit(Program()+" "+Transform(nError)+' '+Transform(nLine)+'   
'+MESSAGE())'

Enddefine
#Endif
Function Logit(cStr)   
TEXT TO mystr TEXTMERGE NOSHOW   
<<DATETIME()>> <<PROGRAM(PROGRAM(-1)-1)>> <<cStr>>   

ENDTEXT
Strtofile(myStr,"D:\t.TXT",.T.)
Visual FoxPro 回调设计
Visual FoxPro 7.0 让开发者可以创建客户程序可以实现的发布接口的 COM 对象. 这种回调情形几乎与 Visual FoxPro 对象对客户程序出现的事件相同. 以下示例由一个叫做 IDEMO 主要的 COM 服务程序类组成, 它也发布一个叫做 DemoEvents 的事件接口.

客户程序代码只有一个名为 cCallBack 的实现 DemoEvents 的类.

IDEMO 有一个名为 BuyStock 的可以被客户程序调用来购买股票方法. BuyStock 方法只有一个关于代码可以放置来购买股票的注释. 但是, 在代码的前面的后面, 该方法调用 DemoEvents 类中的方法. 如果客户程序没有一个回调过程来设置使用 SetCallBack 方法, 则调用 DemoEvents 方法. 但是, 如果有一个回调对象, 则这些方法将在客户程序中被调用.

CLEAR ALL   
IF PROGRAM() != "IDEMO"   
   ?"this file MUST BE NAMED 'idemo.prg'"   
   RETURN
ENDIF
IF .t.   
   IF FILE("idemo.dll")   
      DECLARE integer DllUnregisterServer IN idemo.dll   
      DllUnregisterServer()
      CLEAR DLLS   
   ENDIF
   BUILD PROJECT idemo FROM idemo   
   BUILD DLL idemo from idemo recomp   
endif
clear

oCallback = NEWOBJECT("cCallback")    && 客户端回调函数   
ostock=newOBJECT("idemo.idemo")       && 商业 COM 对象   
ostock.setcallback(oCallBack)         && 象 BindEvents 一样   
?ostock.BuyStock("MSFT",10000 )       && 调用一个方法   
ostock.setcallback(.null.)            && 象 UnBindEvents 一样   
?ostock.BuyStock("MSFT",20000 )       && 这一个不激发事件   

* 这是事件接口的实际执行   
DEFINE CLASS cCallback as session   
   implements iDemoEvents in idemo.dll   
   procedure iDemoEvents_BeforeBuyStock(cStock as String, qty AS Number)   
      ?program(),cstock,qty
   procedure iDemoEvents_AfterBuyStock(cStock as String, qty AS Number)   
      ?program(),cstock,qty

enddefine

* 余下部分在 COM 服务程序中使用   
DEFINE CLASS idemo as session olepublic   
   oc = .null.   
   PROCEDURE init   
      this.SetCallBack(.null.)    && 设置默认的回调   
   PROCEDURE setcallback(oC as Variant)   
      IF ISNULL(oc)   
         && dummy instance that does nothing: virtual function   
         this.oc = NEWOBJECT("DemoEvents")   
      else
         IF VARTYPE(oc) != 'O'   
            COMRETURNERROR(PROGRAM(),"callback must be obj")   
         ENDIF
         this.oc = GETINTERFACE(oC,"iDemoEvents","idemo.idemo")   
      endif
   procedure MyDoCmd(cCmd as String) as Variant   
      &cCmd
   procedure MyEval(cExpr as String) as Variant   
      return &cExpr   
   procedure BuyStock(cStock as String, qty AS Number) as Boolean   
      this.oc.BeforeBuyStock(cStock, qty)   
      *here we buy the stock   
      this.oc.AfterBuyStock(cStock, qty)   
   FUNCTION Error(nError, cMethod, nLine)   
      COMreturnerror(cMethod+'  err#='+str(nError,5)+'  line='+;   
         str(nline,6)+' '+message(),_VFP.ServerName)   
      && this line is never executed   

enddefine

*Just an interface definition that should be implemented by outside callers   
DEFINE CLASS DemoEvents as session olepublic   
   procedure BeforeBuyStock(cStock as String, qty AS Number)   
   procedure AfterBuyStock(cStock as String, qty AS Number)   
enddefine
COM 允许对象间以不同的方式交互. 在这几年中 Visual FoxPro 中的 COM 功能一直在增强, 从一个简单的 COM 客户程序功能, 接口实现, 及早期绑定服务程序和客户程序支持, 已经打开一个完整的新的功能世界.