[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]
