Option Explicit
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const UrlPart As String = "http://www.cnbc.com/id/15837290?q="
Public Event UpdateAvailable(Symbol As String, RealTimeData As RTDArgs)
Public Event TimedOut(Symbol As String)
'requires a reference to Microsoft HTML Object Library
Private WithEvents TimeSpan As HTMLSpanElement
Private LastSpan As HTMLSpanElement
Private VolumeSpan As HTMLSpanElement
Private HTMLDoc As HTMLDocument
Private WithEvents WebB As WebBrowser
Private pFrm As frmDataItem
Private pSymbol As String
Private pEnableEvents As Boolean
Private pConnected As Boolean
Private pTimeOutSeconds As Integer
Private pSessionID As String
Private pFrameSource As String
Private pForceRefresh As Boolean
Private pRealTimeData(2) As String
Private pOpenHighLow(2) As String
Private pCancelNavigation As Boolean
Private pLastRefreshTime As Date
Private pCallerIsUDF As Boolean
Friend Function OpenHighLow() As OHLArgs
If Not pConnected Then Exit Function
If DateDiff("n", pLastRefreshTime, Now) > 1 Then Me.Refresh
Dim Args As OHLArgs
Set Args = New OHLArgs
With Args
.Symbol = pSymbol
.OpenText = pOpenHighLow(0)
.HighText = pOpenHighLow(1)
.LowText = pOpenHighLow(2)
If IsNumeric(pOpenHighLow(0)) Then
.OpenValue = CCur(pOpenHighLow(0))
Else
.HasError = True
End If
If IsNumeric(pOpenHighLow(1)) Then
.HighValue = CCur(pOpenHighLow(1))
Else
.HasError = True
End If
If IsNumeric(pOpenHighLow(2)) Then
.LowValue = CDate(pOpenHighLow(2))
Else
.HasError = True
End If
End With
Set OpenHighLow = Args
End Function
Friend Property Get RTD() As RTDArgs
If Not pConnected Then Exit Property
Dim Args As RTDArgs
Set Args = New RTDArgs
With Args
.Symbol = pSymbol
.LastText = pRealTimeData(0)
.VolumeText = pRealTimeData(1)
.TimeText = pRealTimeData(2)
If IsNumeric(pRealTimeData(0)) Then
.LastValue = CCur(pRealTimeData(0))
Else
.HasError = True
End If
If IsNumeric(pRealTimeData(1)) Then
.VolumeValue = CCur(pRealTimeData(1))
Else
.HasError = True
End If
If IsDate(pRealTimeData(2)) Then
.TimeValue = CDate(pRealTimeData(2))
Else
.HasError = True
End If
End With
Set RTD = Args
End Property
Friend Function Connect(Symbol As String, _
Optional EnableEvents As Boolean, _
Optional TimeOutSeconds As Integer = 10, _
Optional CallerIsUDF As Boolean) As Boolean
Dim TimeOutTime As Date
Me.TimeOutSeconds = TimeOutSeconds
pCallerIsUDF = CallerIsUDF
Me.Symbol = Symbol
If Not pCallerIsUDF Then
Me.EnableEvents = EnableEvents
End If
TimeOutTime = Now + TimeSerial(0, 0, TimeOutSeconds)
Do Until Me.Connected
Sleep 250
If Now > TimeOutTime Then Exit Do
Loop
Connect = Me.Connected
pLastRefreshTime = Now
End Function
Private Function GetProperties() As Boolean
Dim Script As HTMLScriptElement, Frame As HTMLObjectElement
Dim TempFrameSource As String
On Error Resume Next
Set HTMLDoc = WebB.Document
For Each Script In HTMLDoc.Scripts
If InStr(Script.innerHTML, "cnbc_RunQuoteStrip") <> 0 Then
pSessionID = Replace(Split(Script.innerHTML, ",")(3), "'", "")
Exit For
End If
Next
For Each Frame In HTMLDoc.all
TempFrameSource = Frame.src
If InStr(TempFrameSource, "delayedQuotes&symbol=" & Symbol) <> 0 Then
pFrameSource = TempFrameSource
Exit For
End If
Next
Set LastSpan = HTMLDoc.getElementById("WSODQ_" & pSymbol & "_LAST_0_" & pSessionID)
Set VolumeSpan = HTMLDoc.getElementById("WSODQ_" & pSymbol & "_VOLUME_0_" & pSessionID)
Set TimeSpan = HTMLDoc.getElementById("WSODQ_" & pSymbol & "_LASTTIME_0_" & pSessionID)
If (Not LastSpan Is Nothing) And (Not VolumeSpan Is Nothing) And (Not TimeSpan Is Nothing) Then
If LastSpan.innerText <> "" And VolumeSpan.innerText <> "" And TimeSpan.innerText <> "" And pFrameSource <> "" Then
GetProperties = True
Exit Function
End If
End If
End Function
Private Sub Class_Initialize()
Set pFrm = New frmDataItem
Set WebB = pFrm.WebBrowser1
End Sub
Private Sub Class_Terminate()
Set WebB = Nothing
Unload pFrm
Set pFrm = Nothing
End Sub
Friend Sub Refresh()
pForceRefresh = True
Me.Symbol = pSymbol
pLastRefreshTime = Now
End Sub
Friend Property Let TimeOutSeconds(ByVal vNewValue As Integer)
If vNewValue < 5 Then vNewValue = 5
pTimeOutSeconds = vNewValue
End Property
Friend Property Get TimeOutSeconds() As Integer
TimeOutSeconds = pTimeOutSeconds
End Property
Friend Property Get EnableEvents() As Boolean
EnableEvents = pEnableEvents
End Property
Friend Property Let EnableEvents(ByVal vNewValue As Boolean)
pEnableEvents = vNewValue
End Property
Friend Property Get Symbol() As String
Symbol = pSymbol
End Property
Friend Property Let Symbol(ByVal vNewValue As String)
Dim TimeOutTime As Date, doc(1) As HTMLDocument
If pSymbol <> vNewValue Or pForceRefresh Then
pForceRefresh = False
pSymbol = vNewValue
' pFrm.Show vbModeless
pCancelNavigation = False
TimeOutTime = Now + TimeSerial(0, 0, Int(TimeOutSeconds))
WebB.Navigate UrlPart & pSymbol
Do Until GetProperties
If Now > TimeOutTime Then Exit Do
DoEvents
Loop
WebB.Stop
Set doc(0) = New HTMLDocument
Set doc(1) = doc(0).createDocumentFromUrl(pFrameSource, "")
Do Until doc(1).ReadyState = "complete"
DoEvents
Loop
pOpenHighLow(0) = doc(1).getElementById("right").Children(0).Children(0).innerText
pOpenHighLow(1) = doc(1).getElementById("stockQuote").getElementsByTagName("B")(2).innerText
pOpenHighLow(2) = doc(1).getElementById("stockQuote").getElementsByTagName("B")(4).innerText
End If
Set LastSpan = HTMLDoc.getElementById("WSODQ_" & pSymbol & "_LAST_0_" & pSessionID)
pConnected = True
End Property
Friend Property Get Connected() As Boolean
Connected = pConnected
End Property
Private Sub TimeSpan_onpropertychange()
pRealTimeData(0) = LastSpan.innerText
pRealTimeData(1) = VolumeSpan.innerText
pRealTimeData(2) = TimeSpan.innerText
If pEnableEvents Then RaiseEvent UpdateAvailable(pSymbol, Me.RTD)
End Sub
Private Sub WebB_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean)
If pCallerIsUDF Then
Cancel = pCancelNavigation
pCancelNavigation = True
End If
End Sub
