Option Explicit
#If VBA7 Then
Private Declare PtrSafe Function SetTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr, ByVal uElapse As Long, ByVal lpTimerFunc As LongPtr) As LongPtr
Private Declare PtrSafe Function KillTimer Lib "user32" (ByVal hwnd As LongPtr, ByVal nIDEvent As LongPtr) As Long
#Else
Private Declare Function SetTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "user32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
#End If
'//////////////////////////////////////////////////////////////
#If Win64 Then
Private Pri_TimerID As LongPtr
#Else
Private Pri_TimerID As Long
#End If
Function CopyWebsite(Optional URL As String, Optional oRange As Range, Optional PasteObject As Boolean = True) As String
On Error Resume Next
If Pri_TimerID <> 0 Then KillTimer 0&, Pri_TimerID
Static URL_ As String, Rng As Range, Caller As Range, bPasteObject As Boolean
If VBA.TypeName(Application.Caller) = "Range" Then
Set Caller = Application.Caller
URL_ = URL: Set Rng = oRange(2, 1): bPasteObject = PasteObject
Pri_TimerID = SetTimer(0&, 0&, 0, AddressOf CopyWebsite_callback)
Else
Rng.Select
Dim IE As Object
ActiveSheet.DrawingObjects.Delete
Rng.Resize(10000, 1).ClearContents
Dim oDO As Object
Set oDO = VBA.CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
oDO.SetText RequestSite(URL_)
oDO.PutInClipboard
If bPasteObject Then
ActiveSheet.Paste
Else
ActiveSheet.PasteSpecial DisplayAsIcon:= _
False, NoHTMLFormatting:=True
End If
Caller.ClearContents
Set Caller = Nothing
Set oDO = Nothing
Set IE = Nothing
Set Rng = Nothing
End If
On Error GoTo 0
End Function
Sub CopyWebsite2(Optional URL As String, Optional oRange As Range, Optional PasteObject As Boolean = True)
On Error Resume Next
oRange(1, 1).Parent.Activate
oRange(1, 1).Select
Dim IE As Object
Dim oDO As Object
Set oDO = VBA.CreateObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
ActiveSheet.DrawingObjects.Delete
oRange.Resize(10000, 1).ClearContents
oDO.SetText RequestSite(URL)
oDO.PutInClipboard
If PasteObject Then
ActiveSheet.Paste
Else
ActiveSheet.PasteSpecial DisplayAsIcon:= _
False, NoHTMLFormatting:=True
End If
Set oDO = Nothing
Set IE = Nothing
On Error GoTo 0
End Sub
Private Function RequestSite(URL As String) As String
On Error Resume Next
With VBA.CreateObject("MSXML2.XMLHTTP")
.Open "GET", URL, False
.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
.Send ""
If .Status <> 200 Then Exit Function
RequestSite = .responseText
End With
Return
End Function
Private Function CopyWebsite_callback()
Call CopyWebsite
End Function
