UrlCacheEntry Functions

'UserForm1


'A. Available References List

'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'5) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL

'B. Available Tools List

'1) İmage1, Label1, Label2
'2) Listbox1
'3) CommandButton1, CommandButton2, CommandButton3

Option Explicit
Private i As Long
Private Declare Sub SHAddToRecentDocs Lib "SHELL32.DLL" (ByVal uFlags As Integer, ByVal pv As String)
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Private Type FILETIME

dwLowDateTime As Long
dwHighDateTime As Long

End Type
Private 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
dwExemptDelta As Long

End Type
Private ICEI As INTERNET_CACHE_ENTRY_INFO
Private Declare Function FindFirstUrlCacheEntry Lib "wininet.dll" Alias "FindFirstUrlCacheEntryA" (ByVal lpszUrlSearchPattern As String, lpFirstCacheEntryInfo As Any, lpdwFirstCacheEntryInfoBufferSize As Long) As Long
Private Declare Function FindNextUrlCacheEntry Lib "wininet.dll" Alias "FindNextUrlCacheEntryA" (ByVal hEnumHandle As Long, lpNextCacheEntryInfo As Any, lpdwNextCacheEntryInfoBufferSize As Long) As Long
Private Declare Function FindCloseUrlCache Lib "wininet.dll" (ByVal hEnumHandle As Long) As Long
Private Declare Function DeleteUrlCacheEntry Lib "wininet.dll" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Private Declare Function lstrcpyA Lib "kernel32" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Private Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long
Private Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Private Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Dosyam As String
Private Dosya As Long
Private Bellek As Long
Private Yakalanan As Long
Private Sub UserForm_Initialize()

On Error Resume Next
Me.Caption = "[PBİD®] UrlCacheEntry Functions"
Call Ekran_Duzenle

End Sub
Private Sub CommandButton1_Click()

On Error Resume Next
GetCacheURLList

End Sub
Private Sub CommandButton2_Click()

On Error Resume Next
If ListBox1.ListIndex > -1 Then

Dosyam = ListBox1.List(ListBox1.ListIndex)
Call DeleteUrlCacheEntry(Dosyam)
Call GetCacheURLList

Else

MsgBox "Please select a Cookie", vbInformation, "[PBİD®]"

End If

End Sub
Private Sub CommandButton3_Click()

On Error Resume Next
For i = 0 To ListBox1.ListCount - 1

Dosyam = ListBox1.List(i)
If InStr(Dosyam, "Cookie") = 0 Then

Call DeleteUrlCacheEntry(Dosyam)

End If

Next i
Call GetCacheURLList

End Sub
Private Sub ListBox1_Click()

On Error Resume Next
CommandButton2.Enabled = VBA.InStr(ListBox1.List(ListBox1.ListIndex), "Cookie") = 0

End Sub
Public Sub GetCacheURLList()

On Error GoTo Hata
ListBox1.Clear
Bellek = 0
Dosya = FindFirstUrlCacheEntry(0&, ByVal 0, Bellek)
If Dosya = 0 And Err.LastDllError = 122 Then

Yakalanan = LocalAlloc(&H0, Bellek)
If Yakalanan Then

CopyMemory ByVal Yakalanan, Bellek, 4
Dosya = FindFirstUrlCacheEntry(vbNullString, ByVal Yakalanan, Bellek)
If Dosya <> 0 Then

Do

CopyMemory ICEI, ByVal Yakalanan, Len(ICEI)
If (ICEI.CacheEntryType And &H1) = &H1 Then

Dosyam = GetStrFromPtrA(ICEI.lpszSourceUrlName)
ListBox1.AddItem Dosyam

End If
Call LocalFree(Yakalanan)
Bellek = 0
Call FindNextUrlCacheEntry(Dosya, ByVal 0, Bellek)
Yakalanan = LocalAlloc(&H0, Bellek)
CopyMemory ByVal Yakalanan, Bellek, 4

