'********************************************************************
' http://www.KravatzInc.com 1-866-XLS-PROG
'
' This code is copyrighted by Kravatz, Inc. (c) 2007 All Rights Reserved.
' You may use this code as long as this message appears
' There is no warranty made to the fitness or suitablilty of this code
' and by using it you hold Kravatz, Inc. harmless for any damages
' that may result from its use. This code is supplied as is.
'
'********************************************************************
Function GetYahoosDaysHeadlines()
Dim sfile As String, lPos As Long
Dim sNews As String
Dim sStory As String
Dim s As String
Dim r As Long, i As Long
On Error GoTo 0
sfile = "http://finance.yahoo.com/"
Workbooks.Open Filename:=sfile, UpdateLinks:=0 '@ should use the real file
On Error Resume Next
If Err <> 0 Then
GetYahoosDaysHeadlines = "#N/A"
End If
r = FindLastRow(1)
For i = 1 To r
lPos = 0
On Error Resume Next
lPos = InStr(Cells(i, 1).Hyperlinks(1).Name, "topnews") + & _
InStr(Cells(i, 1).Hyperlinks(1).Name, "topstories")
If lPos > 0 Then
sStory = Cells(i, 1).Hyperlinks(1).TextToDisplay
If Right(sStory, 2) = "AP" Then
sStory = Left(sStory, Len(sStory) - 2)
End If
If InStr(sStory, "More Top") > 0 Then
sStory = ""
End If
sNews = sNews & sStory & vbCrLf
'GoTo exit_it
End If
Next
GetYahoosDaysHeadlines = sNews
'price = ActiveSheet.HTMLText12
exit_it:
ActiveWorkbook.Close
End Function
|
