使用VB6制作RTD函数

以前模仿大神在vs里使用c#实现RTD函数功能。（真是很生僻的东东啊）C#制作RTD参考：大神博客跳转。最近想VB里能不能做？就试着做了做，好像基本成了，整套代码有些毛病，勉强能算个样子，暂时不打算再细搞。

概念：什么是RTD函数(效果可先看下结尾的gif演示)

RTD函数是一种程序函数，用途从支持COM自动化的程序中返回实时数据(real-time data)。
语法：RTD(ProgID，server，topic1，[topic2]，...)
参数：ProgID已安装在本地计算机中，经过注册的COM自动化加载宏的ProgID名称，该名称用引号引起来。Server是运行加载宏的服务器的名称
      如果没有服务器，程序是在本地计算机上运行，那么该参数为空白
      topic1，topic2，...为1到28个参数，这些参数放在一起代表一个唯一的实时数据。

猜测的图示，RTD函数和RTD服务和Excel三者之间互有关系？底层MyvbProj.rtdserver是我要做的RTD服务

实现的目标：制作RTD服务程序，从百度APIstore市场中获取股票信息，实时(real-time)刷新数据至excel中。

　　　　　　  API使用方法参考链接：http://apistore.baidu.com/apiworks/servicedetail/115.html

　　　　　　  API取得的数据是JSON，摘要如下（实际信息更多）：

VB处理JSON的方法请参考我另一个博文：点击跳转

{
    "errNum":0,
    "errMsg":"success",
    "retData":
    {
        "stockinfo":[
            {
                "name":"科大讯飞",
                "code":"sz002230",
                "OpenningPrice":31.59,
                "closingPrice":31.4,
                "currentPrice":30.92,
                "hPrice":32.45,
                "lPrice":30.28,
            }]
    }
}

方案准备：

一、使用VB6.0新建一个工程，类型选择ActiveX DLL，工程名称：MyvbProj

二、添加“Microsoft Excel 14.0 Object Library”的引用

三、分别新建四个类模块rtdserver、StockData、StockHelper和一个clsTimer

      前三个类代码下载请点击：点击下载

clsTimer类是个计时器功能的类，代码请参考博文：点击跳转到大神(说明：需要自己动手在类内部添加事件)

StockData类模块：实体类，用来记录数据。因百度api返回的json数据使用的是"name"、"code"等英文名称，所以用属性包装了一下。

     '该次请求的股票代码
 Private Code As String
     '该次请求的股票名称
 Private Index As String
     '该次请求Excel分配的TopicID
 Public TopicID As Integer
     '该次请求的返回值
 Public Value As Variant

 Public Property Get StockCode() As Variant
     If Left(Code, ) =  Then
         StockCode = "sh" & Code
     Else
         StockCode = "sz" & Code
     End If
 End Property

 Public Property Let StockCode(ByVal Value As Variant)
       Code = Value
 End Property

 Public Property Get StockIndex() As String
      StockIndex = Index
 End Property

 Public Property Let StockIndex(ByVal Value As String)
     Select Case Value
         Case "股票名称": Index = "name"
         Case "股票代码": Index = "code"
         Case "开盘价": Index = "OpenningPrice"
         Case "收盘价": Index = "closingPrice"
         Case "最新价": Index = "currentPrice"
         Case "最高价": Index = "hPrice"
         Case "最低价": Index = "lPrice"
         Case Else: Index = "name"
     End Select
 End Property

StockHelper类模块：帮助类，用来具体向百度API拿取(get)数据。API的使用方法可参考网站说明。

向api请求数据需要使用apikey，测试时请替换成个人的apikey。

该类的主要工作是向api请求数据，把请求回来的值保存到StockData的Value属性中。

 Private url As String
 Private list As String

 Private Sub Class_Initialize()
     url = "http://apis.baidu.com/apistore/stockservice/stock?stockid="
     list = "&list=2"
 End Sub

 Private Function JsonText(stock As StockData) As String
 Dim strurl As String
 Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
     strurl = url & stock.StockCode & list
     winhttp.Open "GET", strurl, False
     winhttp.setRequestHeader "apikey", "你的apikey"
     winhttp.send
 JsonText = winhttp.ResponseText
 End Function

 Function QueryInfo(stock As StockData)
 Set scobj = CreateObject("MSScriptControl.ScriptControl")
     scobj.Language = "JavaScript"
     scobj.AddCode ("var query = " & JsonText(stock))
     scobj.AddCode ("var info =query.retData.stockinfo[0]")
     scobj.Eval ("var value = info." & stock.StockIndex)

     stock.Value = scobj.Eval("value")
 '非开盘时间，使用随机数模拟价格变化
 '    If stock.StockIndex = "name" Then
 '        stock.Value = scobj.Eval("value")
 '    Else
 '        stock.Value = scobj.Eval("value") + Format(Rnd * 10, "0.00")
 '    End If
 End Function

 Function QueryInfos(stocks As Collection)
 Dim temp As StockData
     For Each s In stocks
        Set temp = s
            QueryInfo temp
     Next s
 End Function

