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. Students Click Here
|
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:- Navigate to a web site.
- Log in.
- Grab the data (copy the web page to a local file.)
- 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.
CODESub 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 |
|
|
|
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:
Talk To Other Members
- Notification Of Responses To Questions
- Favorite Forums One Click Access
- Keyword Search Of All Posts, And More...
Register now while it's still free!
Already a member? Close this window and log in.
Join Us Close