'Routines to display your Internet Explorer browsing history.
'© Dennis McKinney 2006.
'Free to use in your own programs.
'Prints the history to mainwin.
'Thanks to Rod Bird for providing the 'Order By' solution used in qSORT.
'qSORT is based on David Szafranski's Qsort translation in NL0075.
'histUrl$() fields: intDate, url, site. Tab delimited.
Dim histDay$(1000) 'change if you need more than 1000 days.
maxHistory = 10000 'Adjust as neded.
Dim histUrl$(maxHistory)
Struct ICEI, _ '_INTERNET_CACHE_ENTRY_INFOA
dwStructSize As Ulong, _
lpszSourceUrlName As Ptr, _
lpszLocalFileName As Ptr, _
CacheEntryType As Ulong, _
dwUseCount As Ulong, _
dwHitRate As Ulong, _
dwSizeLow As Ulong , _
dwSizeHigh As Ulong, _
LastModifiedTime.dwLowDateTime As Ulong, _
LastModifiedTime.dwHighDateTime As Ulong, _
ExpireTime.dwLowDateTime As Ulong, _
ExpireTime.dwHighDateTime As Ulong, _
LastAccessTime.dwLowDateTime As Ulong, _
LastAccessTime.dwHighDateTime As Ulong, _
LastSyncTime.dwLowDateTime As Ulong, _
LastSyncTime.dwHighDateTime As Ulong, _
lpHeaderInfo As Ulong, _
dwHeaderInfoSize As Ulong, _
lpszFileExtension As Ptr, _
dwReserved As Ulong
NORMAL.CACHE.ENTRY = 1
URLHISTORY.CACHE.ENTRY = 2097152
Struct st, _ 'SYSTEMTIME
wYear As Word, _
wMonth As Word, _
wDayOfWeek As Word, _
wDay As Word, _
wHour As Word, _
wMinute As Word, _
wSecond As Word, _
wMilliseconds As Word
lenICE = Len(ICEI.struct)
Struct ft, _ ' FILETIME
dwLowDateTime As Ulong, _
dwHighDateTime As Ulong
Struct Deword, x As Ulong
Open "Wininet" For Dll As #inet
'Get the buffer size needed for the results of the UrlCacheEntry.
'The buffer size needed is returned to Deword.x.struct.
Calldll #inet, "FindFirstUrlCacheEntryA", 0 As Long, 0 As Long, _
Deword As Struct, hFile As Ulong
ptrICEI = LocalAlloc(Deword.x.struct)
If ptrICEI Then
'If successful, hFile will not be 0 and the results will
'be returned to the memory buffer ptrICEI.
Calldll #inet, "FindFirstUrlCacheEntryA", 0 As Long, ptrICEI As Ulong, _
Deword As Struct, hFile As Ulong
While hFile <> 0
'Copy the first 80 bytes (lenICE) of the memory buffer into struct ICEI.
Calldll #kernel32,"RtlMoveMemory", ICEI As Struct, ptrICEI As Ulong, lenICE As Long, ret As Void
'Ignore everything except a url history entry.
If ICEI.CacheEntryType.struct = URLHISTORY.CACHE.ENTRY Or NORMAL.CACHE.ENTRY Then
out$ = ""
url$ = Winstring(ICEI.lpszSourceUrlName.struct)
'Extra url information, if any, is returned to the buffer in the space
'at the end of the bytes for the ICEI struct.
If ICEI.lpHeaderInfo.struct Then
hdr$ = Winstring(ICEI.lpHeaderInfo.struct)
'Examine the header and filter out everything that is not a web page.
If (Instr(hdr$,"image")=0) And (Instr(url$,"@http://")>0) Then
'If we're here we have a web page. No ads, banners, images, etc.
If aIdx = maxHistory Then
r = LocalFree(ptrICEI)
Notice "maxHistory exceeded"
Exit While
End If
aIdx = aIdx + 1
'Convert the url timestamp into this computer's system time.
ft.dwLowDateTime.struct = ICEI.LastAccessTime.dwLowDateTime.struct
ft.dwHighDateTime.struct = ICEI.LastAccessTime.dwHighDateTime.struct
Call FileTimeToLocalFileTime
Call FileTimeToSystemTime
'Concat the date from the ICEI struct.
dt$ = DateFromSysTime$()
'Get this date's days since Jan 1, 1901
intDt$ = Str$(Date$(dt$))
'Prevent duplicate dates in array histDay$()
If Not(Instr(dtTmp$,intDt$)) Then
dtTmp$ = dtTmp$ + intDt$ + " "
bIdx = bIdx + 1
histDay$(bIdx) = intDt$
End If
'Build the fields for this url history record.
out$ = intDt$ + Chr$(9)
'the real url
out$ = out$ + Mid$(url$,Instr(url$,"http://")) + Chr$(9)
'Build a site name like: libertybasic (www.libertybasic.com)
fPos = Instr(url$,"@http://")
sPos = fPos + 8
If fPos Then
url$ = Trim$(Mid$(url$, sPos))
x = Instr(url$, "/")
If x Then
url$ = Left$(url$,x-1)
End If
If Instr(url$,"www.") Then
d$ = Mid$(url$,5)
Else
d$ = url$
End If
b$ = "": i = 0
Do
i = i + 1
a$ = Word$(d$,i,".")
Loop While a$ <> ""
For j = 1 To i-2
b$ = b$ + Word$(d$,j,".")+"."
Next j
b$ = Left$(b$,Len(b$)-1)
out$ = out$ + b$ + " ("+url$+")"
End If
'Add the url record to the array.
histUrl$(aIdx) = out$
End If
End If
End If
'Free the current buffer.
r = LocalFree(ptrICEI)
Deword.x.struct = 0
'Get the next buffer size.
Calldll #inet, "FindNextUrlCacheEntryA", hFile As Ulong, 0 As Long, _
Deword As Struct, r As Ulong
ptrICEI = LocalAlloc(Deword.x.struct)
'Get the next UrlCacheEntry.
Calldll #inet, "FindNextUrlCacheEntryA", hFile As Ulong, ptrICEI As Ulong, _
Deword As Struct, hFile As Ulong
Wend
End If
'Close the search.
Calldll #inet, "FindCloseUrlCache", hFile As Ulong, r As Long
'Erase dtTmp$ to free up memory.
dtTmp$ = ""
'Sort both arrays.
Sort histDay$(),1,bIdx
'A qSort is used on histUrl$() to sort on two fields, 1 and 3.
r = qSORT(aIdx, Chr$(9), "13", Descend)
'Print the results.
For i = 1 To bIdx
Print Date$(Val(histDay$(i)))
histDate$ = histDay$(i)
For a = 1 To aIdx
urlDate$ = Word$(histUrl$(a),1,Chr$(9))
If urlDate$ > histDate$ Then Exit For
urlsite$ = Word$(histUrl$(a),3,Chr$(9))
If urlDate$ = histDate$ And urlsite$ <> site$ Then
site$ = urlsite$
Print Tab(4); "Pages visited at "; site$
For b = 1 To aIdx
If urlDate$ > histDate$ Then Exit For
siteDate$ = Word$(histUrl$(b),1,Chr$(9))
siteName$ = Word$(histUrl$(b),3,Chr$(9))
If siteDate$ = histDate$ And siteName$ = site$ Then
Print Tab(8); Word$(histUrl$(b),2,Chr$(9))
End If
Next b
Print
End If
Next a
Print
Next i
Close #inet
Wait
End
'=======================================================
Function LocalAlloc(dwBytes)
Calldll #kernel32, "LocalAlloc", _LMEM_FIXED As Long, dwBytes As Ulong, LocalAlloc As Long
End Function
Function LocalFree(hMem)
Calldll #kernel32, "LocalFree", hMem As Ulong
End Function
Sub FileTimeToLocalFileTime
Calldll #kernel32, "FileTimeToLocalFileTime", ft As Struct, ft As Struct, r As Long
End Sub
Sub FileTimeToSystemTime
Calldll #kernel32, "FileTimeToSystemTime", ft As Struct, st As Struct, r As Long
End Sub
Function DateFromSysTime$()
DateFromSysTime$ = Str$(st.wMonth.struct) + "/" + Str$(st.wDay.struct) + "/" + Str$(st.wYear.struct)
End Function
Function qSORT(RecCnt, Delim$, ORDERBY$, Descend)
'Depends -> histUrl$() to be filled prior to function call.
If 1 >= RecCnt Then Exit Function
first = 1
last = RecCnt
zed = Int((last/5) + 10)
Dim qstack(zed)
flag = 1
stackptr=0
If ORDERBY$ = "" Then ORDERBY$ = "1"
Redim tmpArr$(RecCnt)
'get the number of fields in a record
fieldCnt = 1
tmp$ = Word$(histUrl$(1),fieldCnt,Delim$)
While tmp$ <> ""
fieldCnt = fieldCnt + 1
tmp$ = Word$(histUrl$(1),fieldCnt,Delim$)
Wend
fieldCnt = fieldCnt - 1
'split into fields for ORDERBY purposes
Redim fieldArr$(RecCnt,fieldCnt)
For i = 1 To RecCnt
For j = 1 To fieldCnt
fieldArr$(i,j) = Word$(histUrl$(i),j,Delim$)
Next j
Next i
'Concat the fields specified in ORDERBY$ and place in tmpArr$().
'tmpArr$() is manipulated by the sort.
'histUrl$() elements are swapped in the same order
'as tmpArr$() to achieve the desired results.
For r = 1 To last
tmp$ = ""
For p = 1 To Len(ORDERBY$)
tmp$ = tmp$ + fieldArr$(r,Val(Mid$(ORDERBY$,p,1)))
Next p
tmpArr$(r) = tmp$
Next r
'Start sorting
Do
Do
xVar = Int((last/2) + Int(first/2))
temp$ = tmpArr$(xVar)
i = first
j = last
Do
flag1 = 1
While tmpArr$(i) < temp$
i = i + 1
Wend
While tmpArr$(j) > temp$
j = j -1
Wend
If i > j Then Exit Do
If i < j Then
temp1$ = tmpArr$(i): temp1b$ = histUrl$(i)
temp2$ = tmpArr$(j): temp2b$ = histUrl$(j)
tmpArr$(i) = temp2$: histUrl$(i) = temp2b$
tmpArr$(j) = temp1$: histUrl$(j) = temp1b$
End If
i = i + 1
j = j - 1
Loop While i <= j
If i < last Then
qstack(stackptr) = i
qstack(stackptr + 1) = last
stackptr = stackptr + 2
End If
last = j
Loop While first < last
If stackptr Then
stackptr = stackptr - 2
first = qstack(stackptr)
last = qstack(stackptr + 1)
Else
flag = 0
End If
Loop While flag <> 0
'Sorting finished
'If Descending is True then
'swap the elements to reverse order.
If Descend Then
For v = 1 To (RecCnt/2)
lastptr = RecCnt-(v-1)
tmp$ = histUrl$(v)
histUrl$(v) = histUrl$(lastptr)
histUrl$(lastptr) = tmp$
Next v
End If
End Function