使用VB6制作RTD函数

时间:2022-03-21 00:54:21

以前模仿大神在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服务

         使用VB6制作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个接口的具体实现:

使用VB6制作RTD函数使用VB6制作RTD函数
 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,它的作用应该是标识这个服务)

使用VB6制作RTD函数使用VB6制作RTD函数

效果展示

1、输入公式取到数据

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

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

 使用VB6制作RTD函数