form1.frm

从yahoo.com上下载股票的报价

VERSION 5.00
Object = "{48E59290-9880-11CF-9754-00AA00C00908}#1.0#0"; "msinet.ocx"
Begin VB.Form Form1 
   Caption         =   "Quotes"
   ClientHeight    =   2190
   ClientLeft      =   1800
   ClientTop       =   1530
   ClientWidth     =   5760
   LinkTopic       =   "Form1"
   ScaleHeight     =   2190
   ScaleWidth      =   5760
   Begin VB.TextBox txtQuotes 
      Height          =   1335
      Left            =   2160
      MultiLine       =   -1  'True
      TabIndex        =   5
      Top             =   120
      Width           =   3495
   End
   Begin VB.CommandButton cmdGetQuotes 
      Caption         =   "Get Quotes"
      Height          =   495
      Left            =   840
      TabIndex        =   4
      Top             =   480
      Width           =   1215
   End
   Begin VB.TextBox txtSymbol 
      Height          =   285
      Index           =   3
      Left            =   120
      TabIndex        =   3
      Text            =   "GTE"
      Top             =   1200
      Width           =   615
   End
   Begin VB.TextBox txtSymbol 
      Height          =   285
      Index           =   2
      Left            =   120
      TabIndex        =   2
      Text            =   "COKE"
      Top             =   840
      Width           =   615
   End
   Begin VB.TextBox txtSymbol 
      Height          =   285
      Index           =   1
      Left            =   120
      TabIndex        =   1
      Text            =   "DIS"
      Top             =   480
      Width           =   615
   End
   Begin VB.TextBox txtSymbol 
      Height          =   285
      Index           =   0
      Left            =   120
      TabIndex        =   0
      Text            =   "GTE"
      Top             =   120
      Width           =   615
   End
   Begin InetCtlsObjects.Inet inetQuotes 
      Left            =   1080
      Top             =   960
      _ExtentX        =   1005
      _ExtentY        =   1005
      _Version        =   327681
   End
   Begin VB.Label Label1 
      Caption         =   "Yahoo has changed their Web site so this program no longer works. See readme.txt for details."
      BeginProperty Font 
         Name            =   "MS Sans Serif"
         Size            =   8.25
         Charset         =   0
         Weight          =   700
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   495
      Left            =   120
      TabIndex        =   6
      Top             =   1680
      Width           =   5535
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' Set the following constant to True to load
' from a test data file instead of from
' the Web.
'Private Const USE_TEST_FILE = True
Private Const USE_TEST_FILE = False

' Get a row from the response string.
Private Function GetRow(response As String) As String
Dim pos As Integer
Dim symbol As String
Dim last_time As String
Dim last_price As String
Dim change_amount As String
Dim change_percent As String

    ' Find the "<tr" starting the row.
    pos = InStr(response, "<tr")
    If pos = 0 Then
        response = ""
        GetRow = ""
        Exit Function
    End If
    response = Mid$(response, pos)

    ' Find the items in this row.
    symbol = GetRowItem(response)
    last_time = GetRowItem(response)
    If InStr(last_time, "No such ticker symbol.") > 0 Then
        GetRow = "No such ticker symbol."
        Exit Function
    End If

    last_price = GetRowItem(response)
    change_amount = GetRowItem(response)
    change_percent = GetRowItem(response)

    GetRow = symbol & ": " & _
        last_time & ", " & _
        last_price & ", " & _
        change_amount & ", " & _
        change_percent
End Function
' Get the next table item from the table.
Private Function GetRowItem(response As String) As String
Dim start_pos As Integer
Dim end_pos As Integer
Dim pos As Integer
Dim count As Integer
Dim ch As String
Dim txt As String

    ' Find the "<td" and "</td" that bracket
    ' the item.
    start_pos = InStr(response, "<td")
    end_pos = InStr(start_pos, response, "</td")

    ' Save characters between these where the
    ' outstanding brackets match.
    count = 1
    For pos = start_pos + 1 To end_pos
        ch = Mid$(response, pos, 1)
        If ch = "<" Then
            count = count + 1
        ElseIf ch = ">" Then
            count = count - 1
        Else
            If count = 0 Then txt = txt & ch
        End If
    Next pos

    GetRowItem = txt
    response = Mid$(response, end_pos)
End Function
Private Function LoadTestFile() As String
Dim fname As String
Dim fnum As Integer

    fname = App.Path & "\quote.htm"
    fnum = FreeFile
    Open fname For Input As fnum
    LoadTestFile = Input$(LOF(fnum), #fnum)
    Close fnum
End Function

Private Function ParseResponse(ByVal response As String) As String
Dim start_pos As Integer
Dim end_pos As Integer
Dim i As Integer
Dim quotes As String
Dim new_row As String

    ' Find the table that contains the
    ' interesting information.
    start_pos = InStr(response, "Last Trade")
    If start_pos = 0 Then
        ParseResponse = "Error parsing response."
        Exit Function
    End If
    
    ' See where the table ends.
    end_pos = InStr(start_pos, response, "</table>")
    response = Mid$(response, start_pos, end_pos - start_pos + Len("</table>"))

    ' Parse the rows from the table.
    Do
        new_row = GetRow(response)
        If Len(new_row) = 0 Then Exit Do
        
        quotes = quotes & new_row & vbCrLf
    Loop

    ParseResponse = quotes
End Function
Private Sub cmdGetQuotes_Click()
Dim not_first_symbol As Boolean
Dim symbol As String
Dim query_url As String
Dim i As Integer
Dim response As Variant

    MousePointer = vbHourglass
    txtQuotes.Text = ""
    DoEvents
    
    ' Prepare a URL to get the quotes.
    If USE_TEST_FILE Then
        response = LoadTestFile
    Else
        query_url = "http://quote.yahoo.com/q?s="
        For i = txtSymbol.LBound To txtSymbol.UBound
            symbol = LCase$(Trim$(txtSymbol(i).Text))
            If Len(symbol) > 0 Then
                If not_first_symbol Then _
                    query_url = query_url & "%2C"
                query_url = query_url & symbol
                not_first_symbol = True
            End If
        Next i
        query_url = query_url & "&d=v1"
    
        ' Open the URL.
        response = inetQuotes.OpenURL(query_url)
    End If

    ' Parse the response.
    txtQuotes.Text = ParseResponse(CStr(response))

    MousePointer = vbDefault
End Sub
' Cancel any pending commands.
Private Sub Form_Unload(Cancel As Integer)
    inetQuotes.Cancel
End Sub