VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "StockQuote"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
' HTML tag
' Desaware ActiveX Library
' Copyright (c) 1997 by Desaware Inc.  All Rights Reserved

Option Explicit

' The symbol is set by the GetQuote function
Private m_Symbol As String

' These will be loaded from the web page
Private m_CompanyName As String
Private m_LastPrice As String
Private m_PriorClose As String
Private m_Change As String
Private m_High As String
Private m_Low As String
' Time of last quote
Private m_QuoteTime As String

' Object to notify when quote arrives
' Object must have function:
' Sub QuoteUpdate (QuoteInfo As StockQuote)
' We use notification instead of events because
' an app will typicall use many of these objects.
Private m_Notify As Object

' 0 for idle
' 1 for busy
' 2 for error on latest quote
Private m_State As Integer

Public Enum QuoteState
   sqIdle = 0
   sqBusy = 1
   sqError = 2
End Enum

' Start the process of retrieving a quote
Public Sub GetQuote(symbol As String, Optional callback As Object)
   If m_State = 1 Then
      ' Don't try to get a quote when one is in progress
      TriggerError 4000
      Exit Sub
   End If
   If Not IsMissing(callback) Then
      Set m_Notify = callback
   End If
   ' Set the symbol
   m_Symbol = symbol
   ' Mark it as busy
   m_State = 1
   ' Start the quotation
   StartQuote Me
End Sub

' Report the quote back to the notification object
' if one exists
' Remember, this is called on error - callee should
' always check state for an error code
' html is collection of dwHTMLelements
Friend Sub ReportQuote(html As dwHTMLcollection, endState As QuoteState)
   Dim CallbackObject As Object
   
   ' Parse the html page
   If Not html Is Nothing Then
      ParseHtml html
   End If
   
   ' Set the current state
   m_State = endState
   
   Set CallbackObject = m_Notify
   ' Always clear the notification - we don't want to
   ' hold the object
   Set m_Notify = Nothing
   If Not CallbackObject Is Nothing Then
      On Error GoTo NoCallbackName
      CallbackObject.QuoteUpdate Me
   End If
NoCallbackName:
   ' If a callback text error occurs, just exit
End Sub

' Retrieve the state of this object
' 0 - idle
' 1 - Busy
' 2 - Error on last operation
Public Property Get State() As QuoteState
   State = m_State
End Property

' Symbol
Public Property Get symbol() As String
   symbol = m_Symbol
End Property

' Properties to retrive stock info
Public Property Get CompanyName() As String
   CompanyName = m_CompanyName
End Property

Public Property Get LastPrice() As String
   LastPrice = m_LastPrice
End Property

Public Property Get PriorClose() As String
   PriorClose = m_PriorClose
End Property

Public Property Get Change() As String
   Change = m_Change
End Property

Public Property Get QuoteTime() As String
   QuoteTime = m_QuoteTime
End Property

Public Property Get High() As String
   High = m_High
End Property

Public Property Get Low() As String
   Low = m_Low
End Property

' Raise an error
Private Sub TriggerError(errnum As Long)
   Err.Raise vbObjectError + errnum, "StockQuote", GetErrorString(errnum), App.HelpFile, errnum + HelpBaseOffset
End Sub

' Prevents notification. Used when you
' want to close your application - it
' forces the Quote object to release the callback
' object that it is holding
Public Sub CancelNotification()
   Set m_Notify = Nothing
End Sub

Friend Sub ParseHtml(html As dwHTMLcollection)
   Select Case QuoteSource
      Case sqschwab
         ParseSchwabQuote html
      Case sqyahoo
         ParseYahooQuote html
   End Select
End Sub

