Zjištění, zda cache obsahuje specifikou URL

Option Explicit

Private Const ERROR_INSUFFICIENT_BUFFER = 122
Private Const eeErrorBase = 26720

Private Type FILETIME

    dwLowDateTime As Long
    dwHighDateTime As Long

End Type

Private Type INTERNET_CACHE_ENTRY_INFO

    dwStructSize As Long
    lpszSourceUrlName As String
    lpszLocalFileName As String
    CacheEntryType As String
    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 String
    dwReserved As Long

End Type

Private Declare Function GetUrlCacheEntryInfo Lib "wininet.dll" Alias "GetUrlCacheEntryInfoA" (ByVal sUrlName As String, lpCacheEntryInfo As Any, lpdwCacheEntryInfoBufferSize As Long) As Long

' API chyby:
Private Const FORMAT_MESSAGE_ALLOCATE_BUFFER = &H100
Private Const FORMAT_MESSAGE_ARGUMENT_ARRAY = &H2000
Private Const FORMAT_MESSAGE_FROM_HMODULE = &H800
Private Const FORMAT_MESSAGE_FROM_STRING = &H400
Private Const FORMAT_MESSAGE_FROM_SYSTEM = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK = &HFF

Private Declare Function FormatMessage Lib "kernel32" Alias "FormatMessageA" (ByVal dwFlags As Long, lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, Arguments As Long) As Long

Public Function WinAPIError(ByVal lLastDLLError As Long) As String

    Dim sBuff As String
    Dim lCount As Long

    ' Vrací chybovou hlášku asociovanou s LastDLLError:
    sBuff = String$(256, 0)
    lCount = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS, 0, lLastDLLError, 0&, sBuff, Len(sBuff), ByVal 0)

    If lCount Then

        WinAPIError = Left$(sBuff, lCount)

    End If

End Function

Public Function GetCacheEntryInfo(ByVal hWnd As Long, ByVal lpszUrl As String) As Boolean

    Dim dwEntrySize As Long
    Dim lpCacheEntry As INTERNET_CACHE_ENTRY_INFO
    Dim dwTemp As Long
    Dim lErr As Long

    If (GetUrlCacheEntryInfo(lpszUrl, ByVal 0&, dwEntrySize)) = 0 Then
        lErr = Err.LastDllError
        If (lErr <> ERROR_INSUFFICIENT_BUFFER) Then
           'Neexistuje. Vyvoláme chybu s popisem
            Err.Raise eeErrorBase + 1, App.EXEName & ".mCacheEntry", WinAPIError(lErr)
            GetCacheEntryInfo = False
            Exit Function
        Else
            'Existuje
            GetCacheEntryInfo = True
        End If
    End If

End Function

Do projektu připojte formulář (frmTest), na děj dejte tlačítko a textbox. Na událost click tlačítka:

Private Sub Command1_Click()
    On Error GoTo ErrorHandler
    'otestuje, zda URL zadaná v textboxu existuje
    If (GetCacheEntryInfo(Me.hWnd, Text1.Text)) Then

        MsgBox "Cache URL obsahuje.", vbInformation
    Else
        MsgBox "Cache URL neobsahuje", vbInformation
    End If
    Exit Sub
ErrorHandler:
    MsgBox "Cache URL neobsahuje [" & Err.Description & "]", vbInformation
End Sub

Zpět