Click here to Skip to main content
15,920,383 members
Please Sign up or sign in to vote.
0.00/5 (No votes)
See more:
Hi All,

I'm new to VBA. I want to write a function that can access web page and read data on that and then insert them in to a user defined array. In the web page there is a table with 3 columns having "Name","City" and "Phone number" column headers.In my function I want to read each rows in that table and insert data to the user defined array.

Array will be like below:

Type TableData
Name as string
City as string
Phone as string
End type

Can someone help me on this?
Maciej Los 10-Nov-11 15:16pm    
What you mean "access web page"? Does the address of this web page start with "http://www..." or "file:///..."?
thusith1 11-Nov-11 20:32pm    
Need to read the contents in the web page.Web page starts with "http://www...."

1 solution

OK, i wrote for you the biggest part of code...

The function below was tested on the web pages with 'html' extension.
Option Explicit

'need reference to:
' - Microsoft CDO for Windows...
' - Microsoft ActiveX Data Object ver. no.

'function to save web pages on the local computer
Private Function SaveWebPage(ByVal sUrl As String, ByVal sFilePath As String) As Boolean
Dim iMessage As CDO.Message
Dim adodbstream As ADODB.Stream
Dim bBool As Boolean

On Error GoTo Err_SaveWebPage

bBool = True 'default returning value
Set iMessage = New CDO.Message
Set adodbstream = New ADODB.Stream

iMessage.CreateMHTMLBody sUrl, CDO.CdoMHTMLFlags.cdoSuppressNone, "", ""
adodbstream.Type = ADODB.StreamTypeEnum.adTypeText
adodbstream.Charset = "US-ASCII"
iMessage.DataSource.SaveToObject adodbstream, "_Stream"
adodbstream.SaveToFile sFilePath, ADODB.SaveOptionsEnum.adSaveCreateOverWrite

    On Error Resume Next
    Set iMessage = Nothing
    Set adodbstream = Nothing
    SaveWebPage = bBool
    Exit Function

    bBool = False
    MsgBox Err.Description, vbExclamation, Err.Number
    Resume Exit_SaveWebPage
End Function

Not full functional, without error handlers, but shows some technics!
Private Sub CommandButton1_Click()
Dim bRetVal As Boolean
Dim sUrl As String, sDstFile As String, sTmp As String
Dim sLookFor As Variant, i As Integer, j As Integer

sLookFor = Array("<table>", "</table>", "<tr>", "</tr>", "<th>", "</th>", "<td>", "</td>") 'find this parts
sUrl = Me.TxtUrl.Text '
sDstFile = Me.TxtDstFile.Text 'D:\tmp.html
bRetVal = SaveWebPage(sUrl, sDstFile)
If Not bRetVal Then Exit Sub 'can't save web page - exit Sub
Open sDstFile For Input Lock Read As #1 'open web page to read it content
    Do While Not EOF(1) '
        Line Input #1, sTmp 'get single line
        For i = LBound(sLookFor) To UBound(sLookFor) 'look for...
            j = InStr(1, sTmp, sLookFor(i)) 'get the position
            If j > 0 Then
                MsgBox "'" & sLookFor(i) & "' found in the string: " & vbCrLf & _
                        "'" & sTmp & "'" & vbCrLf & _
                        "on the position: " & j, vbInformation, "Message"
            End If
        Next i
Close #1

End Sub

You should look too at this site:[^]
Share this answer

This content, along with any associated source code and files, is licensed under The Code Project Open License (CPOL)

CodeProject, 20 Bay Street, 11th Floor Toronto, Ontario, Canada M5J 2N8 +1 (416) 849-8900