Private Sub ParseYahooQuote(html As dwHTMLcollection)
   Dim HtmlFoundIdx As Long
   Dim HtmlFoundIdx2 As Long
   Dim IsFund As Boolean
   Dim QuoteType$
   HtmlFoundIdx = html.FindTagSequence(1, False, "Table", "tr", "td", "b")
   If HtmlFoundIdx = 0 Then Exit Sub
   HtmlFoundIdx2 = html.FindTagSequence(HtmlFoundIdx + 1, False, "Table", "tr", "td", "b")
   If HtmlFoundIdx2 <> 0 Then HtmlFoundIdx = HtmlFoundIdx2 ' We may need to skip the first table.
   
   m_CompanyName = ConvertHtmlLiterals(html.item(HtmlFoundIdx + 4).Contents)
   m_QuoteTime = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "Last Trade"))
   If m_QuoteTime = "" Then
      m_QuoteTime = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "Net Asset Value"))
      IsFund = True
   End If
   HtmlFoundIdx = HtmlFoundIdx + 1
   m_LastPrice = ConvertHtmlLiterals(html.AppendThroughTag(HtmlFoundIdx, "", "/b"))
   m_Change = html.AppendThroughTag(HtmlFoundIdx, "Change", "/TD")
   m_PriorClose = ConvertHtmlLiterals(html.AppendThroughTag(HtmlFoundIdx, "Prev Cls", "/td"))
   
   ' If QuoteType <> "Stock" Then IsFund = True
End Sub

Private Sub ParseSchwabQuote(html As dwHTMLcollection)
   Dim HtmlFoundIdx As Long
   Dim IsFund As Boolean
   Dim QuoteType$
   'HtmlFoundIdx = html.FindTagSequence(1, False, "/Table", "P")
   HtmlFoundIdx = 1
   HtmlFoundIdx = html.FindTagSequence(HtmlFoundIdx, False, "TD", "NORB", "FONT", "B")
      
   If HtmlFoundIdx = 0 Then
      HtmlFoundIdx = html.FindTagSequence(1, False, "TD", "FONT", "B")
      m_CompanyName = ConvertHtmlLiterals(html.item(HtmlFoundIdx + 3).Contents)
   Else
      m_CompanyName = ConvertHtmlLiterals(html.item(HtmlFoundIdx + 4).Contents)
   End If
   
   m_LastPrice = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;Last Trade:"))
   If m_LastPrice = "" Then
      m_LastPrice = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;NAV:"))
      IsFund = True
   End If
   m_Change = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;Net Change:"))
   m_High = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;Day High:"))
   m_Low = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;Day Low:"))
   m_QuoteTime = ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;Date:"))
   m_QuoteTime = m_QuoteTime & " " & ConvertHtmlLiterals(html.FindNextContent(HtmlFoundIdx, "&nbsp;Trade Time:"))
 
   
End Sub


Public Function QuoteToCurrency(ByVal quote As String) As Currency
    Dim spacepos%   ' Location of space
    Dim fractionpos% ' Location of fraction
    Dim TempResult As Currency
    If quote = "" Then Exit Function
    quote = Trim$(quote)    ' Dump leading & trailing spaces
    spacepos = InStr(quote, " ")
    If spacepos = 0 Then
        QuoteToCurrency = CCur(quote)
        Exit Function
    End If
    ' Get the integer value first
    TempResult = CCur(Left$(quote, spacepos - 1))
    
    ' We know it's not a traling space because of
    ' the initial trim operation.
    quote = Mid$(quote, spacepos + 1)
    
    ' Is there a fractional?
    fractionpos = InStr(quote, "/")
    If fractionpos <= 1 Or fractionpos = Len(quote) Then
        ' We don't know how to parse this
        QuoteToCurrency = TempResult
        Exit Function
    End If
    On Error GoTo MathError:
    TempResult = TempResult + CCur(Left$(quote, fractionpos - 1)) / CCur(Mid$(quote, fractionpos + 1))
    QuoteToCurrency = TempResult
    Exit Function
    
MathError:
    ' For now, just return the current result.
    QuoteToCurrency = TempResult
End Function

Public Function CurrencyToQuote(ByVal quote As Currency) As String
    Dim IntVal As Integer
    Dim FracVal As Integer
    Dim Denominator As Integer
    IntVal = Fix(quote) ' Get integer part
    
    ' Get the fractional part
    ' How many 64's  (lowest fraction we're likely to see)
    FracVal = CInt(Abs(quote - IntVal) * 64)

    ' Now we keep dividing while even
    Denominator = 64
    Do
        If (FracVal And 1) Then
            ' It's odd
            Exit Do
        End If
        FracVal = FracVal \ 2
        Denominator = Denominator \ 2
    Loop While Denominator > 0

    CurrencyToQuote = IntVal & " " & FracVal & "/" & Denominator

End Function


