Private Declare Function InternetCheckConnectionA Lib "Wininet" (ByVal SITE$, ByVal one&, _
ByVal zero&) As Boolean
Function WebOK(Optional ByVal URL$ = "http://www.msn.com") As Boolean
P& = InStr(9, URL, "/"): If P Then URL = Left$(URL, P)
WebOK = InternetCheckConnectionA(URL, 1, 0)
End Function
Sub Demo()
Dim AR()
For Each D In [{"DESDE", "HASTA"}]
If Range(D).Value = "" Then _
Range(D).Select: MsgBox "No " & D & " !", vbExclamation, " Web Import": End
Next
URL$ = "http://www.ambito.com/economia/mercados/monedas/dolar/info/?ric=ARSB=&desde=" & _
[DESDE].Text & "&hasta=" & [HASTA].Text & "&pag="
If WebOK(URL) = False Then MsgBox "No Web !", vbExclamation, " Web Import": End
Me.Shapes("GO!").Visible = False
M& = Rows.Count - 2
C& = Me.UsedRange.Rows.Count
If C > 2 Then [FECHA].Offset(1).Resize(C - 2, 3).Clear
Do
P& = P& + 1: Application.StatusBar = "Web Import page " & P
With CreateObject("MSXML2.XMLHTTP")
.Open "POST", URL & P, False
.send
If .Status = 200 Then T$ = .responseText Else T = ""
End With
If T > "" Then
With CreateObject("HTMLFile")
.Write T: C = 2
For Each D In .getElementsByTagName("div")
If D.className = "numeros" Then
C = (C + 1) Mod 3
If C Then
AR(C, R&) = Replace(D.innerText, ",", ".")
Else
R = R + 1: If R > M Then Exit Do
ReDim Preserve AR(0 To 2, 1 To R)
AR(0, R) = CLng(DateValue(D.innerText))
End If
End If
Next
C = .GetElementById("nextPG") Is Nothing
End With
End If
Loop Until T = "" Or C
If R Then
With [FECHA].Offset(1).Resize(R, 3)
.Columns(1).NumberFormat = "dd/mm/yyyy "
.Columns("B:C").NumberFormat = "#,##0.000 "
.Value = Application.Transpose(AR)
End With
Else
MsgBox "Compruebe las fechas !", vbExclamation, Space(19) & "Web Import"
End If
Application.StatusBar = False
Me.Shapes("GO!").Visible = True
End
End Sub
