Code:
Rem 2 Manipulate string
' 2a Start and stop, get rid of unwanted at start and end of full string in Clipboard, StringBack
Dim MainString As String
Dim stPos As Long, spPos As Long
Let stPos = InStr(1, StringBack, "IP Address" & vbCr & vbLf & "Instant Messaging" & vbCr & vbLf, vbBinaryCompare) + 31
Let MainString = Mid(StringBack, stPos)
Let spPos = InStr(stPos, StringBack, vbTab & vbCr & vbLf & "Page ", vbBinaryCompare) ' Start looking at stPos , don't have to though
Let MainString = Mid(StringBack, stPos, (spPos - stPos))
' 2b Get rid of some stuff
Dim arrOff() As Variant
Let arrOff() = Array("You are subscribed to this thread ", "Viewing Error Message ", "Viewing " & "'" & "No Permission" & "'" & " Message ", "Viewing Calendar" & vbCr & vbLf & "Default Calendar") '
Dim Steer As Variant
For Each Steer In arrOff()
Let MainString = Replace(MainString, Steer, "", 1, -1, vbBinaryCompare)
Next Steer
' 2c Replace some stuff - So far that is mainly - A word and a vbCr & vbLf makes a thread title a bit wrong and we have an extra unwanted line
Dim arrWrdNwLn() As Variant
Let arrWrdNwLn() = Array("Viewing Thread", "Viewing Index", "Viewing Printable Version", "Viewing Forum", "Viewing User Profile", "Replying to Thread", "Viewing Archives", "Searching Forums", "Creating Private Message", "Sending Thread to a Friend")
' Let MainString = Replace(MainString, "Sending Thread to a Friend" & vbCr & vbLf, "/", 1, -1, vbBinaryCompare)
' Let MainString = Replace(MainString, "", "", 1, -1, vbBinaryCompare)
For Each Steer In arrWrdNwLn()
Let MainString = Replace(MainString, Steer & vbCr & vbLf, "/", 1, -1, vbBinaryCompare)
Next Steer
'2d We have 2-4 words and a vbTab where a vbCr & vbLf should be
Dim arrWordTab() As Variant
Let arrWordTab() = Array("Viewing Attachment", "Viewing Tag List", "Viewing Subscribed Threads", "Viewing Member List", "Viewing Archives", "Viewing Activity Stream", "Viewing Calendar", "Searching Forums", "Viewing Smilies", "Registering", "Viewing Event", "Private Messaging", "Viewing Who's Online", "Viewing User Control Panel", "Viewing FAQ", "Viewing BB Code", "Viewing Forum Leaders", "Viewing Forum", "Sending Forum Feedback", "Logging In", "Sending Thread to a Friend", "Creating Private Message", "Viewing Thread", "Modifying Profile")
For Each Steer In arrWordTab()
Let MainString = Replace(MainString, Steer & vbTab, vbCr & vbLf, 1, -1, vbBinaryCompare)
Next Steer
'2e Possibly broken link
Let MainString = Replace(MainString, "Unknown Location" & vbCr & vbLf, "Unknown Location", 1, -1, vbBinaryCompare) ' leaving Unknown Location in to see that sort of thing later ###
Rem 3 Getting the data. ' At this point we appear to have a good structured string
Dim arrRequestIP() As String ' ' Hoping that we have pairs of lines, the first has amoungst other things, the URL, the second has the IP Address of the thing or person looking
Let arrRequestIP() = Split(MainString, vbCr & vbLf, -1, vbBinaryCompare)
Dim Cnt As Long
For Cnt = 0 To UBound(arrRequestIP()) ' == MAIN LOOP for a Refreshed page ======================
' 3a Check for non good structure, typically in a problem senario we get then two lines starting with Geust - a '2d synario. It may not get the problem if one or more of the lines is not a Guest oh well, that's life
If Left(arrRequestIP(Cnt), 5) = "Guest" And Left(arrRequestIP(Cnt + 1), 5) = "Guest" Then
Debug.Print ' just to make space in any other clutter in immediate window
Debug.Print "Guest Guest " & arrRequestIP(Cnt) ' to check out any still needed sanitation of the full string text to achieve a good structured string,
Debug.Print ' just to make space in any other clutter in immediate window
MsgBox prompt:="Guest Guest synario, (likely words with a vbTab where a vbCr & vbLf should be)"
Stop
Else
' This next array should be User vbTab Time vbTab Request
Dim arrWhenWhat() As String: Let arrWhenWhat() = Split(arrRequestIP(Cnt), vbTab, -1, vbBinaryCompare)
' 3b Check for non good structure, typically in a problem scenario ' 2c
If UBound(arrWhenWhat()) <> 2 Then ' This might occur if there is an unwanted extra vbCr & vblf such as in the synario '2c
Debug.Print ' These Debug.Print lines should give me an idea what the problem is
Debug.Print arrRequestIP(Cnt - 2)
Debug.Print arrRequestIP(Cnt - 1)
Debug.Print arrRequestIP(Cnt - 0)
Debug.Print arrRequestIP(Cnt + 1)
Debug.Print
' /forum/showthread.php?17-Using-ListView-a-Listbox-on-steroidsViewing Thread 52.167.144.181
' /forum/showthread.php/17-Using-ListView-a-Listbox-on-steroids
MsgBox prompt:="Possible '2c scenario you have a word and extra vbCr & vnLf to get rid of "
Stop
Else ' Now we are ready to start a hopefully regular ordered text, havong just finished checking form irregularities
Rem 4
Dim Request As String: Let Request = arrWhenWhat(2) ' This hould be the URL being requested
Dim IPAddress As String: Let IPAddress = arrRequestIP(Cnt + 1) ' Zhe next line should be the IP Address of the thing or person viewing
' Worksheets info, maybe a better place for this is somewhere else.
Dim WsReq As Worksheet, WsIP As Worksheet, WsReqErr As Worksheet
Set WsReq = ThisWorkbook.Worksheets("Requests"): Set WsIP = ThisWorkbook.Worksheets("IPAddresses"): Set WsReqErr = ThisWorkbook.Worksheets("UnkownLocations")
Dim LrReq As Long, LrIP As Long, LrReqErr As Long
Let LrReq = WsReq.Range("B" & WsReq.Rows.Count & "").End(xlUp).Row: LrIP = WsIP.Range("B" & WsIP.Rows.Count & "").End(xlUp).Row: Let LrReqErr = WsReqErr.Range("B" & WsReqErr.Rows.Count & "").End(xlUp).Row
Dim rngReq As Range, rngIP As Range, rngReqErr As Range
Set rngReq = WsReq.Range("B1:B" & LrReq & ""): Set rngIP = WsIP.Range("B1:B" & LrIP & ""): Set rngReqErr = WsReqErr.Range("B1:B" & LrReqErr & "")
If InStr(1, Request, "Unknown Location", vbBinaryCompare) > 0 Then ' ###
Let Request = Replace(Request, "Unknown Location", "", 1, 1, vbBinaryCompare)
Rem 5 Problem URL requests, so URL into "UnkownLocations" worksheet
WsReqErr.Activate
Dim rngReqErrIn As Range '
If Len(Request) > 255 Then ' If an untypical very long URL crops up, the .Find below won't work, so here we just hope there are not so many of these and with that unlikely to be duplicates of them - this is a bit of a bodge done after all the coding was first done
Set rngReqErrIn = WsReqErr.Range("B" & LrReqErr + 1 & "")
Let rngReqErrIn = Request
Let rngReqErrIn.Offset(0, -1) = 1
Let rngReqErrIn.Offset(0, 1) = IPAddress
Else ' For more typical URLs we can check to see if we already have it, so as to avoid duplicate entries
Set rngReqErrIn = rngReqErr.Find(what:=Request, After:=WsReqErr.Range("B1"), LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
If rngReqErrIn Is Nothing Then
Set rngReqErrIn = WsReqErr.Range("B" & LrReqErr + 1 & "")
Let rngReqErrIn = Request
Let rngReqErrIn.Offset(0, -1) = 1
Let rngReqErrIn.Offset(0, 1) = IPAddress
Else
Let rngReqErrIn = Request
Let rngReqErrIn.Offset(0, -1) = rngReqErrIn.Offset(0, -1).Value + 1
Let rngReqErrIn.Offset(0, 1) = rngReqErrIn.Offset(0, 1).Value & vbCr & vbLf & " " & IPAddress
End If
End If ' Finished with problem requests here
Else '
Rem 6 For most URLs, URL goes into worksheet "Requests"
WsReq.Activate
Dim rngReqIn As Range '
If Len(Request) > 255 Then ' I csannot use the .Find for these rare occaisions, so i just put it at the end, hoping it is not a duplicate
Set rngReqIn = WsReq.Range("B" & LrReq + 1 & "")
Let rngReqIn = Request
Let rngReqIn.Offset(0, -1) = 1
Let rngReqIn.Offset(0, 1) = IPAddress
Else
Set rngReqIn = rngReq.Find(what:=Request, After:=WsReq.Range("B1"), LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
If rngReqIn Is Nothing Then
Set rngReqIn = WsReq.Range("B" & LrReq + 1 & "")
Let rngReqIn = Request
Let rngReqIn.Offset(0, -1) = 1
Let rngReqIn.Offset(0, 1) = IPAddress
Else
Let rngReqIn = Request
Let rngReqIn.Offset(0, -1) = rngReqIn.Offset(0, -1).Value + 1
Let rngReqIn.Offset(0, 1) = rngReqIn.Offset(0, 1).Value & vbCr & vbLf & " " & IPAddress
End If
End If
End If
Let Cnt = Cnt + 1 ' Hopefully now we are at the IP address line (Bit naughty apparantly - cardinal sin apparantly to do this.) Hopefully the URL has now been added, in either "Requests" or "UnkownLocations" worksheets, (and the IP address added in column C ), and we now go to next line for adding IP address worksheet info
Rem 7 IP address info worksheet
WsIP.Activate
Dim rngIPIn As Range, UsrNme As String: Let UsrNme = arrWhenWhat(0)
Set rngIPIn = rngIP.Find(what:=IPAddress, After:=WsIP.Range("B1"), LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlNext, MatchCase:=True)
If rngIPIn Is Nothing Then
Set rngIPIn = WsIP.Range("B" & LrIP + 1 & "")
Let rngIPIn = IPAddress
Let rngIPIn.Offset(0, -1) = 1
Let rngIPIn.Offset(0, 1) = UsrNme
Else
Let rngIPIn = IPAddress ' This is redundant
Let rngIPIn.Offset(0, -1) = rngIPIn.Offset(0, -1).Value + 1
If InStr(1, rngIPIn.Offset(0, 1).Value, UsrNme, vbBinaryCompare) > 0 Then
' same User Name for this IP as last time, (the most likely case), so do nothing
Else
Let rngIPIn.Offset(0, 1) = rngIPIn.Offset(0, 1).Value & vbCr & vbLf & UsrNme
End If
End If
End If ' end of a check for a likely situation where there is an extra unwanted vbDr & vbLf
End If ' End of the check for a Guest Guest synario (likely words with a vbTab where a vbCr & vbLf should be)
Next Cnt ' == MAIN LOOP For a refreshed Page ==================================================
' 7b Sort order of IP addresses
LrIP = WsIP.Range("B" & WsIP.Rows.Count & "").End(xlUp).Row ' refresh after last entry (probably just LrIP = LrIP +1 would do
Dim rngToSort As Range: Set rngToSort = WsIP.Range("A2:C" & LrIP & "")
rngToSort.Sort Key1:=WsIP.Range("B2:B" & LrIP & ""), Order1:=xlAscending
Rem 10 Miscalaneous
' A count sometimes useful to keep track how many times you run the coding, you will want to manually set this to 0 maybe dependiung on what when you are doing something
' let WsIP.Range("I2") = WsIP.Range("I2").Value + 1
Let WsIP.Range("I2") = Refresh ' In this second coding, the manual selecitng of the pages is replaced by the refresh
'End Sub from the first codoing,
Next Refresh ' Next Refresh ----------------------------------------------------------------------
End Sub
Reply With Quote
Bookmarks