rtdserver类模块：rtdserver实现rtd函数的主要功能，是本案的主要功能模块

(VB中工程名称+该类模块的类名即为rtd函数的ProgID，本案例中的ProgID="MyvbProj.rtdserver")

该类模块主要实现IRtdServer接口(Implements IRtdServer)。

该接口下有五个方法:

1、服务启动时做一些初始化。该方法的返回值为1时，表示服务启动
   参数是IRTDUpdateEvent对象，该对象有一个UpdateNotify方法很重要。起到通知的作用，执行方法后，Excel会调用IRtdServer_RefreshData方法更新数据
   Private Function IRtdServer_ServerStart(ByVal CallbackObject As IRTDUpdateEvent) As Long

2、rtd函数首次向服务请求数据时执行的方法。每一个请求会被分配一个TopicID(主题)
   Stings()与rtd函数的参数topic1,[topic2]对应，每一个唯一的topic组合对应一个TopicID
   GetNewValues，当它值为1时表示，每次工作簿打开都重新请求数据
   该方法的返回值类型为Variant类型，就是主题首次请求得到的值（即rtd公式的结果）
Private Function IRtdServer_ConnectData(ByVal TopicID As Long, Strings() As Variant, GetNewValues As Boolean) As Variant

3、IRTDUpdateEvent对象调用本方法更新数据(更新主题的数据)，即更新rtd公式的结果
Private Function IRtdServer_RefreshData(TopicCount As Long) As Variant()

4、删除某个主题会执行的方法,参数是被删除的主题的TopicID
Private Sub IRtdServer_DisconnectData(ByVal TopicID As Long)

5、服务器关闭时执行的方法，主要用来释放资源
Private Sub IRtdServer_ServerTerminate()

下面是5个接口的具体实现：

 Implements IRtdServer

 Dim rtdUpdate As IRTDUpdateEvent
 Dim stocks As Collection
 Dim helper As StockHelper
 Dim WithEvents Timer As clsTimer

 Private Function IRtdServer_Heartbeat() As Long
          IRtdServer_Heartbeat =
 End Function

 Private Function IRtdServer_ServerStart(ByVal CallbackObject As IRTDUpdateEvent) As Long
         Set rtdUpdate = CallbackObject
         Set stocks = New Collection
         Set helper = New StockHelper
         Set Timer = New clsTimer
         Timer.Interval =
         Timer.Enabled = True
         IRtdServer_ServerStart =
 End Function

 Private Sub Timer_Timer()
     helper.QueryInfos stocks
     rtdUpdate.UpdateNotify
 End Sub

 Private Function IRtdServer_ConnectData(ByVal TopicID As Long, Strings() As Variant, GetNewValues As Boolean) As Variant
       GetNewValues = True
       Dim temp As New StockData
       temp.StockCode = Strings()
       temp.StockIndex = Strings()
       temp.TopicID = TopicID
       helper.QueryInfo temp
       stocks.Add temp
       IRtdServer_ConnectData = temp.Value
 End Function

 Public Function IRtdServer_RefreshData(TopicCount As Long) As Variant()
      Dim objs() As Variant
      Dim i As Integer
      TopicCount = stocks.Count
      ReDim objs( To ,  To TopicCount - )
        For Each s In stocks
                 objs(, i) = s.TopicID
                 objs(, i) = s.Value
                 i = i +
        Next
      IRtdServer_RefreshData = objs
 End Function

 Private Sub IRtdServer_DisconnectData(ByVal TopicID As Long)
     For i = stocks.Count To  Step -
         If stocks(i).TopicID = TopicID Then
             stocks.Remove (i)
         End If
     Next i
 End Sub

 Private Sub IRtdServer_ServerTerminate()
     Timer.Enabled = False
     Set rtdUpdate = Nothing
     Set stocks = Nothing
     Set Timer = Nothing
 End Sub

