INTELLIGENT WORK FORUMS
FOR COMPUTER PROFESSIONALS

Log In

Come Join Us!

Are you a
Computer / IT professional?
Join Tek-Tips Forums!
  • Talk With Other Members
  • Be Notified Of Responses
    To Your Posts
  • Keyword Search
  • One-Click Access To Your
    Favorite Forums
  • Automated Signatures
    On Your Posts
  • Best Of All, It's Free!

*Tek-Tips's functionality depends on members receiving e-mail. By joining you are opting in to receive e-mail.

Posting Guidelines

Promoting, selling, recruiting, coursework and thesis posting is forbidden.

Jobs

VBA Visual Basic for Applications (Microsoft) FAQ

Excel How To

WebQuery for web sites that require a log in by CautionMP
Posted: 6 Sep 06

Here is one approach to handling a WebQuery for pages that require a login before the tables with the data are displayed. This routine will allow you to use VBA to:
  1. Navigate to a web site.
  2. Log in.
  3. Grab the data (copy the web page to a local file.)
  4. Link your Excel workbook to the local file.
For the sake of familiarity I used Tek-Tips as the web site used in the demonstration.
NOTE: if you have the Remember Me option set for Tek-Tips, this routine will DELETE that cookie.

CODE

Sub PutItAllTogether()
'Fire this macro using a custom Toolbar button
Dim blnProcessComplete As Boolean
blnProcessComplete = GetMyTekTipsReplies
'Open Internet Explorer, Log In, navigate To My Replies, save results To local file
If Not blnProcessComplete Then
  MsgBox "The process did not complete due to an error in " & _
  "GetMyTekTipsReplies", vbCritical, "Error with GetMyTekTipsReplies"
  Exit Sub
End If

'Update QueryTable WebOuput, create it If necesarry
blnProcessComplete = UpdateQueryTableFromLocalHTML
If Not blnProcessComplete Then
  MsgBox "The process did not complete due to an error in " & _
  "UpdateQueryTableFromLocalHTML", vbCritical, "Error with " & _
  "UpdateQueryTableFromLocalHTML"
  Exit Sub
End If

End Sub

Function GetMyTekTipsReplies() As Boolean
On Error Goto GetMyTekTipsReplies_Error
Dim objIE As Object
Dim strUserName As String, strPassword As String

'Set the return value
GetMyTekTipsReplies = True

'Spawn Internet Explorer
Set objIE = CreateObject("InternetExplorer.Application")

'Set the user Information here
strUserName = "Handle here"
strPassword = "Password here"
'Double check
If strUserName = "Handle here" Then
  strUserName = InputBox("Please enter your Tek-Tips Handle:", "Username needed")
End If
If strPassword = "Password here" Then
  strPassword = InputBox("Please enter your Tek-Tips password:", "Password needed")
End If

DoEvents

'Check For and delete cookies If present because they keep the logIn page
'from showing up
DeleteCookies

'Remove all the controls since we Don't want the user to
'monkey with it
With objIE
  .AddressBar = False
  .StatusBar = False
  .MenuBar = False
  .Toolbar = 0
  'Or leave everything alone and just hide the sucker
  .Visible = True
  .Navigate "http://www.tek-tips.com"
End With

'let IE do it's thing and Settle before we touch it
While objIE.Busy
  'Do Nothing
Wend
While objIE.Document.ReadyState <> "complete"
  'AgaIn Do Nothing
Wend

'Actually log In here
With objIE.Document.Forms("pass")
  .All.Item("Handle").Value = strUserName
  .All.Item("Pass").Value = strPassword
  .submit
End With

'let IE do it's thing and Settle before we Touch it
While objIE.Busy
  'Do Nothing
Wend
While
objIE.Document.ReadyState <> "complete"
  'AgaIn Do Nothing
Wend

'check If login wss sucessful
If InStr(1, objIE.Document.body.outerHTML, "Hi " & strUserName, vbTextCompare) = 0 Then
  Err.Raise 9000, "GetMyTekTipsThreads", "Login does not appear sucessful, Exiting routine."
