使用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"等英文名称，所以用属性包装了一下。

 1     '该次请求的股票代码
 2 Private Code As String
 3     '该次请求的股票名称
 4 Private Index As String
 5     '该次请求Excel分配的TopicID
 6 Public TopicID As Integer
 7     '该次请求的返回值
 8 Public Value As Variant
 9 
10 Public Property Get StockCode() As Variant
11     If Left(Code, 1) = 6 Then
12         StockCode = "sh" & Code
13     Else
14         StockCode = "sz" & Code
15     End If
16 End Property
17 
18 Public Property Let StockCode(ByVal Value As Variant)
19       Code = Value
20 End Property
21 
22 Public Property Get StockIndex() As String
23      StockIndex = Index
24 End Property
25 
26 Public Property Let StockIndex(ByVal Value As String)
27     Select Case Value
28         Case "股票名称": Index = "name"
29         Case "股票代码": Index = "code"
30         Case "开盘价": Index = "OpenningPrice"
31         Case "收盘价": Index = "closingPrice"
32         Case "最新价": Index = "currentPrice"
33         Case "最高价": Index = "hPrice"
34         Case "最低价": Index = "lPrice"
35         Case Else: Index = "name"
36     End Select
37 End Property

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

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

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

 1 Private url As String
 2 Private list As String
 3 
 4 Private Sub Class_Initialize()
 5     url = "http://apis.baidu.com/apistore/stockservice/stock?stockid="
 6     list = "&list=2"
 7 End Sub
 8 
 9 Private Function JsonText(stock As StockData) As String
10 Dim strurl As String
11 Set winhttp = CreateObject("WinHttp.WinHttpRequest.5.1")
12     strurl = url & stock.StockCode & list
13     winhttp.Open "GET", strurl, False
14     winhttp.setRequestHeader "apikey", "你的apikey"
15     winhttp.send
16 JsonText = winhttp.ResponseText
17 End Function
18 
19 Function QueryInfo(stock As StockData)
20 Set scobj = CreateObject("MSScriptControl.ScriptControl")
21     scobj.Language = "JavaScript"
22     scobj.AddCode ("var query = " & JsonText(stock))
23     scobj.AddCode ("var info =query.retData.stockinfo[0]")
24     scobj.Eval ("var value = info." & stock.StockIndex)
25     
26     stock.Value = scobj.Eval("value")
27 '非开盘时间，使用随机数模拟价格变化
28 '    If stock.StockIndex = "name" Then
29 '        stock.Value = scobj.Eval("value")
30 '    Else
31 '        stock.Value = scobj.Eval("value") + Format(Rnd * 10, "0.00")
32 '    End If
33 End Function
34 
35 Function QueryInfos(stocks As Collection)
36 Dim temp As StockData
37     For Each s In stocks
38        Set temp = s
39            QueryInfo temp
40     Next s
41 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个接口的具体实现：

 1 Implements IRtdServer
 2 
 3 Dim rtdUpdate As IRTDUpdateEvent
 4 Dim stocks As Collection
 5 Dim helper As StockHelper
 6 Dim WithEvents Timer As clsTimer
 7 
 8 Private Function IRtdServer_Heartbeat() As Long
 9          IRtdServer_Heartbeat = 1
10 End Function
11 
12 Private Function IRtdServer_ServerStart(ByVal CallbackObject As IRTDUpdateEvent) As Long
13         Set rtdUpdate = CallbackObject
14         Set stocks = New Collection
15         Set helper = New StockHelper
16         Set Timer = New clsTimer
17         Timer.Interval = 2000
18         Timer.Enabled = True
19         IRtdServer_ServerStart = 1
20 End Function
21 
22 Private Sub Timer_Timer()
23     helper.QueryInfos stocks
24     rtdUpdate.UpdateNotify
25 End Sub
26 
27 Private Function IRtdServer_ConnectData(ByVal TopicID As Long, Strings() As Variant, GetNewValues As Boolean) As Variant
28       GetNewValues = True
29       Dim temp As New StockData
30       temp.StockCode = Strings(0)
31       temp.StockIndex = Strings(1)
32       temp.TopicID = TopicID
33       helper.QueryInfo temp
34       stocks.Add temp
35       IRtdServer_ConnectData = temp.Value
36 End Function
37 
38 Public Function IRtdServer_RefreshData(TopicCount As Long) As Variant()
39      Dim objs() As Variant
40      Dim i As Integer
41      TopicCount = stocks.Count
42      ReDim objs(0 To 1, 0 To TopicCount - 1)
43        For Each s In stocks
44                 objs(0, i) = s.TopicID
45                 objs(1, i) = s.Value
46                 i = i + 1
47        Next
48      IRtdServer_RefreshData = objs
49 End Function
50 
51 Private Sub IRtdServer_DisconnectData(ByVal TopicID As Long)
52     For i = stocks.Count To 1 Step -1
53         If stocks(i).TopicID = TopicID Then
54             stocks.Remove (i)
55         End If
56     Next i
57 End Sub
58 
59 Private Sub IRtdServer_ServerTerminate()
60     Timer.Enabled = False
61     Set rtdUpdate = Nothing
62     Set stocks = Nothing
63     Set Timer = Nothing
64 End Sub

View Code

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

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

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

 1 Dim rtdUpdate As IRTDUpdateEvent
 2 Dim stocks As Collection
 3 Dim helper As StockHelper
 4 Dim WithEvents Timer As clsTimer
 5 
 6 Private Function IRtdServer_ServerStart(ByVal CallbackObject As IRTDUpdateEvent) As Long
 7         Set rtdUpdate = CallbackObject
 8         Set stocks = New Collection
 9         Set helper = New StockHelper
10         Set Timer = New clsTimer
11         Timer.Interval = 2000
12         Timer.Enabled = True
13         IRtdServer_ServerStart = 1
14 End Function
15 
16 Private Sub Timer_Timer()
17     helper.QueryInfos stocks
18     rtdUpdate.UpdateNotify
19 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函数首次请求数据时执行本方法。

 1 Private Function IRtdServer_ConnectData(ByVal TopicID As Long, Strings() As Variant, GetNewValues As Boolean) As Variant
 2       GetNewValues = True
 3       Dim temp As New StockData
 4       　　temp.StockCode = Strings(0)
 5       　　temp.StockIndex = Strings(1)
 6       　　temp.TopicID = TopicID
 7       helper.QueryInfo temp
 8       stocks.Add temp
 9       IRtdServer_ConnectData = temp.Value
10 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执行时会调用本方法刷新数据)

 1 Public Function IRtdServer_RefreshData(TopicCount As Long) As Variant()
 2      Dim objs() As Variant
 3      Dim i As Integer
 4      TopicCount = stocks.Count
 5      ReDim objs(0 To 1, 0 To TopicCount - 1)
 6        For Each s In stocks
 7                 objs(0, i) = s.TopicID
 8                 objs(1, i) = s.Value
 9                 i = i + 1
10        Next
11      IRtdServer_RefreshData = objs
12 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、删除单个主题，不影响其它主题

 

 

 

 

 

 

 

    

  

    

转载于:https://www.cnblogs.com/zzstone/p/5584173.html