IRtdServer_ServerStart：该方法做一些初始化工作，返回值设为1表示服务器已准备就绪，可以工作了。

参数CallbackObject是IRTDUpdateEvent类型，Excel将这个对象实例传至方法内部。

第7行接收IRTDUpdateEvent的对象实例，在类模块内部全局使用。这个对象有个重要方法是UpdateNotify

 Dim rtdUpdate As IRTDUpdateEvent
 Dim stocks As Collection
 Dim helper As StockHelper
 Dim WithEvents Timer As clsTimer

 Private Function IRtdServer_ServerStart(ByVal CallbackObject As IRTDUpdateEvent) As Long
         Set rtdUpdate = CallbackObject
         Set stocks = New Collection
         Set helper = New StockHelper
         Set Timer = New clsTimer
         Timer.Interval =
         Timer.Enabled = True
         IRtdServer_ServerStart =
 End Function

 Private Sub Timer_Timer()
     helper.QueryInfos stocks
     rtdUpdate.UpdateNotify
 End Sub

a、StockHelper类中的方法向百度API请求(get)数据，在这里先做好实例化，备用。

　　b、stocks集合用来保存所有请求到的StockData

　　c、timer是一个计时器（类），因为vb的类模块里无法使用窗体控件timer，我从其它地方抄来了一个timer类来用，自己添加了事件进去。该计时器每隔两秒触发一次Timer事件（Sub Timer_Timer()）做两件事情：

1、代码第17行：重新请求股票数据。
           2、代码第18行：执行rtdUpdate.UpdateNotify实现excel中数据的更新(Excel会调用IRtdServer_ConnectData方法，使用该方法的返回值更新数据)

IRtdServer_ConnectData：rtd函数首次请求数据时执行本方法。

 Private Function IRtdServer_ConnectData(ByVal TopicID As Long, Strings() As Variant, GetNewValues As Boolean) As Variant
       GetNewValues = True
       Dim temp As New StockData
       　　temp.StockCode = Strings()
       　　temp.StockIndex = Strings()
       　　temp.TopicID = TopicID
       helper.QueryInfo temp
       stocks.Add temp
       IRtdServer_ConnectData = temp.Value
 End Function

该方法主要做几个工作：

a、依据rtd函数的参数topic1、topic2...(对应Stings(0),String(1)...)请求数据，得到返回值。
                1.每一个不重复的topic组合，服务器会分配唯一的TopicID
                2.每个主题请求得到的返回值，本案保存在temp.value中。
           b、自动为每一个请求分配一个唯一的TopicID(在IRtdServer_ConnectData依据TopicID刷新数据)

c、GetNewValues=1表示，每次打开工作簿都重新请求数据

IRtdServer_RefreshData:当服务器要刷新数据时执行本方法(IRTDUpdateEvent的UpdateNotify执行时会调用本方法刷新数据)

 Public Function IRtdServer_RefreshData(TopicCount As Long) As Variant()
      Dim objs() As Variant
      Dim i As Integer
      TopicCount = stocks.Count
      ReDim objs( To ,  To TopicCount - )
        For Each s In stocks
                 objs(, i) = s.TopicID
                 objs(, i) = s.Value
                 i = i +
        Next
      IRtdServer_RefreshData = objs
 End Function

　　a、TopicCount记录主题数量。
　　b、返回值是一个2行n列的二维数组，第一行记录TopicID，第二行保存刷新后的值。
      c、猜测Excel使用该方法的返回值，这个二维数组更新rtd公式的值。

其他三个方法比较简单，具体代码可在下载文件中查看，也可以看前文中的代码折叠区，自行分析消化一下：

　　IRtdServer_DisconnectData：删除主题时根据TopicID从Stocks中删除数据，它的参数TopicID就是被删除的主题ID。很简单。

　　IRtdServer_ServerTerminate：释放资源。

　　IRtdServer_Heartbeat：返回值为1时，表示服务器运行正常。

项目编译生成dll文件后，还有关键的一步是要在注册表中注册：

1、生成的dll，我生成的dll起名vbproj.dll。这个生成的dll名字可以按自己的想法起名字。

2、注册dll，方法是在cmd中输入"regsvr32 dll文件的保存路径"

注册完成以后，在注册表中搜索关键字myvbproj.rtdserver会有收获，如图：(可以看到ProgID，它的作用应该是标识这个服务)

效果展示：

1、输入公式取到数据

2、数据每2秒更新一次（非开盘时间，使用随机数模拟数据源的变化）

3、删除单个主题，不影响其它主题