Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

1 Ekim 2011 Cumartesi

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





Hiç yorum yok:

Blog Arşivi

Bu gadget'ta bir hata oluştu

Bu Blogda Ara

Contributor

Contributor
Mustafa ULUSARAÇ İstanbul, TÜRKİYE
free counters
T. C. Central Bank Indicative Exchange Rates
Currency Exchange Rate Widget,Currency Converter Widget
Borsa İstanbul