Problem with Internet Explorer

[pwf3k]

I am just learning how to program VB in Excel. I want to write a macro that navigates to a URL and then returns the index of some of the buttons/objects/whatever on the webpage. When I try to run the following code I get "Method 'Document' of object 'IWebBrowser2' failed":

Sub runIE()
Dim IE As Object
Set IE = CreateObject("InternetExplorer.Application")
Dim theURL As String
theURL = "http://finance.yahoo.com/q/hp?s=GOOG&d=6&e=1&f=2008&g=d&a=7&b=19&c=2004&z=66&y=66"
With IE
.Navigate theURL
.Visible = True
End With
For Each mitem In IE.Document.All
mitem.Value = x
x = x + 1
Next
End Sub


Any help? Sorry I can't download on this computer and thus couldn't use the HTML maker program.

 

[Legacy 98055]

Here is a class that retrieves historical data from yahoo. It is returned as a recordset.

Example usage on some worksheet:
B1 contains a stock symbol, B2 a starting date, B3 an ending date, and B4 the interval(Daily, Weekly, or Monthly),
Add a commandbutton named CommandButton1
Paste this code into your worksheet.

Private Sub CommandButton1_Click()
    Dim HSDFY As HistoricalStockDataFromYahoo
    Dim rs As ADODB.RecordSet
    
    On Error GoTo Err_CommandButton1_Click
    
    Set HSDFY = New HistoricalStockDataFromYahoo
    Set rs = HSDFY.GetHistoricalData([b1], [b2], [b3], [b4])
    
    
    rs.MoveFirst
    Range("E2:K" & Rows.Count).ClearContents
    Range("E2").CopyFromRecordset rs

Exit Sub
Err_CommandButton1_Click:
    Select Case Err.Number
        Case 10000
            MsgBox Err.Description
        Case 10001
            'invalid interval
            MsgBox Err.Description
        Case 10002
            'query failed
            MsgBox Err.Description
    End Select
End Sub

Add a class module to your project named "HistoricalStockDataFromYahoo"
Add this code.

Option Explicit

'Grabs Yahoo historical stock data
'tstom@fuse.net
'requires Microsoft ActiveX Data Objects 2.6 or later
Private pWinHttpRequest As WinHttp.WinHttpRequest

Friend Function GetHistoricalData(Symbol As String, _
    Optional FromDate As Date = #12:00:00 AM#, _
    Optional ToDate As Date = #12:00:00 AM#, _
    Optional Interval As String = "Daily") As ADODB.RecordSet
    
    Dim URL As String, ResponseText As String
    Dim pRecordSet As ADODB.RecordSet
    Dim DateString As String, IntervalString As String
    Dim RTS() As String, RTFI
    Dim x As Long
    
    'http://ichart.finance.yahoo.com/table.csv?s=INTC&a=06&b=9&c=1986&d=2&e=5&f=2008&g=d
   
    If FromDate <> #12:00:00 AM# Or ToDate <> #12:00:00 AM# Then
        If FromDate = 0 And ToDate > 0 Then
            FromDate = #1/1/1900#
        ElseIf FromDate > 0 And ToDate = 0 Then
            ToDate = Date
        End If
        DateString = "&a=" & Format(Month(FromDate) - 1, "00") & "&b=" & Format(FromDate, "DD") & "&c=" & Format(FromDate, "YYYY") & _
                     "&d=" & Format(Month(ToDate) - 1, "00") & "&e=" & Format(ToDate, "DD") & "&f=" & Format(ToDate, "YYYY")
    End If
    
    Select Case Interval
        Case "Daily", "": IntervalString = "&g=d"
        Case "Weekly": IntervalString = "&g=w"
        Case "Monthly": IntervalString = "&g=m"
        Case Else
            Err.Raise 10001, "HistoricalStockDataFromYahoo.GetHistoricalData", "Invalid Interval.  Expected ""Daily"", ""Weekly"", or ""Monthly"""
    End Select
    
    URL = "http://ichart.finance.yahoo.com/table.csv?s=" & Symbol & DateString & IntervalString
    
    pWinHttpRequest.Open "GET", URL, False
    pWinHttpRequest.Send
     
    ResponseText = pWinHttpRequest.ResponseText
    If InStr(ResponseText, "<title>Yahoo! - 404 Not Found</title>") Then
            Err.Raise 10002, "HistoricalStockDataFromYahoo.GetHistoricalData", "Invalid Search Parameters or other error.  No data was returned."
    End If
    
    Set pRecordSet = New ADODB.RecordSet
    
    pRecordSet.Fields.Append "Date", adDBDate
    pRecordSet.Fields.Append "Open", adCurrency
    pRecordSet.Fields.Append "High", adCurrency
    pRecordSet.Fields.Append "Low", adCurrency
    pRecordSet.Fields.Append "Close", adCurrency
    pRecordSet.Fields.Append "Volume", adInteger
    pRecordSet.Fields.Append "Adj Close", adCurrency
    pRecordSet.Open
    
    RTS = Split(ResponseText, Chr(10))
    
    For x = LBound(RTS) + 1 To UBound(RTS)
        If RTS(x) <> "" Then
            RTFI = Split(RTS(x), ",")
            pRecordSet.AddNew Array("Date", "Open", "High", "Low", "Close", "Volume", "Adj Close"), Array(RTFI(0), RTFI(1), RTFI(2), RTFI(3), RTFI(4), RTFI(5), RTFI(6))
            pRecordSet.Update
        End If
    Next x

    pRecordSet.MoveFirst
    Set GetHistoricalData = pRecordSet
