Const TITULO$ = " Web Import"
Private BeeC%, BeeL$, BeeT!
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 WindUp(Optional BeeMIA As Boolean = True)
Me.Shapes("GO!").Visible = True: Application.StatusBar = False
If BeeMIA Then MsgBox "Bee Missing In Action !", vbExclamation, TITULO
On Error Resume Next
Kill BeeL: End
End Sub
Sub Been(SHEDULE As Boolean)
Static TS
If SHEDULE Then TS = Now + 0.0007
Application.OnTime TS, Me.CodeName & ".WindUp", , SHEDULE
End Sub
Private Sub LetItBee()
Dim TP%()
BeeT! = Timer
For Each D In [{"DESDE", "HASTA"}]
If Range(D).Value = "" Then _
Range(D).Select: MsgBox "No " & D & " !", vbExclamation, TITULO: 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 "URL no responde !", vbExclamation, TITULO: End
With [FECHA].Offset(1)
FC& = .Column: FR& = .Row
End With
C& = Me.UsedRange.Rows.Count
Me.Shapes("GO!").Visible = False
If C >= FR Then Cells(FR, FC).Resize(C - FR + 1, 3).Clear
Application.ScreenUpdating = False
Been True: LP% = 1: N% = -1: RC% = 99
Do
P% = LP: Application.StatusBar = Format(P, "Page @@@")
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: ReDim AR(1 To RC, 2): C = 2: R% = 0
For Each D In .GetElementsByTagName("div")
If D.className = "numeros" Then
C = (C + 1) Mod 3
If C Then AR(R, C) = Replace(D.innerText, ",", ".") _
Else R = R + 1: AR(R, 0) = CLng(DateValue(D.innerText))
End If
Next
If R Then
Cells(FR + (P - 1) * RC, FC).Resize(R, 3).Value = AR
If P = 1 Then RC = R
D = Split(.GetElementById("boxPaginador").innerText, vbCrLf)
LP = CInt(D(UBound(D)))
If LP = P Then
If N > 0 Then ReDim Preserve TP(N - 1)
Else
N = N + 1: ReDim Preserve TP(N): TP(N) = LP
End If
End If
End With
End If
Loop Until T = "" Or P = LP
If R Then
With Range(Cells(FR, FC), Cells(Rows.Count, FC + 2).End(xlUp))
.Columns(1).NumberFormat = "dd/mm/yyyy "
.Columns("B:C").NumberFormat = "#,##0.000 "
End With
If LP > 2 Then
With ThisWorkbook
BeeL = .Path & "\Bee - " & Split(.Name, ".")(0) & " - " & Me.Name & " .vbs"
SC = Array("Dim AR(" & RC & ",2)", "On Error Resume Next", _
"P=WScript.Arguments(0): If Err.Number Then WScript.Quit 1", _
"With CreateObject(""MSXML2.XMLHTTP"")", _
"If Err.Number Then WScript.Quit 2", _
".open ""POST"",""" & URL & """ & P,False", _
"If Err.Number Then WScript.Quit 3", _
".send: If .status=200 Then T=.responseText", "End With", "R=-1", _
"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(R,C)=Replace(D.innerText,"","",""."") Else " & _
"R=R+1: AR(R,0)=CLng(DateValue(D.innerText))", "Next", _
"End With", "End If", "GetObject(,""Excel.Application"")" & _
".Workbooks(""" & .Name & """).Worksheets(""" & Me.Name & _
""").Cells(3+(P-1)*" & RC & "," & FC & ").Resize(R+1,3).Value=AR")
End With
F% = FreeFile
Open BeeL For Output As #F
Print #F, Join(SC, vbNewLine)
Close #F
SC = """" & BeeL & """ "
With CreateObject("WScript.Shell")
For P = 2 To LP - 1
D = Application.Match(P, TP, 0)
If IsError(D) Then
.Run SC & P: BeeC = BeeC + 1
Application.StatusBar = "Let it Bee : " & Format(BeeC, "@@@")
End If
Next
End With
End If
Else
MsgBox "Compruebe las fechas !", vbExclamation, TITULO
End If
Application.ScreenUpdating = True: If BeeC = 0 Then Been False: WindUp False
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If BeeC And Target.Columns.Count = 3 Then
BeeC = BeeC - 1: Application.StatusBar = "Let it Bee : " & Format(BeeC, "@@@")
If BeeC = 0 Then
S$ = Format$(Timer - BeeT, " (0.000s)"): Been False: Debug.Print "LetItBee" & S
MsgBox "Operación completada …" & S, vbInformation, TITULO: WindUp False
End If
End If
End Sub
