De: Stratos Malasiotis <ieaaf@csv.warwick.ac.uk>
À: Jim Ray <jaray@my-deja.com>
Objet: Re: Importing web page into current sheet
Date : mercredi 13 septembre 2000 17:50

Hi Jim,

Would something like this be acceptable:
----------------------------------------------------------------------------
Sub test_warwick()
    Debug.Print fncGetWebData(URLocation:="http://www.warwick.ac.uk", _
                              SourceTableAddress:="A1:Z100", _
                              TargetBookFullName:=ActiveWorkbook.Name, _
                              TargetTableAddress:="C6")
End Sub
----------------------------------------------------------------------------


HTH
Stratos






(in standard module)
------------------------------------------------------------------------------
Option Explicit

Public Function fncGetWebData(URLocation As String, _
                               Optional SourceTableAddress As String = vbNullString, _
                               Optional TargetBookFullName As String = vbNullString, _
                               Optional TargetTableAddress As String = vbNullString, _
                               Optional DisplayMessages As Boolean = True) As Boolean
 'downloads data from a specified URL and puts them in a new workbook
  Dim WebBook As Workbook, TargetBook As Workbook
  Dim WebTable As Range, WebTableDims(1 To 2) As Long
  Dim TargetTable As Range
  Dim SheetIndex As Integer, SheetNo As Integer
  Dim TargetBookName As String
  Dim FullNameLen As Integer, anIndex As Integer
  Dim MessagePrompt As String
 'initiate the result of the function to False; assume failure
  fncGetWebData = False
 'initialise other variables
  TargetBookName = vbNullString
 'turn screenupdating off; display message to statusbar
  Application.StatusBar = "Downloading Web Data... Please Wait"
  Application.ScreenUpdating = False
 'download the specified html file
  On Error Resume Next
  Application.DisplayAlerts = False
  set WebBook = Workbooks.Open(FileName:=URLocation)
  Application.DisplayAlerts = True
  On Error GoTo 0
  If WebBook Is Nothing Then
     MessagePrompt = "The specified URL could not be found." & Chr(10) & _
                     "No data were collected"
     If DisplayMessages = True Then
        MsgBox Title:="Get Web Data", Prompt:=MessagePrompt, Buttons:=vbCritical
     End If
     GoTo ExitFunction
  End If
 'get the data from the source table in the WebBook
  On Error GoTo ExitFunction
    'if the SourceTableAddress argument is missing get the used range
     If SourceTableAddress = vbNullString Then
        set WebTable = WebBook.Worksheets(1).UsedRange
        WebTableDims(1) = WebTable.Rows.Count
        WebTableDims(2) = WebTable.Columns.Count
     Else
       'get the range specified by SourceTableAddress argument
        On Error Resume Next
        set WebTable = WebBook.Worksheets(1).Range(SourceTableAddress)
        On Error GoTo 0
        If WebTable Is Nothing Then 'i.e. if the specified address was invalid
           MessagePrompt = "The specified source range address could not be located." & Chr(10) & _
                           "No data were collected."
           If DisplayMessages = True Then
              MsgBox Title:="Get Web Data", Prompt:=MessagePrompt, Buttons:=vbCritical
           End If
           GoTo ExitFunction
        End If
        WebTableDims(1) = WebTable.Rows.Count
        WebTableDims(2) = WebTable.Columns.Count
  End If
 'determine in which workbook to put the collected data
  If Not TargetBookFullName = vbNullString Then
     FullNameLen = Len(TargetBookFullName)
     For anIndex = FullNameLen To 1 Step -1
         If Mid(TargetBookFullName, anIndex, 1) = Application.PathSeparator Then Exit For
         TargetBookName = Right(TargetBookFullName, Len(TargetBookFullName) - anIndex + 1)
     Next anIndex
     On Error Resume Next
     set TargetBook = Workbooks(TargetBookName)
     If TargetBook Is Nothing Then
        set TargetBook = Workbooks.Open(FileName:=TargetBookFullName)
     End If
     On Error GoTo 0
  End If
 'if the TargetBookFullName file could not be found create a new workbbok
  On Error GoTo ExitFunction
  If TargetBook Is Nothing Then
     set TargetBook = Workbooks.Add
     TargetBook.Windows(1).Caption = "WebData" 'to be able to recognise it from the controling
                                               'sub-procedure
     SheetNo = TargetBook.Worksheets.Count
    'leave only one worksheet in the new workbook
     If SheetNo > 1 Then
        Application.DisplayAlerts = False
        For SheetIndex = 2 To SheetNo
            TargetBook.Worksheets(SheetIndex).Delete
        Next SheetIndex
        Application.DisplayAlerts = True
     End If
  End If
 TargetBook.Activate
 'determine the range to put the collected data
  If TargetTableAddress = vbNullString Then
     set TargetTable = TargetBook.Worksheets(1).Cells(1, 1).Resize(WebTableDims(1), WebTableDims(2))
  Else
     On Error Resume Next
     set TargetTable = Range(TargetTableAddress).Cells(1, 1).Resize(WebTableDims(1), WebTableDims(2))
     On Error GoTo 0
  End If
  If TargetTable Is Nothing Then 'i.e. if the target table address is invalid
     MessagePrompt = "The specified target range address could not be located." & Chr(10) & _
                     "No data were collected."
     If DisplayMessages = True Then
        MsgBox Title:="Get Web Data", Prompt:=MessagePrompt, Buttons:=vbCritical
     End If
     GoTo ExitFunction
  End If
 'put the data in the specified address
  TargetTable.Value = WebTable.Value
 'close the WebBook
  Application.DisplayAlerts = False
  WebBook.Close SaveChanges:=False
  Application.DisplayAlerts = True
  TargetBook.Activate
 'display the result
  Application.ScreenUpdating = True
 'the function was completed succesfully
  fncGetWebData = True
ExitFunction:
  On Error Resume Next
  Application.DisplayAlerts = False
  WebBook.Close SaveChanges:=False
  Application.DisplayAlerts = True
  Application.StatusBar = False
  On Error GoTo 0
  set WebBook = Nothing
  set TargetBook = Nothing
  set WebTable = Nothing
  set TargetTable = Nothing
End Function
----------------------------------------------------------------------------------------


Jim Ray wrote:
> 
> I have in a Excel 97 spreadsheet a link to a WEB page.  I call this
> function through VBA.  Calling the web page is working greate.  What is
> happening is that it will load it in a new spreadsheet.
> 
> What I want it to do is to have it load into the current open
> spreadsheet.
> 
> Does anyone know how this can be done?
> 
> Thank you.
> 
> Jim Ray
> 
> Sent via Deja.com http://www.deja.com/
> Before you buy.