' ******************************************************************************
' **
' ** Yahoo Finance Managed
' ** Written by Marius Häusler 2010
' ** It would be pleasant, if you contact me when you are using this code.
' ** Contact: YahooFinanceManaged@gmail.com
' ** Project Home: http://code.google.com/p/yahoo-finance-managed/
' **
' ******************************************************************************
' **
' ** Copyright 2010 Marius Häusler
' **
' ** Licensed under the Apache License, Version 2.0 (the "License");
' ** you may not use this file except in compliance with the License.
' ** You may obtain a copy of the License at
' **
' ** http://www.apache.org/licenses/LICENSE-2.0
' **
' ** Unless required by applicable law or agreed to in writing, software
' ** distributed under the License is distributed on an "AS IS" BASIS,
' ** WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
' ** See the License for the specific language governing permissions and
' ** limitations under the License.
' **
' ******************************************************************************
Imports System.Text.RegularExpressions
Namespace Finance.NonAPI
''' <summary>
''' Downloads lists of Yahoo IDs for different countries in alphabetical order
''' </summary>
''' <remarks></remarks>
Public Class IDListDownload
Inherits Base.DataDownload
''' <summary>
''' Raises if an asynchronous download of list ranges completes
''' </summary>
''' <param name="sender">The event raising object</param>
''' <param name="ea">The results of the asynchronous download</param>
''' <remarks></remarks>
Public Event AsyncDownloadIDListRangeCompleted(ByVal sender As Base.Download, ByVal ea As IDListRangeDownloadCompletedEventArgs)
''' <summary>
''' Raises if an asynchronous download of list subranges completes
''' </summary>
''' <param name="sender">The event raising object</param>
''' <param name="ea">The results of the asynchronous download</param>
''' <remarks></remarks>
Public Event AsyncDownloadIDListSubRangeCompleted(ByVal sender As Base.Download, ByVal ea As IDListSubRangeDownloadCompletedEventArgs)
''' <summary>
''' Raises when an asynchronous download a company list completes
''' </summary>
''' <param name="sender">The event raising object</param>
''' <param name="ea">The results of the asynchronous download</param>
''' <remarks></remarks>
Public Event AsyncDownloadCompanyListCompleted(ByVal sender As Base.Download, ByVal ea As API.IDSearchDownloadCompletedEventArgs)
''' <summary>
''' Downloads the alphabetical list ranges of all US companies and funds
''' </summary>
''' <returns></returns>
''' <remarks>Uses Server.USA as server</remarks>
Public Function DownloadListRangeUSA() As IDListRangeResponse
Dim url As String = Me.RangeDownloadURL(Country.USA, Server.USA)
Return Me.ToRangeResponse(MyBase.Download(url), url, Server.USA)
End Function
''' <summary>
''' Starts an asynchronous download of the alphabetical list ranges of all US companies and funds
''' </summary>
''' <param name="userArgs"></param>
''' <remarks>Uses Server.USA as server</remarks>
Public Sub DownloadListRangeUSAAsync(Optional ByVal userArgs As Object = Nothing)
Dim url As String = "http://biz.yahoo.com/i/"
MyBase.DownloadAsync(url, New AsyncDownloadArgs(userArgs) With {.URL = url, .Server = Server.USA, .Type = AlphabeticalDownloadReturnType.ListRange})
End Sub
''' <summary>
''' Downloads the alphabetical list ranges of companies of a special country and server
''' </summary>
''' <param name="country">The country of the companies in the list. Allowed countries are [Denmark];[France];[Germany];[Italy];[Norway];[Spain];[Sweden];[UK];[USA]. For other countries an exception will be raised.</param>
''' <param name="server">The used server for downloading. Allowed servers are [France];[Germany];[Italy];[Spain];[UK];[USA]. For other servers an exception will be raised.</param>
''' <returns></returns>
''' <remarks>If server is [USA], country parameter will be ignored.</remarks>
Public Function DownloadListRange(ByVal country As Country, ByVal server As Server) As IDListRangeResponse
Dim url As String = Me.RangeDownloadURL(country, server)
Return Me.ToRangeResponse(MyBase.Download(url), url, server)
End Function
''' <summary>
''' Starts an asynchronous download of the alphabetical list ranges of companies of a special country and server
''' </summary>
''' <param name="country">The country of the companies in the list</param>
''' <param name="server">The used server for downloading</param>
''' <param name="userArgs">Individual user args</param>
''' <remarks>Allowed countries are [Denmark];[France];[Germany];[Italy];[Norway];[Spain];[Sweden];[UK];[USA]. For other countries an exception will be raised.</remarks>
Public Sub DownloadListRangeAsync(ByVal country As Country, ByVal server As Server, Optional ByVal userArgs As Object = Nothing)
Dim url As String = Me.RangeDownloadURL(country, server)
MyBase.DownloadAsync(url, New AsyncDownloadArgs(userArgs) With {.URL = url, .Server = server, .Type = AlphabeticalDownloadReturnType.ListRange})
End Sub
''' <summary>
''' Downloads the alphabetical list sub ranges of a downloaded list range
''' </summary>
''' <param name="range">The downloaded range</param>
''' <returns></returns>
''' <remarks></remarks>
Public Function DownloadListSubRange(ByVal range As IDListRangeData) As IDListSubRangeResponse
Return Me.ToSubRangeResponse(MyBase.Download(range.Link), range.Link, range.Server)
End Function
''' <summary>
''' Starts an asynchronous download of list sub ranges of a downloaded list range
''' </summary>
''' <param name="range">The downloaded range</param>
''' <param name="userArgs">Individual user args</param>
''' <remarks></remarks>
Public Sub DownloadListSubRangeAsync(ByVal range As IDListRangeData, Optional ByVal userArgs As Object = Nothing)
MyBase.DownloadAsync(range.Link, New AsyncDownloadArgs(userArgs) With {.URL = range.Link, .Server = range.Server, .Type = AlphabeticalDownloadReturnType.SubRange})
End Sub
''' <summary>
''' Downloads the alphabetical company list of a downloaded list subrange
''' </summary>
''' <param name="subRange">The downloaded subrange</param>
''' <returns></returns>
''' <remarks></remarks>
Public Function DownloadCompanyList(ByVal subRange As IDListSubRangeData) As API.IDSearchResponse
Return Me.ToCompanyResponse(MyBase.Download(subRange.Link))
End Function
''' <summary>
''' Starts an asynchronous download of the alphabetical company list of a downloaded list subrange
''' </summary>
''' <param name="subRange">The downloaded subrange</param>
''' <param name="userArgs">Individual user args</param>
''' <remarks></remarks>
Public Sub DownloadCompanyListAsync(ByVal subRange As IDListSubRangeData, Optional ByVal userArgs As Object = Nothing)
MyBase.DownloadAsync(subRange.Link, New AsyncDownloadArgs(userArgs) With {.URL = subRange.Link, .Server = subRange.Server, .Type = AlphabeticalDownloadReturnType.CompanyList})
End Sub
''' <summary>
''' Default constructor
''' </summary>
''' <remarks></remarks>
Public Sub New()
End Sub
Private Sub DownloadAsync_Completed(ByVal sender As Base.Download, ByVal ba As Base.DataDownloadCompletedEventArgs) Handles MyBase.AsyncDataBaseDownloadCompleted
If ba IsNot Nothing AndAlso ba.UserArgs IsNot Nothing AndAlso TypeOf ba.UserArgs Is AsyncDownloadArgs Then
Dim dlArgs As AsyncDownloadArgs = DirectCast(ba.UserArgs, AsyncDownloadArgs)
Select Case dlArgs.Type
Case AlphabeticalDownloadReturnType.ListRange
RaiseEvent AsyncDownloadIDListRangeCompleted(Me, New IDListRangeDownloadCompletedEventArgs(dlArgs.UserArgs, Me.ToRangeResponse(ba.Response, dlArgs.URL, dlArgs.Server), dlArgs.Server))
Case AlphabeticalDownloadReturnType.SubRange
RaiseEvent AsyncDownloadIDListSubRangeCompleted(Me, New IDListSubRangeDownloadCompletedEventArgs(dlArgs.UserArgs, Me.ToSubRangeResponse(ba.Response, dlArgs.URL, dlArgs.Server), dlArgs.Server))
Case AlphabeticalDownloadReturnType.CompanyList
RaiseEvent AsyncDownloadCompanyListCompleted(Me, New API.IDSearchDownloadCompletedEventArgs(dlArgs.UserArgs, Me.ToCompanyResponse(ba.Response), "", IDSearchServer.DefaultUS))
End Select
End If
End Sub
Private Function RangeDownloadURL(ByVal country As Country, ByVal server As Server) As String
Dim url As New Text.StringBuilder
url.Append(AtoZDownloadURL(server))
If server <> server.USA Then
url.Append("/p/")
Select Case country
Case country.Germany : url.Append("de")
Case country.Denmark : url.Append("dk")
Case country.Spain : url.Append("es")
Case country.France : url.Append("fr")
Case country.Italy : url.Append("it")
Case country.Norway : url.Append("no")
Case country.Sweden : url.Append("se")
Case country.UK : url.Append("uk")
Case country.USA : url.Append("us")
Case Else : Throw New NotSupportedException("The passed country will not be supported. Available countries: [Denmark];[France];[Germany];[Italy];[Norway];[Spain];[Sweden];[UK];[USA]")
End Select
url.Append("/cpi/index.html")
Else
url.Append("/i/")
End If
Return url.ToString
End Function
Private Function AtoZDownloadURL(ByVal server As Server) As String
Dim url As String = "http://"
If server = server.France Or server = server.Germany Or server = server.Italy Or server = server.Spain Or server = server.UK Then
url &= mHelper.ServerString(server)
ElseIf server <> server.USA Then
Throw New NotSupportedException("The passed server will not be supported. Available servers: [France];[Germany];[Italy];[Spain];[UK];[USA]")
End If
Return url & "biz.yahoo.com"
End Function
Private Function ToRangeResponse(ByVal resp As Base.DataResponse, ByVal sourceURL As String, ByVal server As Server) As IDListRangeResponse
Dim lst As New List(Of IDListRangeData)
Dim match As Match = Regex.Match(resp.Result.Replace(Chr(10), ""), "<table( style=""font-family: arial""|cellpadding=0cellspacing=1)><tr>.*?</tr></table>")
If match.Success Then
Dim cells As MatchCollection = Regex.Matches(match.Value, "<td(>|nowrap>).*?</td>")
If cells.Count > 0 Then
Dim linkReg As New Regex("<(ahref=.*?>|a href="".*?"">|<b>)(.|1-9)(</a>|</b>)")
Dim valueReg As New Regex(">(.|1-9)<")
For Each cell As Match In cells
If cell.Success Then
Dim link As Match = linkReg.Match(cell.Value)
If link.Success Then
Dim value As String = valueReg.Match(link.Value).Value.Replace(">", "").Replace("<", "")
Dim linkStr As String = GetHtmlLink(link.Value)
If linkStr <> String.Empty Then
linkStr = Me.AtoZDownloadURL(server) & linkStr
ElseIf link.Value.StartsWith("<b>") Then
linkStr = sourceURL
End If
If linkStr <> String.Empty Then lst.Add(New IDListRangeData(value, linkStr, server))
End If
End If
Next
End If
End If
Return New IDListRangeResponse(resp.Connection, lst.ToArray)
End Function
Private Function ToSubRangeResponse(ByVal resp As Base.DataResponse, ByVal sourceURL As String, ByVal server As Server) As IDListSubRangeResponse
Dim lst As New List(Of IDListSubRangeData)
Dim tablePattern1 As String = ""
Dim tablePattern2 As String = ""
Dim match As Match
If server = server.USA Then
match = Regex.Match(resp.Result.Replace(Chr(10), ""), "<tableborder=0><tralign=center><td><tablecellpadding=0cellspacing=1><tr>.*?</tr></table></td></tr></table>")
If Not match.Success Then
match = Regex.Match(resp.Result.Replace(Chr(10), ""), "</table><p><tablecellpadding=0cellspacing=1><tr>.*?</tr></table>")
End If
Else
match = Regex.Match(resp.Result.Replace(Chr(10), ""), "<table><tr align=center><td>.*?</td></tr></table>")
End If
If match.Success Then
Dim tables As MatchCollection
If server = server.USA Then
tables = Regex.Matches(match.Value, "<tralign=center><td><tablecellpadding=0cellspacing=1><tr>.*?</tr></table></td></tr>")
Else
tables = Regex.Matches(match.Value, "<table cellspacing=5 style=""font-family: arial""><tr><td>.*?</td></tr></table>")
End If
If tables.Count > 0 Then
Dim rowReg As New Regex("<td(>|nowrap>| bgcolor=.*?>|nowrapbgcolor=.*?>|nowrapbgcolor=.*?>).*?</td>")
Dim rawReg As New Regex("(>.*?</a>|<b>.*?</b>| .*? )")
Dim linkReg As New Regex("<a.?href=.*?>")
For Each t As Match In tables
If t.Success Then
Dim rows As MatchCollection = rowReg.Matches(t.Value)
If rows.Count > 0 Then
For Each r As Match In rows
If Not r.Value.IndexOf("|"c) > -1 AndAlso Not r.Value.IndexOf("["c) > -1 AndAlso Not r.Value.IndexOf("]"c) > -1 Then
Dim raw As Match = rawReg.Match(r.Value)
Dim url As String = GetHtmlLink(raw.Value)
Dim name As String = String.Empty
If server = server.USA Then
If raw.Value.IndexOf(" ") > -1 Then
name = raw.Value.Replace(" ", "")
Else
Dim replace As String = linkReg.Replace(raw.Value, "")
name = replace.Replace("</a>", "").Replace("<small>", "").Replace("</small>", "").Replace("</", "").Replace(">", "")
End If
Else
If raw.Value.IndexOf("<b>") > -1 Then
name = raw.Value.Replace("</b>", "").Replace("<b>", "")
Else
name = Regex.Match(linkReg.Replace(raw.Value, ""), ">?.*?</a>").Value.Replace("<small>", "").Replace("</small>", "").Replace("</a>", "").Replace("</", "").Replace(">", "")
End If
End If
If name <> String.Empty Then
If url <> String.Empty Then
url = Me.AtoZDownloadURL(server) & url
Else
url = sourceURL
End If
lst.Add(New IDListSubRangeData(name, url, server))
End If
End If
Next
End If
End If
Next
End If
Else
lst.Add(New IDListSubRangeData("All", sourceURL, server))
End If
Return New IDListSubRangeResponse(resp.Connection, lst.ToArray)
End Function
Private Function ToCompanyResponse(ByVal resp As Base.DataResponse) As API.IDSearchResponse
Dim lst As New List(Of IDSearchResult)
Dim tablePattern1 As String = " width=""752"" border=""0"" cellpadding=""3"" cellspacing=""1"" class=""yfnc_datamodoutline1"""
Dim tablePattern2 As String = " width=""100%"" border=0 cellspacing=0 cellpadding=3 style=""font-family: arial;font-size: 12px"""
Dim tablePattern3 As String = "width=100%border=0cellspacing=0cellpadding=3"
Dim match As Match = Regex.Match(resp.Result.Replace(Chr(10), ""), "<table(" & tablePattern1 & "|" & tablePattern2 & "|" & tablePattern3 & ")>.*?</table>")
If match.Success Then
Dim rows As MatchCollection = Regex.Matches(match.Value, "<tr(>| bgcolor=""#cccccc"">| class=""yfnc_tabledata1"">|bgcolor=EEEEEE>).*?</tr>")
If rows.Count > 0 Then
Dim cellReg As New Regex("<td.*?</td>")
Dim linkReg As New Regex("q\?s=.*?>")
For Each r As Match In rows
If Not r.Value.IndexOf("yfnc_tablehead1") > -1 Then
Dim mts As MatchCollection = cellReg.Matches(r.Value)
If mts.Count >= 4 Then
Dim name As String = mts(0).Value.Replace("<td>", "").Replace("</td>", "").Replace("<b>", "").Replace("</b>", "")
Dim wkn As String = mts(1).Value.Replace("<td align=left>", "").Replace("</td>", "")
Dim link As String = linkReg.Match(r.Value).Value
Dim id As String = link.Replace("""", "").Replace("q?s=", "").Replace(">", "").ToUpper
Dim exchange As String = String.Empty
Dim exc As Support.StockExchange = Support.WorldMarket.StockExchangeBySuffix(id)
If exc IsNot Nothing Then exchange = exc.ID.ToString
lst.Add(New IDSearchResult(name, id, "Stock", exchange, String.Empty, String.Empty, String.Empty))
End If
End If
Next
End If
End If
Return New API.IDSearchResponse(resp.Connection, lst.ToArray)
End Function
Private Function GetHtmlLink(ByVal html As String) As String
If html.IndexOf("<a href=""") > -1 Then
Dim urlHtml As String = html.Substring(html.IndexOf("<a href="""))
Dim firstIndex As Integer = urlHtml.IndexOf(""""c) + 1
Dim lastIndex As Integer = urlHtml.LastIndexOf(""""c)
Return urlHtml.Substring(firstIndex, lastIndex - firstIndex)
ElseIf html.IndexOf("<ahref=") > -1 Then
Dim urlHtml As String = html.Substring(html.IndexOf("<ahref="))
Dim firstIndex As Integer = urlHtml.IndexOf("="c) + 1
Dim lastIndex As Integer = urlHtml.IndexOf(">"c)
Return urlHtml.Substring(firstIndex, lastIndex - firstIndex)
Else
Return String.Empty
End If
End Function
Private Class AsyncDownloadArgs
Inherits Base.DownloadEventArgs
Public Type As AlphabeticalDownloadReturnType
Public URL As String
Public Server As Server
Public Sub New(ByVal userArgs As Object)
MyBase.New(userArgs)
End Sub
End Class
Private Enum AlphabeticalDownloadReturnType
ListRange
SubRange
CompanyList
End Enum
End Class
Public Class IDListDownloadCompletedEventArgs
Inherits Base.DownloadCompletedEventArgs
Private mServer As Server
Public ReadOnly Property Server() As Server
Get
Return mServer
End Get
End Property
Friend Sub New(ByVal userArgs As Object, ByVal resp As Base.Response, ByVal srv As Server)
MyBase.New(userArgs, resp)
mServer = srv
End Sub
End Class
''' <summary>
''' Stores the available alphabetical ranges of a list of companies
''' </summary>
''' <remarks></remarks>
Public Class IDListRangeDownloadCompletedEventArgs
Inherits IDListDownloadCompletedEventArgs
Public Overloads ReadOnly Property Response() As IDListRangeResponse
Get
Return TryCast(MyBase.Response, IDListRangeResponse)
End Get
End Property
Friend Sub New(ByVal userArgs As Object, ByVal resp As IDListRangeResponse, ByVal srv As Server)
MyBase.New(userArgs, resp, srv)
End Sub
End Class
Public Class IDListRangeResponse
Inherits Base.Response
Private mServer As Server
Public ReadOnly Property Server() As Server
Get
Return mServer
End Get
End Property
Public Overloads ReadOnly Property Result() As IDListRangeData()
Get
Return TryCast(MyBase.Result, IDListRangeData())
End Get
End Property
Friend Sub New(ByVal info As Base.ConnectionInfo, ByVal result As IDListRangeData())
MyBase.New(info, result)
End Sub
End Class
''' <summary>
''' Stores the available alphabetical subranges of a list of companies
''' </summary>
''' <remarks>e.g. ["Aa-Ad","Be-Bo","All"]</remarks>
Public Class IDListSubRangeDownloadCompletedEventArgs
Inherits IDListDownloadCompletedEventArgs
Public Overloads ReadOnly Property Response() As IDListSubRangeResponse
Get
Return TryCast(MyBase.Response, IDListSubRangeResponse)
End Get
End Property
Friend Sub New(ByVal userArgs As Object, ByVal resp As IDListSubRangeResponse, ByVal srv As Server)
MyBase.New(userArgs, resp, srv)
End Sub
End Class
Public Class IDListSubRangeResponse
Inherits Base.Response
Public Overloads ReadOnly Property Result() As IDListSubRangeData()
Get
Return TryCast(MyBase.Result, IDListSubRangeData())
End Get
End Property
Friend Sub New(ByVal info As Base.ConnectionInfo, ByVal result As IDListSubRangeData())
MyBase.New(info, result)
End Sub
End Class
End Namespace
Submit an article or tip