浏览器

开发平台：
Visual Basic

Main.bas：源码内容
							Attribute VB_Name = "mMain"
Option Explicit
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
'public Declare Function SysAllocString Lib "oleaut32.dll" (ByVal pOlechar As Long) As String
Public Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Long) As Long
Public Declare Function FindFirstUrlCacheGroup Lib "wininet.dll" ( _
    ByVal dwFlags As Long, _
    ByVal dwFilter As Long, _
    ByRef lpSearchCondition As Long, _
    ByVal dwSearchCondition As Long, _
    ByRef lpGroupId As Date, _
    ByRef lpReserved As Long) As Long
Public Declare Function FindNextUrlCacheGroup Lib "wininet.dll" ( _
    ByVal hFind As Long, _
    ByRef lpGroupId As Date, _
    ByRef lpReserved As Long) As Long
Public Declare Function DeleteUrlCacheGroup Lib "wininet.dll" ( _
    ByVal sGroupID As Date, _
    ByVal dwFlags As Long, _
    ByRef lpReserved As Long) As Long
Public Declare Function FindFirstUrlCacheEntry Lib "wininet.dll" Alias "FindFirstUrlCacheEntryA" ( _
    ByVal lpszUrlSearchPattern As String, _
    ByRef lpFirstCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, _
    ByRef lpdwFirstCacheEntryInfoBufferSize As Long) As Long
'public Type INTERNET_CACHE_ENTRY_INFO
'    dwStructSize As Long
'    szRestOfData(1024) As Long
'End Type
Public Type FILETIME
    dwLowDateTime As Long
    dwHighDateTime As Long
End Type
Public Type INTERNET_CACHE_ENTRY_INFO
    dwStructSize As Long
    lpszSourceUrlName As Long
    lpszLocalFileName As Long
    CacheEntryType As Long
    dwUseCount As Long
    dwHitRate As Long
    dwSizeLow As Long
    dwSizeHigh As Long
    LastModifiedTime As FILETIME
    ExpireTime As FILETIME
    LastAccessTime As FILETIME
    LastSyncTime As FILETIME
    lpHeaderInfo As Long
    dwHeaderInfoSize As Long
    lpszFileExtension As Long
    dwReserved As Long
    bff(0 To 2048) As Byte
'    union {
'        DWORD dwReserved;
'        DWORD dwExemptDelta;
'    }
End Type
Public Const COOKIE_CACHE_ENTRY As Long = &H100000
Public Const URLHISTORY_CACHE_ENTRY As Long = &H200000
Public Const NORMAL_CACHE_ENTRY As Long = &H1
Public Const TRACK_OFFLINE_CACHE_ENTRY As Long = &H10
Public Const TRACK_ONLINE_CACHE_ENTRY As Long = &H20
Public Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" ( _
    ByVal lpszUrlName As Long) As Long
Public Declare Function FindNextUrlCacheEntry Lib "wininet.dll" Alias "FindNextUrlCacheEntryA" ( _
    ByVal hEnumHandle As Long, _
    ByRef lpNextCacheEntryInfo As INTERNET_CACHE_ENTRY_INFO, _
    ByRef lpdwNextCacheEntryInfoBufferSize As Long) As Long
Public Const CACHGROUP_SEARCH_ALL = &H0
Public Const ERROR_NO_MORE_FILES = 18
Public Const ERROR_NO_MORE_ITEMS = 259
Public Const CACHEGROUP_FLAG_FLUSHURL_ONDELETE = &H2
Public Const BUFFERSIZE = 2048
Sub main()
Dim tFrm As frmMain
Select Case Command
    Case "normal"
        Call DelCache("*.*", URLHISTORY_CACHE_ENTRY Or COOKIE_CACHE_ENTRY)
    Case "cookie"
        Call DelCache("cookie:")
    Case "visited"
        Call DelCache("visited:")
    Case "all"
        Call DelCache("*.*")
    Case Else
        Set tFrm = New frmMain
        tFrm.Show
        Set tFrm = Nothing
