Excel Problem - System Error &H80004005 (-2147467259) + cannot access webpage

Option Explicit

Const C_PAGE = "http://www.dealextreme.com/p/"

' ADO constants (from C:\Program Files\Common Files\System\ado\ADOVBS.INC)
Const adCmdText = &H1
Const adCmdStoredProc = &H4
Const adInteger = 3
Const adCurrency = 6
Const adVarChar = 200
Const adParamInput = &H1
Const adExecuteNoRecords = &H80

Sub GetDetails()

    ' note: use menu Tools|References to add "Microsoft VBScript Regular Expressions 5.5"
    Dim objRE As New RegExp

    Dim objConn, objRst
    Set objConn = CreateObject("ADODB.Connection")
    objConn.ConnectionString = "Provider=SQLOLEDB;Data Source=.\SQLEXPRESS;User ID=ee;Password=ee"
    objConn.Open
    Dim str_sku
    Set objRst = objConn.Execute("SELECT TOP 2 [SKU] FROM [tblDX] WHERE [LAST_UPDATE] IS NULL OR [LAST_UPDATE] < GETDATE() - 1 ORDER BY [LAST_UPDATE] DESC, ID")
    Dim arrSKUs(), intCountSKUs
    intCountSKUs = -1
    While Not objRst.EOF
        str_sku = objRst.Fields(0).Value
        intCountSKUs = intCountSKUs + 1
        ReDim Preserve arrSKUs(intCountSKUs)
        arrSKUs(intCountSKUs) = str_sku
        objRst.MoveNext
    Wend
    objRst.Close
    Set objRst = Nothing
    
    If intCountSKUs = -1 Then
        MsgBox "Nothing to update"
    Else
        Dim objXMLHTTP, strHtml, objCmd
        ' prepare update command
        Set objCmd = CreateObject("ADODB.Command")
        Set objCmd.ActiveConnection = objConn
        objCmd.CommandType = adCmdText
        objCmd.CommandText = "UPDATE [tblDX] SET [Name] = ?, [PriceUS] = ?, [PriceAUS] = ?, [Specs] = Replace(?,'<br />',char(13)), [LAST_UPDATE] = GETDATE() WHERE [SKU] = ?"
        objCmd.Parameters.Append objCmd.CreateParameter("Name", adVarChar, adParamInput, 200)
        objCmd.Parameters.Append objCmd.CreateParameter("PriceUS", adCurrency, adParamInput)
        objCmd.Parameters.Append objCmd.CreateParameter("PriceAUS", adCurrency, adParamInput)
        objCmd.Parameters.Append objCmd.CreateParameter("Specs", adVarChar, adParamInput, 500)
        objCmd.Parameters.Append objCmd.CreateParameter("SKU", adVarChar, adParamInput, 20)
        ' start below header, TODO: clear rest of sheet?
        [A3].Select
        ' get pages for each SKU to be updated
        Set objXMLHTTP = CreateObject("Microsoft.XMLHTTP")
        For Each str_sku In arrSKUs ' Array(93909, 93910) ' numbers or strings (for letters or leading zeroes)
            objCmd.Parameters(4).Value = str_sku
            ' get page html
            objXMLHTTP.Open "GET", C_PAGE & str_sku, False
            objXMLHTTP.Send
            strHtml = objXMLHTTP.ResponseText
            ' find text parts
            objRE.IgnoreCase = True
            objRE.MultiLine = True
            objRE.Pattern = "<div class=""SectionContents"">\s*Item: (.*?)\s*<br />\s*<div><font face=""Arial"" size=2>(.*?)</font></div>\s*</div>"
            Dim objMatches, objMatch
            Set objMatches = objRE.Execute(strHtml)
            If objMatches.Count > 0 Then
                ActiveCell.Value = objMatches(0).SubMatches(0)
                ActiveCell.Offset(0, 1).Value = str_sku
                ActiveCell.Offset(0, 4).Value = Replace(objMatches(0).SubMatches(1), "<br />", Chr(10))
                objCmd.Parameters(0).Value = objMatches(0).SubMatches(0)
                objCmd.Parameters(3).Value = objMatches(0).SubMatches(1) ' Replace(, "<br />", Chr(13)) ' now done in SQL!
            Else
                ActiveCell.Value = "name not found"
                ActiveCell.Offset(0, 1).Value = str_sku
                ActiveCell.Offset(0, 4).Value = "description not found"
                objCmd.Parameters(0).Value = "N/A"
                objCmd.Parameters(3).Value = "N/A"
            End If
            Set objMatches = Nothing
            ' search price US
            objRE.Pattern = "<strong>\s*Price:</strong>\s*<span id=""ctl00_content_Price"" style=""font-family:Arial;font-size:15pt;font-weight:bold;"">\$([0-9,.]+)</span>"
            Set objMatches = objRE.Execute(strHtml)
            If objMatches.Count > 0 Then
                ActiveCell.Offset(0, 2).Value = objMatches(0).SubMatches(0)
                objCmd.Parameters(1).Value = objMatches(0).SubMatches(0)
            Else
                ActiveCell.Offset(0, 2).Value = "N/A"
                objCmd.Parameters(1).Value = 0 ' default/keep existing?
            End If
            Set objMatches = Nothing
            ' search price AUD
            objRE.Pattern = "<span id='AUD'>\s*([0-9,.]+)\s*</span>"
            Set objMatches = objRE.Execute(strHtml)
            If objMatches.Count > 0 Then
                ActiveCell.Offset(0, 3).Value = objMatches(0).SubMatches(0)
                objCmd.Parameters(2).Value = objMatches(0).SubMatches(0)
            Else
                ActiveCell.Offset(0, 3).Value = "N/A"
                objCmd.Parameters(2).Value = 0 ' ?
            End If
            Set objMatches = Nothing
            ' update database
            objCmd.Execute , , adExecuteNoRecords
            ' next row
            ActiveCell.Offset(1, 0).Select
        Next
        ' clean up
        Set objRE = Nothing
        Set objXMLHTTP = Nothing
        Set objCmd.ActiveConnection = Nothing
        While objCmd.Parameters.Count > 0
            objCmd.Parameters.Delete objCmd.Parameters.Count - 1
        Wend
        Set objCmd = Nothing
        MsgBox "Update complete"
    End If
    objConn.Close
    Set objConn = Nothing
End Sub

Select allOpen in new window