End Function

Private Sub Class_Initialize()
    On Error Resume Next
    Set pWinHttpRequest = New WinHttpRequest
    If pWinHttpRequest Is Nothing Then
        Err.Raise 10000, "HistoricalStockDataFromYahoo.Class_Initialize", "Could not create WinHttp.WinHttpRequest object..."
    End If
End Sub

<a href="http://home.fuse.net/tstom/StockQuoteGrabber.zip"><img src="http://home.fuse.net/tstom/zip.gif"width="48"height="48"border="0"></a> <a href="http://home.fuse.net/tstom/StockQuoteGrabber.zip">StockQuoteGrabber.zip</a>

 

[jjbungles]

Tom -

This macro really works well- thanks!!! . Wish I was as proficient in VBA as you are.

This may not be a VBA question but I seem to be having trouble downloading supported symbols at yahoo finance.

Most are forex and US indices: I have tried to input ^DIA , ^DIJ, EURUSD=x and ^GSPC for daily data. I push the button, nothing happens, not even an error code. I have looked at the yahoo finance web site and could not find any reason why except it may be under anoter URL? There is a download data button on the ^GSPC and the URL target says: http://download.finance.yahoo.com/d/quotes.csv?s=^GSPC&f=sl1d1t1c1ohgv&e=.csv

Should I try this URL in your provided code above?

Also do you know the syntax of other sites like MSN money or digitallook.com for downloads similar to what you provided for yahoo?

Thanking you in advance - and thanks again for the macro - it has save me countless hours of data input.

 

[jjbungles]

Re: WinHttp.WinHttpRequest or Microsoft.XMLHTTP?

Here's an update. I found a solution to getting the historical data for ^DJI and EURUSD=X symbols from yahoo finance. It seems that DIYTraders.com has a historical macro (similar to Tom's above) that downloads the data to a separate file (and I need in on the same worksheet - HELP Please?). As I look at Tom's Macro above and compare it to the DIYTraders.com Macro they used different methods for getting what I think is a CSV file.

Tom uses WinHttp.WinHttpRequest
DIYTraders uses Microsoft.XMLHTTP

Being an absolute novice, I have tried to find out what each of these(object/method/function/property?) are, how they work and why/when to use them.

As the Microsoft.XMLHTTP seems to work for all the tickers Yahoo finance supports, how do I modify Toms code above to include this alternate method yet write the results in the same worksheet like Tom's does?

Please forgive my ignorance but I have trolled the web/VBA help files etc. for days to understand whats going on. If any one can help or point me in the right direction that would be great. I got confused because I believe that yahoo finance is providing a csv file, yet both macros go to great lengths to reparse the data and get it into excel. The DIYTraders.com macro seems to ask for a table.csv, put it into a .txt file then transpose to a .csv then to an .xls file. This confuses me. Can anyone explain this?

I have included the download Sub below from DIY.Traders.com so you can compare.

(With hat in hand...) Can anyone please help me?

Sub Download()
Set occXMLHTTP = CreateObject("Microsoft.XMLHTTP")
Set fso = CreateObject("Scripting.FileSystemObject")
DIY_Dir = "c:\DIYTraders\"
DIYSub_Dir = "c:\DIYTraders\tickers\"
 
If Not fso.FolderExists(DIY_Dir) Then
    MkDir DIY_Dir
End If
 
If Not fso.FolderExists(DIYSub_Dir) Then
    MkDir DIYSub_Dir
End If
Check_Date
PFROW = 1
Do Until Worksheets("Portfolio").Cells(PFROW, 1) = ""
    PFROW = PFROW + 1
Loop
PFROW = PFROW - 1
For x = 1 To PFROW
    fn = Worksheets("Portfolio").Cells(x, 1)
    fname = Worksheets("Portfolio").Cells(x, 1) & ".txt"
    occXLS = DIYSub_Dir & fname
    'occUrl = "http://ichart.finance.yahoo.com/table.csv?s=" & Worksheets("Portfolio").Cells(x, 1) & "&d=" & EM & "&e=" & ED & "&f=" & EY & "&g=d&a=2&b=7&c=2002"
    occUrl = "http://ichart.finance.yahoo.com/table.csv?s=" & Trim(Worksheets("Portfolio").Cells(x, 1)) & _
    "&d=" & SM & "&e=" & SD & "&f=" & SY_2 & "&g=d&a=" & SM & "&b=" & SD & "&c=" & SY
    occLocalFile = DIYSub_Dir & fname
    occLocalFileName = Worksheets("Portfolio").Cells(x, 1) & ".txt"
 
    occXMLHTTP.Open "GET", occUrl, False
    occXMLHTTP.send
    occArray = occXMLHTTP.ResponseBody
    occfile = 1
 
    Open occLocalFile For Binary As #occfile
    Put #occfile, , occArray
    Close #occfile
 
    RemoveLine
