Builder.cz - Informacni server o programovani

Odběr fotomagazínu

Fotografický magazín "iZIN IDIF" každý týden ve Vašem e-mailu.
Co nového ve světě fotografie!

 

Zadejte Vaši e-mailovou adresu:

Kamarád fotí rád?

Přihlas ho k odběru fotomagazínu!

 

Zadejte e-mailovou adresu kamaráda:



VB6 - data z Webu

Seznam témat     Nová odpověď

Přihlásit se     Registrace     Zapomenuté heslo

Re: VB6 - data z Webu

Autor: Gábina ♀

10:59:45 18.07.2012

Prázdný formulář Form1, nakopírovat kód, bude-li možné :

Imports System.Text
Imports System.Text.RegularExpressions
Imports System.Net
Imports System.Drawing
Imports System.IO
Imports System.Windows.Forms

Public Class Form1
Dim tc As TabControl
Dim ds As System.Data.DataSet
Dim tt As New ToolTip

Public Sub New()
' This call is required by the Windows Form Designer.
InitializeComponent()
' Add any initialization after the InitializeComponent() call.
Me.Text = "F1 Teams And Driwers"
Dim pnl As Panel
pnl = New Panel
pnl.Dock = DockStyle.Bottom
Me.Controls.Add(pnl)

Dim lnklbl As LinkLabel

lnklbl = New LinkLabel
lnklbl.Name = "lnklbl1"
lnklbl.Text = "Show WebBrowser Tab"
lnklbl.Top = 3
AddHandler lnklbl.LinkClicked, AddressOf lnklbl_LinkClicked
pnl.Controls.Add(lnklbl)
pnl.Height = lnklbl.Height


lnklbl = New LinkLabel
lnklbl.Name = "lnklbl2"
lnklbl.Left = pnl.Controls(0).Width
lnklbl.Text = "Show HTML Tab"
lnklbl.Top = 3
AddHandler lnklbl.LinkClicked, AddressOf lnklbl_LinkClicked
pnl.Controls.Add(lnklbl)

lnklbl = New LinkLabel
lnklbl.Name = "lnklbl3"
lnklbl.Left = pnl.Controls(1).Left + pnl.Controls(1).Width
lnklbl.Text = "Load Html Tables"
lnklbl.Top = 3
AddHandler lnklbl.LinkClicked, AddressOf lnklbl_LinkClicked
pnl.Controls.Add(lnklbl)

tc = New TabControl
tc.Size = New Size(Me.ClientSize.Width, Me.ClientSize.Height - pnl.Height)
tc.Anchor = AnchorStyles.Left + AnchorStyles.Right + AnchorStyles.Bottom + AnchorStyles.Top
AddHandler tc.SelectedIndexChanged, AddressOf tc_SelectedIndexChanged
Me.Controls.Add(tc)
End Sub

'Dowmload html web page: http://www.digitalcoding.com/Code-Snippets/VB/Visual-Basic-Code-Snippet-Download-HTML-Web-Page.html
Private Function DownloadPageHTMLContent(ByVal URL As String) As String
Dim pageContent As String = Nothing
Try
' Open a connection .
Dim request As HttpWebRequest = _
CType(HttpWebRequest.Create(URL), HttpWebRequest)
' set timeout for 10 seconds (Optional)
request.Timeout = 10000
' Request response:
Dim response As WebResponse = request.GetResponse()
' Open data stream: .
Dim remoteStream As Stream = response.GetResponseStream()
' Create reader object:
Dim readStream As New StreamReader(remoteStream)
' Read the entire stream content:
pageContent = readStream.ReadToEnd()
' Cleanup .
readStream.Close()
remoteStream.Close()
response.Close()
Return pageContent
Catch _Exception As Exception
' Error
MsgBox(Format(_Exception.ToString(), "Exception caught in process: {0}"))
Return Nothing
End Try
End Function