End Select
End Sub
Public Sub DelCache(vUrlSearchPattern As String, Optional vExcluded As Long = 0)
    Dim sGroupID As Date
    Dim hGroup As Long
    Dim hFile As Long
    Dim sEntryInfo As INTERNET_CACHE_ENTRY_INFO
    Dim iSize As Long
    On Error Resume Next
    ' Delete the groups
    hGroup = FindFirstUrlCacheGroup(0, 0, 0, 0, sGroupID, 0)
    ' To avoid error using it with IE4 as FindFirstUrlCacheGroup is not implemented
    If Err.Number <> 453 Then
        If (hGroup = 0) And (Err.LastDllError <> 2) Then
            'MsgBox "An error occurred enumerating the cache groups" & Err.LastDllError
            Debug.Print "An error occurred enumerating the cache groups" & Err.LastDllError
            Exit Sub
        End If
    Else
        Err.Clear
    End If
    If (hGroup <> 0) Then
        'we succeeded in finding the first cache group.. enumerate and
        'delete
        Do
            If (0 = DeleteUrlCacheGroup(sGroupID, CACHEGROUP_FLAG_FLUSHURL_ONDELETE, 0)) Then
               ' To avoid error using it with IE4 as FindFirstUrlCacheGroup is not implemented
               If Err.Number <> 453 Then
                 'MsgBox "Error deleting cache group " & Err.LastDllError
                 Debug.Print "Error deleting cache group " & Err.LastDllError
                 Exit Sub
               Else
                  Err.Clear
               End If
            End If
            iSize = BUFFERSIZE
            If (0 = FindNextUrlCacheGroup(hGroup, sGroupID, iSize)) And (Err.LastDllError <> 2) Then
                'MsgBox "Error finding next url cache group! - " & Err.LastDllError
                Debug.Print "Error finding next url cache group! - " & Err.LastDllError
            End If
        Loop Until Err.LastDllError = 2
    End If
  ' Delete the files
    sEntryInfo.dwStructSize = 80
    iSize = BUFFERSIZE
    hFile = FindFirstUrlCacheEntry(vUrlSearchPattern, sEntryInfo, iSize)
    If (hFile = 0) Then
        If (Err.LastDllError = ERROR_NO_MORE_ITEMS) Then
            'GoTo done
            Exit Sub
        End If
        'MsgBox "ERROR: FindFirstUrlCacheEntry - " & Err.LastDllError
        Debug.Print "ERROR: FindFirstUrlCacheEntry - " & Err.LastDllError
        Exit Sub
    End If
        
    Do
        If (sEntryInfo.CacheEntryType And vExcluded) = 0 Then
            If (0 = DeleteUrlCacheEntry(sEntryInfo.lpszSourceUrlName)) _
                And (Err.LastDllError <> 2) Then
                Err.Clear
            End If
        End If
        iSize = BUFFERSIZE
        If (0 = FindNextUrlCacheEntry(hFile, sEntryInfo, iSize)) And (Err.LastDllError <> ERROR_NO_MORE_ITEMS) Then
            'MsgBox "Error:  Unable to find the next cache entry - " & Err.LastDllError
            Debug.Print "Error:  Unable to find the next cache entry - " & Err.LastDllError
            Exit Sub
        End If
                
    Loop Until Err.LastDllError = ERROR_NO_MORE_ITEMS
    
End Sub
Public Function Ptr2StrW(Ptr As Long) As String
Dim sRtn() As Byte
    ' Check if the pointer is valid
    If Ptr <> 0 Then
    
        ReDim sRtn(lstrlen(ByVal Ptr) - 1)
        
        ' Copy the string to the byte array
        CopyMemory sRtn(0), ByVal Ptr, UBound(sRtn) + 1
        Ptr2StrW = sRtn()
        
    End If
    
End Function

						