Next
Response = MsgBox _
("Download Completed." & vbCrLf & _
"Open C:\DIYTraders\Tickers to view files ?", vbYesNo)
If Response = vbYes Then
    RetVal = Shell("explorer " & DIYSub_Dir, 1)
End If
End Sub
Sub RemoveLine()
  Set oFSO = CreateObject("Scripting.FileSystemObject")
  fname_path = DIYSub_Dir & fname
  DeleteLine = 1
  sTemp = "Date,Open,High,Low,Close,Volume,Adj Close" & vbCrLf
 
  On Error Resume Next
  If oFSO.FileExists(fname_path) Then
     Set oFSTR = oFSO.OpenTextFile(fname_path)
    lCtr = 1
     Do While Not oFSTR.AtEndOfStream
        sLine = oFSTR.ReadLine
        If lCtr <> DeleteLine Then
            sTemp = sTemp & sLine & vbCrLf
        Else
            bLineFound = True
        End If
        lCtr = lCtr + 1
    Loop
 
     oFSTR.Close
     Set oFSTR = oFSO.CreateTextFile(fname_path, True)
     oFSTR.Write sTemp
   End If
oFSTR.Close
Set oFSTR = Nothing
oFSO.MoveFile fname_path, DIYSub_Dir & fn & ".csv"
Remove_Column
oFSO.DeleteFile DIYSub_Dir & fn & ".csv"
Set oFSO = Nothing
End Sub
Sub Remove_Column()
 
    fn1 = fn & ".csv"
    fn2 = fn & ".xls"
    RV = DIYSub_Dir & fn & ".csv"
 
    Workbooks.Open RV
    Set rv1 = Workbooks(fn1).Sheets(fn)
    currRow = 1
    Do
        currRow = currRow + 1
    Loop While rv1.Cells(currRow, 1).Value <> ""
 
    currRow = currRow - 1
 
    rv1.Columns("G:G").Select
    Selection.Delete Shift:=xlToLeft
 
    If asc.Value = True Then
        rv1.Range("A1:F" & currRow & "").Select
        Selection.Sort Key1:=rv1.Range("A1:F" & currRow & ""), Order1:=xlDescending, Header:= _
            xlYes, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
    End If
 
    Application.DisplayAlerts = False
    Workbooks(fn1).SaveAs Filename:=DIYSub_Dir & fn & ".xls", FileFormat:=xlNormal
    Workbooks(fn2).Close True
End Sub
Sub Check_Date()
    SD = Day(Now)
    SM = Month(Now) - 1
    SY = Year(Now)
    SY_2 = Year(Now)
 
    If y1.Value = True Then
        SY = SY - 1
    ElseIf y2.Value = True Then
        SY = SY - 2
    ElseIf y3.Value = True Then
        SY = SY - 3
    ElseIf y5.Value = True Then
        SY = SY - 5
    ElseIf y10.Value = True Then
        SY = SY - 10
    ElseIf y20.Value = True Then
        SY = SY - 20
    Else
        SY = SY - 1
        y1.Value = True
    End If
End Sub
Private Sub help_1_Click()
    Help.Show
End Sub
Private Sub y1_Click()
    Select Case y1.Value
    Case True
        y2.Value = False
        y3.Value = False
        y5.Value = False
        y10.Value = False
        y20.Value = False
    End Select
End Sub
Private Sub y2_Click()
    Select Case y2.Value
    Case True
        y1.Value = False
        y3.Value = False
        y5.Value = False
        y10.Value = False
        y20.Value = False
    End Select
End Sub
Private Sub y3_Click()
    Select Case y3.Value
    Case True
        y1.Value = False
        y2.Value = False
        y5.Value = False
        y10.Value = False
        y20.Value = False
    End Select
End Sub
Private Sub y5_Click()
    Select Case y5.Value
    Case True
        y1.Value = False
        y2.Value = False
        y3.Value = False
        y10.Value = False
        y20.Value = False
    End Select
End Sub
Private Sub y10_Click()
    Select Case y10.Value
    Case True
        y1.Value = False
        y2.Value = False
        y3.Value = False
        y5.Value = False
        y20.Value = False
    End Select
End Sub
Private Sub y20_Click()
    Select Case y20.Value
    Case True
        y1.Value = False
        y2.Value = False
        y3.Value = False
        y5.Value = False
        y10.Value = False
    End Select
End Sub
Private Sub asc_Click()
    Select Case asc.Value
    Case True
        desc.Value = False
    Case False
        desc.Value = True
    End Select
End Sub
Private Sub desc_Click()
    Select Case desc.Value
    Case True
        asc.Value = False
    Case False
        asc.Value = True
    End Select
End Sub
Private Sub CommandButton1_Click()
    Sheet1.Download
End Sub