Loop While FindNextUrlCacheEntry(Dosya, ByVal Yakalanan, Bellek)

End If

End If

End If
Call LocalFree(Yakalanan)
Call FindCloseUrlCache(Dosya)
Exit Sub
Hata:
ListBox1.Clear
MsgBox VBA.Err.Description, vbCritical, "[PBİD®]"

End Sub
Public Function GetStrFromPtrA(ByVal lpszA As Long) As String

On Error Resume Next
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)

End Function
Sub EmptyDocument()

On Error Resume Next
SHAddToRecentDocs 2, vbNullString

End Sub
Private Sub Ekran_Duzenle()

On Error Resume Next
With Me

.BackColor = vbWhite
.Height = 244
.Width = 426
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
.SpecialEffect = fmSpecialEffectFlat
With Image1

.Top = 6
.Left = 6
.Height = 24
.Width = 24
.BackStyle = fmBackStyleTransparent
.BorderStyle = fmBorderStyleSingle
.BorderColor = vbBlue
.Picture = Resim(URL2)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = False

End With
With Label1

.Left = 36
.Top = 6
.Height = 12
.Width = 420
.Caption = "Mustafa ULUSARAÇ"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue

End With
With Label2

.Left = 36
.Top = 18
.Height = 12
.Width = 420
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue

End With
With ListBox1

.Left = 6
.Top = 36
.Height = 150
.Width = 408
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.Font.Bold = False
.Font.Name = "Tahoma"
.ForeColor = &H808000
.TextAlign = fmTextAlignLeft

End With
With CommandButton1

.Left = 6
.Top = 192
.Height = 24
.Width = 96
.Caption = "Get Cache URL List"
.Font.Name = "Tahoma"
.Font.Size = 8
.ForeColor = &H808000
.BackStyle = fmBackStyleTransparent

End With
With CommandButton2

.Left = 108
.Top = 192
.Height = 24
.Width = 96
.Caption = "Delete Cache URL List"
.Font.Name = "Tahoma"
.Font.Size = 8
.ForeColor = &HC0&
.BackStyle = fmBackStyleTransparent

End With
With CommandButton3

.Left = 210
.Top = 192
.Height = 24
.Width = 204
.Caption = "Clear Cache URL List"
.Font.Name = "Tahoma"
.Font.Size = 8
.ForeColor = &HFF&
.BackStyle = fmBackStyleTransparent

End With

End With

End Sub


'Module1


Option Explicit
Public Declare Function CLSIDFromString Lib "ole32" (ByVal lpstrCLSID As Long, lpCLSID As Any) As Long
Public Declare Function OleLoadPicturePath Lib "oleaut32" (ByVal szURLorPath As Long, ByVal punkCaller As Long, ByVal dwReserved As Long, ByVal clrReserved As OLE_COLOR, ByRef riid As Any, ByRef ppvRet As Any) As Long
Public IPic(15) As Byte
Public Const ClsID As Variant = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp"
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg"
Public URL As String
Sub Form_Aç()

On Error Resume Next
UserForm1.Show 0

End Sub
Public Function Resim(URL) As Picture 'Picture load frome web address...

On Error Resume Next
CLSIDFromString StrPtr(ClsID), IPic(0)
OleLoadPicturePath StrPtr(URL), 0&, 0&, 0&, IPic(0), Resim

End Function
'Sub References_List()

'On Error Resume Next
'Dim Eleman, No
'No = 1
'For Each Eleman In ThisWorkbook.VBProject.References

'Sheets(1).Cells(No, 1) = No & ") Name: "
'Sheets(1).Cells(No, 2) = Eleman.Name
'Sheets(1).Cells(No, 3) = ", Description: "
'Sheets(1).Cells(No, 4) = Eleman.Description
'Sheets(1).Cells(No, 5) = ", FullPath: "
'Sheets(1).Cells(No, 6) = Eleman.FullPath
'No = No + 1

'Next Eleman

'End Sub