'ImageToByte: http://www.a1vbcode.com/snippet-4642.asp
Private Function ImageToByte(ByVal img As Image) As Byte()
Dim imgStream As MemoryStream = New MemoryStream()
img.Save(imgStream, Imaging.ImageFormat.Jpeg)
imgStream.Close()
Dim byteArray As Byte() = imgStream.ToArray()
imgStream.Dispose()
Return byteArray
End Function

Private Function ByteToImage(ByVal ByteArray As Byte()) As Image
Dim imgStream As MemoryStream
imgStream = New MemoryStream(ByteArray)
Dim img As Image = Image.FromStream(imgStream)
imgStream.Close()
imgStream.Dispose()
Return img
End Function

'Add image column into datatable: http://www.vbforums.com/archive/index.php/t-443692.html
'Get image by url: http://mxdev.blogspot.cz/2008/12/get-image-by-url-net-aspnet.html
Private Function GetImageByUrl(ByVal url As String) As Image
Try
Dim request As WebRequest = WebRequest.Create(url)
Dim response As WebResponse = request.GetResponse()
Dim remoteStream As Stream = response.GetResponseStream()
Dim readStream As StreamReader = New StreamReader(remoteStream)
Dim img As Image = Image.FromStream(remoteStream)
readStream.Close()
remoteStream.Close()
response.Close()
Return img
Catch _Exception As Exception
MsgBox(Format(_Exception.ToString(), "Exception caught in process: {0}"))
Return Nothing
End Try
End Function

'Read html tables to dataset: http://www.eggheadcafe.com/community/vb/14/10295083/read-tables-in-html-file-to-dataset-.aspx
Private Function ConvertHTMLTablesToDataSet(ByVal HTML As String) As System.Data.DataSet
Dim ds As New System.Data.DataSet
Dim dt As System.Data.DataTable
Dim dr As System.Data.DataRow
'Dim dc As System.Data.DataColumn
Dim TableExpression As String = "<table[^>]*>(.*?)</table>"
Dim TableBodyExpression As String = "<tbody[^>]*>(.*?)</tbody>"
Dim HeaderExpression As String = "<th[^>]*>(.*?)</th>"
Dim RowExpression As String = "<tr[^>]*>(.*?)</tr>"
Dim ColumnExpression As String = "<td[^>]*>(.*?)</td>"
Dim HeadersExist As Boolean = False
Dim StrongHeadersExist As Boolean = False
Dim iCurrentColumn As Integer = 0
Dim iCurrentRow As Integer = 0
Dim strongS As String = "<strong>"
Dim strongE As String = "</strong>"