End If

'It appears To be so navigate To the My Replies page
objIE.Navigate "http://www.tek-tips.com/userthreadparticipate.cfm?handle=" & strUserName

'let IE do it's thing and settle before we touch it
While objIE.Busy
  'Do Nothing
Wend
While
objIE.Document.ReadyState <> "complete"
  'AgaIn Do Nothing
Wend

'The page should be loaded, write To a local file
CreateLocalHTMLFile (objIE.Document.body.outerHTML)

Cleanup:
objIE.Quit
Set objIE = Nothing
Exit Function

GetMyTekTipsReplies_Error:
Select Case Err.Number
  Case 9000
    'LogIn is Incorrect
    MsgBox Err.Number & " " & Err.Description, vbCritical, "Error in " & Err.Source
    GetMyTekTipsReplies = False
    Resume Cleanup
  Case Else
    Debug.Print Err.Number, Err.Description
    GetMyTekTipsReplies = False
    Stop
End Select
End Function

Private Sub DeleteCookies()
Dim strDir As String, strFile As String
'Get the location of your user profile
strDir = VBA.Environ$("USERPROFILE") & "\Cookies\"
'intialize the search For a Tek-Tips cookie
strFile = Dir(strDir & "*tek-tips*.txt", vbNormal)
Do While strFile <> ""
  'Found one so delete it and keep looking
  Kill strDir & strFile
  strFile = Dir
Loop
End Sub

Private Sub CreateLocalHTMLFile(outerHTML As String)
On Error Goto CreateLocalHTMLFile_Error
'The following is a temporary directory used the cache the web page
Const cWebTempDirectory As String = "C:\WebTemp"
Dim intFile As Integer

'Get a file number and open the file we will dump the webpage Into
intFile = FreeFile
Open cWebTempDirectory & "\WebOutput.htm" For Output As #intFile
'This will write the data To file using the HTML passed In
Print #intFile, outerHTML

Cleanup:
Close #intFile
Exit Sub

CreateLocalHTMLFile_Error:
Select Case Err.Number
  Case 76
    'temp directiory Does not exist so create it
    VBA.MkDir cWebTempDirectory
    Resume
  Case Else
    Debug.Print Err.Number, Err.Description
    Stop
End Select
End Sub

Function UpdateQueryTableFromLocalHTML() As Boolean
On Error Goto UpdateQueryTableFromLocalHTML_Error
Dim wksDestination As Worksheet
Dim qtDestination As QueryTable

'Set the return value
UpdateQueryTableFromLocalHTML = True

Set wksDestination = Worksheets("Sheet1")
Set qtDestination = wksDestination.QueryTables("WebOutput")
qtDestination.Refresh False

Cleanup:
Set qtDestination = Nothing
Set wksDestination = Nothing
Exit Function

UpdateQueryTableFromLocalHTML_Error:
Select Case Err.Number
  Case 9
  'QueryTable probably Doesn't exist
    Set qtDestination = wksDestination.QueryTables.Add( _
                        "URL;C:\WebTemp\WebOutput.htm", _
                        wksDestination.Range("A1"))
    With qtDestination
      .Name = "WebOutput"
      .WebTables = 8
      .WebFormatting = xlWebFormattingNone
    End With
    Resume Next
  Case Else
    UpdateQueryTableFromLocalHTML = False
    Debug.Print Err.Number, Err.Description
    Stop
End Select
End Function

Back to VBA Visual Basic for Applications (Microsoft) FAQ Index
Back to VBA Visual Basic for Applications (Microsoft) Forum

My Archive

Resources

Close Box

Join Tek-Tips® Today!

Join your peers on the Internet's largest technical computer professional community.
It's easy to join and it's free.

Here's Why Members Love Tek-Tips Forums:

Register now while it's still free!

Already a member? Close this window and log in.

Join Us             Close