香港新浪網 MySinaBlog
« 上一篇 | 下一篇 »
Emily | 29th Jan 2007, 10:59 AM | General | (1181 Reads)

List IE history

 

Sub BrowserHist()
Const ssfHISTORY = 34

User = Environ("USERNAME")
Cells(1, 1) = "User"
Cells(1, 2) = "Time"
Cells(1, 3) = "Title"
Cells(1, 4) = "URL"
r = 2

On Error Resume Next

Set sh = CreateObject("Shell.Application")
Set history = sh.Namespace(ssfHISTORY)

For Each Item In history.items
   If Item.isFolder Then
      Set itFol = Item.GetFolder
      For Each item2 In itFol.items
         If item2.isFolder Then
            Set itFol2 = item2.GetFolder
            For Each item3 In itFol2.items
                With ActiveSheet
                    .Cells(r, 1).Value = User
                    .Cells(r, 2).Value = itFol2.GetDetailsOf(item3, 2)
                    .Cells(r, 3).Value = itFol2.GetDetailsOf(item3, 1)
                    .Cells(r, 4).Value = itFol2.GetDetailsOf(item3, 0)
                End With
            r = r + 1
            Next
         End If
      Next
   End If
Next
End Sub

'Code Revised using array by Stanley Pan

Sub BrowserHist()
Const ssfHISTORY = 34
Dim buf() As Variant
Dim i As Long
Dim start_time: start_time = Timer
   Application.ScreenUpdating = False
   'loop
   User = Environ("USERNAME")
   On Error Resume Next

   Set sh = CreateObject("Shell.Application")
   Set history = sh.Namespace(ssfHISTORY)

   For Each Item In history.items
      If Item.isFolder Then
         Set itFol = Item.GetFolder
         For Each item2 In itFol.items
            If item2.isFolder Then
               Set itFol2 = item2.GetFolder
               For Each item3 In itFol2.items
                  i = i + 1
                  ReDim Preserve buf(1 To 4, 1 To i)
                  buf(1, i) = User
                  buf(2, i) = itFol2.GetDetailsOf(item3, 2)
                  buf(3, i) = itFol2.GetDetailsOf(item3, 1)
                  buf(4, i) = itFol2.GetDetailsOf(item3, 0)
               Next
            End If
         Next
      End If
   Next

   'output result
   [A1].Resize(, 4).Value = Array("User", "Time", "Title", "URL")
   [A2].Resize(UBound(buf, 2), 4) = myTranspose(buf)
   MsgBox "Time used:" & VBA.Str(Timer - start_time) + " seconds"
   Application.ScreenUpdating = True
End Sub

Function myTranspose(buf)
Dim i As Long
Dim j As Long
Dim A() As Variant
   ReDim A(1 To UBound(buf, 2), 1 To UBound(buf, 1))
   For i = LBound(buf, 1) To UBound(buf, 1)
      For j = LBound(buf, 2) To UBound(buf, 2)
         A(j, i) = buf(i, j)
      Next
   Next

   myTranspose = A
End Function