' Get a match for all the tables in the HTML
Dim Tables As MatchCollection = _
Regex.Matches(HTML, TableExpression, RegexOptions.Multiline _
Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
' Loop through each table element
For Each Table As Match In Tables
'Debug.Print(Table.Groups(0).ToString)
If Table.Groups(0).ToString.Contains("<tbody>") Then
' Reset the current row counter and the header flag
iCurrentRow = 0
HeadersExist = False
' Add a new table to the DataSet
dt = New System.Data.DataTable
' Create the relevant amount of columns for this table
If Table.Value.Contains("<th") Then
' Set the HeadersExist flag
HeadersExist = True
' Get a match for all the rows in the table
Dim Headers As MatchCollection = _
Regex.Matches(Table.Value, HeaderExpression, _
RegexOptions.Multiline Or RegexOptions.Singleline _
Or RegexOptions.IgnoreCase)
' Loop through each header element
For Each Header As Match In Headers
dt.Columns.Add(Header.Groups(1).ToString)
Next
Else
For iColumns As Integer = 1 To Regex.Matches(Regex.Matches(Regex.Matches(Table.Value, TableExpression, _
RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase).Item(0).ToString, _
RowExpression, RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase).Item(0).ToString, _
ColumnExpression, RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase).Count
dt.Columns.Add("Column " & iColumns)
Next
End If
' Get a match for all the rows in the table
Dim Rows As MatchCollection = Regex.Matches(Table.Value, RowExpression, RegexOptions.Multiline _
Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
' Loop through each row element
For Each Row As Match In Rows
' Only loop through the row if it isn't a header row
If Not (iCurrentRow = 0 And HeadersExist = True) Then
iCurrentColumn = 0
' Get a match for all the columns in the row
Dim Columns As MatchCollection = Regex.Matches(Row.Value, ColumnExpression, RegexOptions.Multiline _
Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
StrongHeadersExist = True
If Not (iCurrentRow = 0 And Columns.Item(0).Groups(1).ToString.Contains(strongS)) Then
' Create a new row and reset the current column counter
dr = dt.NewRow
StrongHeadersExist = False
End If
' Loop through each column element
For Each Column As Match In Columns
' Add the value to the DataRow
Dim colValue
If Column.Groups(1).ToString.Contains(strongS) Then
colValue = Column.Groups(1).ToString.Substring(Column.Groups(1).ToString.IndexOf(strongS) + strongS.Length)
colValue = colValue.Substring(0, colValue.IndexOf(strongE))
Else
colValue = Column.Groups(1).ToString
End If
If Not (iCurrentRow = 0 And StrongHeadersExist = True) Then
If Not (dt.Columns.Count > iCurrentColumn) Then dt.Columns.Add("Column " & (dt.Columns.Count + 1))

Dim iVal As Integer
Integer.TryParse(colValue, iVal)
dr(iCurrentColumn) = IIf(dt.Columns(iCurrentColumn).DataType.Name = "String", colValue, iVal)
Else
dt.Columns(iCurrentColumn).ColumnName = colValue
If colValue = "P." Or colValue = "Body" Then
dt.Columns(iCurrentColumn).DataType = GetType(Integer)
End If
End If
' Increase the current column
iCurrentColumn += 1
Next
' Add the DataRow to the DataTable
If Not (iCurrentRow = 0 And StrongHeadersExist = True) Then dt.Rows.Add(dr)
End If
' Increase the current row counter
iCurrentRow += 1
Next
' Add the DataTable to the DataSet
ds.Tables.Add(dt)
End If 'contains body
Next
Return (ds)
End Function

Private Function ConvertHTMLTablesToDataTablePictures(ByVal HTML As String) As System.Data.DataTable
' Declarations
Dim dt As New System.Data.DataTable
Dim dr As System.Data.DataRow
'Dim dc As System.Data.DataColumn
Dim TableExpression As String = "<table[^>]*>(.*?)</table>"
Dim TableBodyExpression As String = "<tbody[^>]*>(.*?)</tbody>"
Dim HeaderExpression As String = "<th[^>]*>(.*?)</th>"
Dim RowExpression As String = "<tr[^>]*>(.*?)</tr>"
Dim ColumnExpression As String = "<td[^>]*>(.*?)</td>"
Dim HeadersExist As Boolean = False
Dim StrongHeadersExist As Boolean = False

Dim iCurrentColumn As Integer = 0
Dim iCurrentRow As Integer = 0
' Get a match for all the tables in the HTML
Dim Tables As MatchCollection = _
Regex.Matches(HTML, TableExpression, _
RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
' Loop through each table element
For Each Table As Match In Tables
Dim Bodies As MatchCollection = Regex.Matches(Table.Groups(0).ToString, TableBodyExpression, _
RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)

For Each Body As Match In Bodies
If Body.Groups(0).ToString Like "*img src=*http://racingsports.mfstatic.cz/assets/images/sezona_f1/jezdci/*.jpg*" Then
'Debug.Print(Body.Groups(0).ToString)
' Reset the current row counter and the header flag
iCurrentRow = 0
' Get a match for all the rows in the table
Dim Rows As MatchCollection = Regex.Matches(Body.Value, RowExpression, _
RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
' Loop through each row element
For Each Row As Match In Rows
' Get a match for all the columns in the row
Dim Columns As MatchCollection = Regex.Matches(Row.Value, ColumnExpression, _
RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
' Create a new row and reset the current column counter
dr = dt.NewRow
iCurrentColumn = 0
' Loop through each column element
For Each Column As Match In Columns
If Not (dt.Columns.Count > iCurrentColumn) Then dt.Columns.Add("Column " & (dt.Columns.Count + 1))
Dim colValue As String = Column.Groups(1).ToString
If colValue.Contains("a href=") And Not colValue Like ("*img*src=*") Then
If colValue.Contains("<strong>") Then
colValue = ParseExpression(Column.Value, "<strong[^>]*>(.*?)</strong>")
Else
colValue = ParseExpression(Column.Value, "[""""]>(.*?)<")
End If
ElseIf colValue.Contains("a href=") And colValue Like ("*img*src=*") Then
colValue = ParseExpression(Column.Value, "img.*src\s*=\s*(?:""(?<1>[^""]*)""|(?<1>\S+))")
End If
dr(iCurrentColumn) = colValue
' Increase the current column
iCurrentColumn += 1
Next
' Add the DataRow to the DataTable
dt.Rows.Add(dr)
' Increase the current row counter
iCurrentRow += 1
Next
End If 'body like img src
Next
Next
Return (dt)
End Function

Private Function ParseExpression(ByVal StringToParse As String, ByVal ByPattern As String) As String
Dim aMatchCol As MatchCollection = Regex.Matches(StringToParse, ByPattern, _
RegexOptions.Multiline Or RegexOptions.Singleline Or RegexOptions.IgnoreCase)
If aMatchCol.Count > 0 Then
Return aMatchCol.Item(0).Groups(1).ToString()
Else
Return StringToParse
End If
End Function

'Remove Diacritism: http://www.vbnet.cz/blog-clanek--163-net_tip_6_ciste_odstraneni_diakritiky.aspx
Private Function RemoveDiacritism(ByVal Text As String) As String
Dim stringFormD = Text.Normalize(NormalizationForm.FormD)
Dim retVal As New StringBuilder()
For index As Integer = 0 To stringFormD.Length - 1
If (System.Globalization.CharUnicodeInfo.GetUnicodeCategory(stringFormD(index)) _
<> Globalization.UnicodeCategory.NonSpacingMark) Then
retVal.Append(stringFormD(index))
End If
Next
Return retVal.ToString().Normalize(NormalizationForm.FormC)
End Function
Private Sub lnklbl_LinkClicked(ByVal sender As Object, ByVal e As LinkLabelLinkClickedEventArgs)
Dim ll As LinkLabel = DirectCast(sender, LinkLabel)
Select Case ll.Name
Case "lnklbl3"
Dim htmlWebContents As String = Nothing
'Read HTML contents from a web page
htmlWebContents = DownloadPageHTMLContent("http://f1sport.autorevue.cz/sezona")
If htmlWebContents IsNot Nothing Then
ds = ConvertHTMLTablesToDataSet(htmlWebContents)
End If
htmlWebContents = Nothing
htmlWebContents = DownloadPageHTMLContent("http://f1sport.autorevue.cz/jezdci")
Dim dt As System.Data.DataTable
If htmlWebContents IsNot Nothing Then
dt = ConvertHTMLTablesToDataTablePictures(htmlWebContents)
If dt IsNot Nothing Then
dt.Columns.Add("Pilot Image", GetType(Byte()))
dt.Columns.Add("Team Image", GetType(Byte()))
dt.Columns.Add("Pilot Key", Type.GetType("System.String"))
For Each r As System.Data.DataRow In dt.Rows
r.Item("Pilot Key") = RemoveDiacritism(r.Item(1).ToString)
Dim img As Image = GetImageByUrl(r.Item(0))
r.Item("Pilot Image") = ImageToByte(img)
img = GetImageByUrl(r.Item(3))
r.Item("Team Image") = ImageToByte(img)
Next
dt.TableName = "Pilot And Team Images"
ds.Tables.Add(dt)
End If
End If

For Each dt In ds.Tables
tc.TabPages.Add(dt.TableName, dt.TableName)
Dim tp As TabPage = tc.TabPages(dt.TableName)
Dim dgv As DataGridView = New DataGridView
With dgv
.AllowUserToAddRows = False
.ReadOnly = True
.SelectionMode = DataGridViewSelectionMode.FullRowSelect
.RowHeadersVisible = False
.MultiSelect = False
.Dock = DockStyle.Fill
.AutoSizeRowsMode = DataGridViewAutoSizeRowsMode.AllCells
.DataSource = dt
End With

For c As Integer = 0 To dt.Columns.Count - 1
If dt.Columns(c).ColumnName = "Jezdec" Then
tp.Tag = dt.Columns(c).ColumnName
Exit For
End If
Next

If tp.Tag IsNot Nothing Then
Dim splcnt1 As SplitContainer = New SplitContainer
splcnt1.Name = "splcnt1"
splcnt1.Orientation = Orientation.Vertical
splcnt1.Dock = DockStyle.Fill
tp.Controls.Add(splcnt1)

Dim splcnt2 As SplitContainer = New SplitContainer
splcnt2.Name = "splcnt2"
splcnt2.Orientation = Orientation.Horizontal

splcnt1.Panel1.Controls.Add(dgv)

splcnt1.Panel2.Controls.Add(splcnt2)
splcnt2.Dock = DockStyle.Fill

Dim lbl As Label, pb As PictureBox

lbl = New Label
lbl.Name = "lbl2"
lbl.AutoSize = False
lbl.TextAlign = ContentAlignment.MiddleLeft
lbl.BorderStyle = BorderStyle.FixedSingle
lbl.Dock = DockStyle.Top
lbl.BackColor = SystemColors.InactiveCaption

lbl.DataBindings.Add("Text", dt, "Tým")
splcnt2.Panel2.Controls.Add(lbl)

pb = New PictureBox
pb.Name = "pb2"
pb.Top = lbl.Height
pb.Anchor = AnchorStyles.Top + AnchorStyles.Left
pb.SizeMode = PictureBoxSizeMode.AutoSize
splcnt2.Panel2.Controls.Add(pb)



lbl = New Label
lbl.Name = "lbl1"
lbl.BorderStyle = BorderStyle.FixedSingle
lbl.AutoSize = False
lbl.TextAlign = ContentAlignment.MiddleLeft
lbl.Dock = DockStyle.Top
lbl.BackColor = SystemColors.InactiveCaption

tt.ShowAlways = True
AddHandler lbl.TextChanged, AddressOf lblJezdec_TextChanged
lbl.DataBindings.Add("Text", dt, "Jezdec")

pb = New PictureBox
pb.Name = "pb1"
pb.Top = lbl.Height
pb.Anchor = AnchorStyles.Top + AnchorStyles.Left
pb.SizeMode = PictureBoxSizeMode.AutoSize
splcnt2.Panel1.Controls.Add(pb)

splcnt2.Panel1.Controls.Add(lbl)
Else
tp.Controls.Add(dgv)
End If
Next
ll.Visible = False
Case "lnklbl2"

Dim tpHtml As TabPage, tb As TextBox
tpHtml = tc.TabPages("HTML Tab")
If tpHtml Is Nothing Then
tc.TabPages.Add("HTML Tab", "HTML Tab")
tpHtml = tc.TabPages("HTML Tab")
tb = New TextBox
tb.ReadOnly = True
tb.Multiline = True
tb.ScrollBars = ScrollBars.Both
tb.Dock = DockStyle.Fill
tpHtml.Controls.Add(tb)
Dim htmlWebContents As String = Nothing
'read HTML contents from a web page
htmlWebContents = DownloadPageHTMLContent("http://f1sport.autorevue.cz/sezona")
If htmlWebContents IsNot Nothing Then tb.Text = htmlWebContents
ll.Text = "Hide HTML Tab"
tc.SelectedTab = tpHtml
Else
tc.TabPages.Remove(tpHtml)
ll.Text = "Show HTML Tab"
End If
tpHtml = Nothing

Case "lnklbl1"

Dim tpwb As TabPage, wb As WebBrowser
tpwb = tc.TabPages("WebBrowser Tab")
If tpwb Is Nothing Then
tc.TabPages.Add("WebBrowser Tab", "WebBrowser Tab")
tpwb = tc.TabPages("WebBrowser Tab")
wb = New WebBrowser
tpwb.Controls.Add(wb)
wb.Dock = DockStyle.Fill
wb.Navigate("http://f1sport.autorevue.cz/sezona")
ll.Text = "Hide WebBrowser Tab"
tc.SelectedTab = tpwb
Else
wb = tpwb.Controls(0)
wb.Dispose()
tc.TabPages.Remove(tpwb)
ll.Text = "Show WebBrowser Tab"
End If
tpwb = Nothing
End Select
End Sub

Private Sub tc_SelectedIndexChanged(ByVal sender As Object, ByVal e As System.EventArgs)
If tc.TabCount = 0 Then Exit Sub
If tc.SelectedTab.Text = "Pilot And Team Images" Then
Dim dg As DataGridView = tc.SelectedTab.Controls(0)
If dg.Tag IsNot Nothing Then Exit Sub
Dim dgvic As DataGridViewImageColumn = dg.Columns("Team Image")
dgvic.ImageLayout = DataGridViewImageCellLayout.Zoom
dgvic = dg.Columns("Pilot Image")
dgvic.ImageLayout = DataGridViewImageCellLayout.Zoom
dg.Tag = "zoom was set"
End If
End Sub

Private Sub lblJezdec_TextChanged(ByVal sender As Object, ByVal e As System.EventArgs)
Dim lb As Label = DirectCast(sender, Label)
Dim splPanel As SplitterPanel = lb.Parent
Dim splContainer As SplitContainer = splPanel.Parent

Dim dt As System.Data.DataTable
dt = ds.Tables("Pilot And Team Images")

Dim expression As String = "[Pilot Key]" & " = '" & RemoveDiacritism(lb.Text.Trim) & "'"
Dim foundRows() As System.Data.DataRow = dt.Select(expression)

If foundRows.Length > 0 Then
Dim img As Image = ByteToImage(foundRows(0).Item("Pilot Image"))
Dim pb As PictureBox = splPanel.Controls("pb1")
pb.Image = img
tt.SetToolTip(pb, foundRows(0).Item(0).ToString)

img = ByteToImage(foundRows(0).Item("Team Image"))
pb = splContainer.Panel2.Controls("pb2")
pb.Image = img
tt.SetToolTip(pb, foundRows(0).Item(3).ToString)
End If

End Sub
End Class

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: Gábina ♀

10:29:28 18.07.2012

Zdar Petře (toonny),
snažím se najít příspěvek na obdobné téma s načítáním html tabulky F1 ve vb.net :
http://www.builder.cz/cz/forum/?19,3343543,3343543,quote=1
Link však není funkční, náhradou snad tento :
https://groups.google.com/forum/?fromgroups#!topic/buildercz/RkuvusCP5io

Zbyl mi kousek pokusného kódu a pokusím se ho sem vložit.

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: toonnyy

20:06:52 06.04.2011

Omlouvám se, už to funguje...vloudila se chybka, a to Like "Grand Prix*", byla před * tečka.

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: toonnyy

20:03:26 06.04.2011

Ahoj, prosím ještě jednou o pomoc. Z této stránky potřebuji také načíst tabulku, první kod od Gábi ale neumím upravit, nic nefunguje.Pomůže někdo? Moc dík
http://www.formula1.com/results/season/
V kodu jsem zaměnil adresu a pak .....Like "P.JezdecTýmBody*" za Like "Grand Prix*".

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: toonnyy

23:52:02 02.04.2011

Tak Gábi DÍKY, funguje, po malých úpravách kodu - tedy ten první.Jen sem myslel, že z toho kodu pochopim jak dál,jak třeba z oné stránky načíst další údaje,fotky atd., ale sem z toho "jelen", nic dalšího se mi nedaří.Ale i tak MOC DÍKY! toonnyy

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: toonnyy

14:58:21 01.04.2011

MOC všem díky!! Doufám, že to nějak spáchám dohromady.

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: Gábina

14:12:22 01.04.2011

Pro načtení do listu excelu lze použít:

[code] With ActiveSheet.QueryTables.Add(Connection:= _
"URL;http://f1sports.autorevue.cz/sezona", Destination:=Range("$A$1"))
.WebFormatting = xlWebFormattingNone
.WebTables = "1"
.Refresh BackgroundQuery:=False
End With[/code]


...
Načítat přímo do ADODB.Recordsetu HTMLTable? ;)
Jak sestavit funkční ADODB.Connection? :S
...
The connection string to open an HTML table has this format:
"HTML Import;DATABASE={drive:\ | FTP:// | HTTP://}path\filename [;HDR={Yes | No}]"

Citovat příspěvek

 

Re: VB6 - data z Webu

Autor: Gábina

9:19:31 01.04.2011

Načtení tabulky jezdců pomocí vba Excel
(zde do aktivního listu excelu)


Standard module:
[code]Option Explicit

Sub WebTableToSheet()
'Tested using IE8, Excel 2003 SP3 and Windows XP
Dim objIE As Object
Dim varTables, varTable
Dim varRows, varRow
Dim varCells, varCell
Dim lngRow As Long, lngColumn As Long
Dim strBuffer As String

Set objIE = CreateObject("InternetExplorer.Application")

With objIE
.Visible = False
.AddressBar = False
.StatusBar = False
.MenuBar = False
.Toolbar = 0
.Navigate "http://f1sports.autorevue.cz/sezona"
End With


While objIE.Busy
Wend
While objIE.Document.ReadyState <> "complete"
Wend

Set varTables = objIE.Document.All.tags("TABLE")

For Each varTable In varTables
'Use the innerText to see if this is the table we want.
If varTable.innerText Like "P.JezdecTýmBody*" Then
Set varRows = varTable.Rows
lngRow = 2 'This will be the first output row
For Each varRow In varRows
Set varCells = varRow.Cells
lngColumn = 1 'This will be the output column
For Each varCell In varCells
ActiveSheet.Cells(lngRow - 1, lngColumn) = varCell.innerText
lngColumn = lngColumn + 1
Next varCell
lngRow = lngRow + 1
Next varRow
Exit For
End If
Next varTable

Cleanup:
Set varCell = Nothing: Set varCells = Nothing
Set varRow = Nothing: Set varRows = Nothing
Set varTable = Nothing: Set varTables = Nothing
objIE.Quit
Set objIE = Nothing
End Sub[/code]

...
Parse HTML code, create a table
http://www.tek-tips.com/viewthread.cfm?qid=1458220
...

Citovat příspěvek

 

VB6 - data z Webu

Autor: toonnyy

22:23:02 31.03.2011

Ahoj
měl bych jeden dotaz-prosbu: chtěl bych ve VB6 udělat program o F1, tedy info o pilotech,týmech, a hlavně aktuální pořadí, výsledky jednotlivých VC. Chtěl bych ale, aby se informace načetli ze stránky třeba http://f1sports.autorevue.cz/sezona po kliknutí třeba na Aktualizovat. Data se uloží do txt polí,propojené z databází (*mdb). Vytvoření *mdb, naplnění, třídění atd problém není, to zvládám. Najde se někdo, kdo by poslal zdroják, jak třeba načíst právě aktuální pořadí-tedy jméno pilota a počet bodů z této stránky? Je to něco podobného, jako programy na katalogizaci DVD filmů, kde se údaje také načtou z filmové databáze. Tam se ale film musí nejprve vyhledat, tady ale přesně znám adresu stránky, ze které data budou načtena. Bohužel ale o tomhle nemám ani páru.Předem dík, pokud možno za zdrojá, pokud to není velký problém
toonnyy@centrum.cz

Citovat příspěvek

 

 

 

Přihlášení k mému účtu

Uživatelské jméno:

Heslo: