使用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, 1) = 6 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 = 1
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 = 2000
        Timer.Enabled = True
        IRtdServer_ServerStart = 1
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(0)
      temp.StockIndex = Strings(1)
      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(0 To 1, 0 To TopicCount - 1)
       For Each s In stocks
                objs(0, i) = s.TopicID
                objs(1, i) = s.Value
                i = i + 1
       Next
     IRtdServer_RefreshData = objs
End Function

Private Sub IRtdServer_DisconnectData(ByVal TopicID As Long)
    For i = stocks.Count To 1 Step -1
        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 = 2000
        Timer.Enabled = True
        IRtdServer_ServerStart = 1
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(0)
      　　temp.StockIndex = Strings(1)
      　　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(0 To 1, 0 To TopicCount - 1)
       For Each s In stocks
                objs(0, i) = s.TopicID
                objs(1, i) = s.Value
                i = i + 1
       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、删除单个主题，不影响其它主题