WebQuery for web sites that require a log in

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

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

[navy]End Sub[/navy]

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

[green]'Set the return value[/green]
GetMyTekTipsReplies = [navy]True[/navy]

[green]'Spawn Internet Explorer[/green]
[navy]Set[/navy] objIE = CreateObject("InternetExplorer.Application")

[green]'Set the user Information here[/green]
strUserName = "[i]Handle here[/i]"
strPassword = "[i]Password here[/i]"
[green]'Double check[/green]
[navy]If[/navy] strUserName = "[i]Handle here[/i]" [navy]Then[/navy]
  strUserName = [navy]In[/navy]putBox("Please enter your Tek-Tips Handle:", "Username needed")
[navy]End If[/navy]
[navy]If[/navy] strPassword = "[i]Password here[/i]" [navy]Then[/navy]
  strPassword = [navy]In[/navy]putBox("Please enter your Tek-Tips password:", "Password needed")
[navy]End If[/navy]

DoEvents

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

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

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

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

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

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

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

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

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

Cleanup:
objIE.Quit
[navy]Set[/navy] objIE = [navy]Nothing[/navy]
[navy]Exit Function[/navy]

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

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

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

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

Cleanup:
Close #intFile
[navy]Exit Sub [/navy]

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

[navy]Function[/navy] UpdateQueryTableFromLocalHTML() [navy]As Boolean[/navy]
[navy]On Error Goto[/navy] UpdateQueryTableFromLocalHTML_Error
[navy]Dim[/navy] wksDestination [navy]As[/navy] Worksheet
[navy]Dim[/navy] qtDestination [navy]As[/navy] QueryTable

[green]'Set the return value[/green]
UpdateQueryTableFromLocalHTML = [navy]True[/navy]

[navy]Set[/navy] wksDestination = Worksheets("Sheet1")
[navy]Set[/navy] qtDestination = wksDestination.QueryTables("WebOutput")
qtDestination.Refresh [navy]False[/navy]

Cleanup:
[navy]Set[/navy] qtDestination = [navy]Nothing[/navy]
[navy]Set[/navy] wksDestination = [navy]Nothing[/navy]
[navy]Exit Function[/navy]

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