vb求救,RTD (real_time_data )客户端
我想用VB做一个类似于excel的RTD (real_time_data )客户端。
有服务端的代码范例,来自微软。
建立範例 RealTimeData 伺服器
下列範例將告訴您,如何利用 Microsoft Excel 2002 建立和使用 RealTimeData 伺服器。此伺服器只會在工作表上提供每 10 秒更新一次的計數器。伺服器最多可接受兩個主題字串。第一個主題字串可以是 AAA、BBB 和 CCC,而任何其他主題字串會被視為無效,並且伺服器會傳回 #VALUE! 至 RTD 函數。第二個字串是數值,表示傳回值該如何遞增。如果省略第二個字串,遞增值會預設為 1;如果第二個字串不是數值,則伺服器會傳回 #NUM! 至 RTD 函數。
在 Visual Basic 中開啟新的 ActiveX DLL 專案。
在 [專案] 功能表上,按一下 [參考],選取 Excel 的物件程式庫,然後按一下 [確定]。
在 Microsoft Excel 2002 中:[Microsoft Excel 10.0 物件程式庫]
在 Microsoft Office Excel 2003 中:[Microsoft Excel 11.0 物件程式庫]
在 [專案] 功能表上,按一下 [Project1 屬性]。將 [專案名稱] 變更為 ExcelRTD,然後按一下 [確定]。
將 Class1 類別模組的 Name 屬性變更為 RTDFunctions。將下列程式碼加入至 RTDFunctions:
Option Explicit
Implements IRtdServer 'Interface allows Excel to contact this RealTimeData server
Private m_colTopics As Collection
Private Function IRtdServer_ConnectData(ByVal TopicID As Long, Strings() As Variant, GetNewValues As Boolean) As Variant
'** ConnectData is called whenever a new RTD topic is requested
'Create a new topic class with the given TopicId and string and add it to the
'm_colTopics collection
Dim oTopic As New Topic
m_colTopics.Add oTopic, CStr(TopicID)
oTopic.TopicID = TopicID
oTopic.TopicString = Strings(0)
If UBound(Strings) >= 1 Then oTopic.SetIncrement Strings(1)
'For this example, the initial value for a new topic is always 0
IRtdServer_ConnectData = oTopic.TopicValue
Debug.Print "ConnectData", TopicID
End Function
Private Sub IRtdServer_DisconnectData(ByVal TopicID As Long)
'** DisconnectData is called whenever a specific topic is not longer needed
'Remove the topic from the collection
m_colTopics.Remove CStr(TopicID)
Debug.Print "DisconnectData", TopicID
End Sub
Private Function IRtdServer_Heartbeat() As Long
'** Called by Excel if the heartbeat interval has elapsed since the last time
' Excel was called with UpdateNotify.
Debug.Print "HeartBeat"
End Function
Private Function IRtdServer_RefreshData(TopicCount As Long) As Variant()
'** Called when Excel is requesting a refresh on topics. RefreshData will be called
' after an UpdateNotify has been issued by the server. This event should:
' - supply a value for TopicCount (number of topics to update)
' - return a two dimensional variant array containing the topic ids and the
' new values of each.
Dim oTopic As Topic, n As Integer
ReDim aUpdates(0 To 1, 0 To m_colTopics.Count - 1) As Variant
For Each oTopic In m_colTopics
oTopic.Update
aUpdates(0, n) = oTopic.TopicID
aUpdates(1, n) = oTopic.TopicValue
n = n + 1
Next
TopicCount = m_colTopics.Count
IRtdServer_RefreshData = aUpdates
Debug.Print "RefreshData", TopicCount & " topics updated"
End Function
Private Function IRtdServer_ServerStart(ByVal CallbackObject As Excel.IRTDUpdateEvent) As Long
'** ServerStart is called when the first RTD topic is requested
Set oCallBack = CallbackObject
Set m_colTopics = New Collection
g_TimerID = SetTimer(0, 0, TIMER_INTERVAL, AddressOf TimerCallback)
If g_TimerID > 0 Then IRtdServer_ServerStart = 1 'Any value <1 indicates failure.
Debug.Print "ServerStart"
End Function
Private Sub IRtdServer_ServerTerminate()
'** ServerTerminate is called when no more topics are needed by Excel.
KillTimer 0, g_TimerID
'** Cleanup any remaining topics. This is done here since
' IRtdServer_DisconnectData is only called if a topic is disconnected
' while the book is open. Items left in the collection when we terminate
' are those topics left running when the workbook was closed.
Dim oTopic As Topic
For Each oTopic In m_colTopics
m_colTopics.Remove CStr(oTopic.TopicID)
Set oTopic = Nothing
Next
Debug.Print "ServerTerminate"
End Sub
在 [專案] 功能表上,按一下 [加入類別模組]。將類別模組 Name 屬性變更為 Topic,並將 Instancing 屬性變更為 Private。將下列程式碼加入至 Topic 類別模組:
Option Explicit
Private m_TopicID As Long
Private m_TopicString As String
Private m_Value As Variant
Private m_IncrementVal As Long
Private Sub Class_Initialize()
m_Value = 0
m_IncrementVal = 1
End Sub
Friend Property Let TopicID(ID As Long)
m_TopicID = ID
End Property
Friend Property Get TopicID() As Long
TopicID = m_TopicID
End Property
Friend Property Let TopicString(s As String)
s = UCase(s)
If s = "AAA" Or s = "BBB" Or s = "CCC" Then
m_TopicString = s
Else
m_Value = CVErr(xlErrValue) 'Return #VALUE if not one of the listed topics
End If
End Property
Friend Sub Update()
On Error Resume Next 'the next operation will fail if m_Value is an error (like #NUM or #VALUE)
m_Value = m_Value + m_IncrementVal
End Sub
Friend Sub SetIncrement(v As Variant)
On Error Resume Next
m_IncrementVal = CLng(v)
If Err <> 0 Then
m_Value = CVErr(xlErrNum) 'Return #NUM if Increment value is not numeric
End If
End Sub
Friend Property Get TopicValue() As Variant
If Not (IsError(m_Value)) Then
TopicValue = m_TopicString & ": " & m_Value
Else
TopicValue = m_Value
End If
End Property
在 [專案] 功能表上,選取 [加入模組]。將下列程式碼加入至新的模組:
Public Declare Function SetTimer Lib "user32" (ByVal hWnd As Long, _
ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Public Declare Function KillTimer Lib "user32" (ByVal hWnd As Long, ByVal nIDEvent As Long) As Long
Public Const TIMER_INTERVAL = 5000
Public oCallBack As Excel.IRTDUpdateEvent
Public g_TimerID As Long
Public Sub TimerCallback(ByVal hWnd As Long, ByVal uMsg As Long, ByVal idEvent As Long, ByVal dwTime As Long)
oCallBack.UpdateNotify
End Sub
在 [檔案] 功能表上,按一下 [建立 ExcelRTD.dll] 以建置元件。