Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

20 Ekim 2011 Perşembe

SHGetPathFromIDList Function


'UserForm1

'A 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: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: IWshRuntimeLibrary, Description: Windows Script Host Object Model, FullPath: C:\Windows\SysWOW64\wshom.ocx

'6) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B Additional Tolls List
'1) Image1, Label1, label2
'2) CommandButton1
'3) Label3, ListBox1, CommandButton2, CommandButton3
'3) Label4, ListBox2, CommandButton4, CommandButton5
Option Explicit
Private No As Integer
Private Dosya As String
Private FSFKaynak As String
Private Const FSFHedef As String = "C:\Yedek"
Private Kontrol
Private FSObject As FileSystemObject
Private FSFolder As Folder
Private FSPath As Boolean
Private FSFile As File
Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type
Private BI As BROWSEINFO
Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Private BrowsReturn As Long
Private BrowsList As Long
Private BrowsPath As String
Private BrowsPos As Integer
Private CB As office.CommandBar
Private CBB As office.CommandBarButton
Private CBC As office.CommandBarControl
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] SHGetPathFromIDList Function"
Call Ekran_Duzenle
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
ListBox1.Clear
ListBox2.Clear
FSFKaynak = Get_Browse_Folder("Yedeklenecek klasör seçimi")
If Not FSFKaynak = vbNullString Then Call Yedekle
End Sub
Private Sub CommandButton2_Click()
On Error GoTo Hata
If MsgBox("KAYNAK klasördeki dosyları silmek istediğinizden emin misiniz?", vbOKCancel, "[PBİD®] Lütfen Dikkat!") = vbOK Then
Set FSObject = New FileSystemObject
Set FSFolder = FSObject.GetFolder(FSFKaynak)
If Not FSFolder.Files.Count > 0 Then GoTo Hata
For Each FSFile In FSFolder.Files
FSFile.Attributes = Archive
FSFile.Delete False
Next FSFile
ListBox1.Clear
For Each FSFile In FSFolder.Files
ListBox1.AddItem FSFile.Name
Next FSFile
End If
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
Exit Sub
Hata:
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
MsgBox "İşlem Tamamlanamadı!", vbInformation, "[PBİD®] Lütfen Dikkat!"
End Sub
Private Sub CommandButton3_Click()
On Error GoTo Hata
If ListBox1.ListIndex > -1 Then
Dosya = ListBox1.Value
If MsgBox("KAYNAK klasördeki seçili dosyayı silmek istediğinizden emin misiniz?", vbOKCancel, "[PBİD®] Lütfen Dikkat!") = vbOK Then
Set FSObject = New FileSystemObject
Set FSFolder = FSObject.GetFolder(FSFKaynak)
If Not FSFolder.Files.Count > 0 Then GoTo Hata
For Each FSFile In FSFolder.Files
If FSFile.Name = Dosya Then
FSFile.Attributes = Archive
FSFile.Delete False
'VBA.Kill FSFile
End If
Next FSFile
ListBox1.Clear
For Each FSFile In FSFolder.Files
ListBox1.AddItem FSFile.Name
Next FSFile
End If
Else
MsgBox "Silmek için; lütfen bir dosya seçiniz!", vbInformation, "[PBİD®] Lütfen Dikkat!"
End If
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
Exit Sub
Hata:
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
MsgBox "İşlem Tamamlanamadı!", vbInformation, "[PBİD®] Lütfen Dikkat!"
End Sub
Private Sub CommandButton4_Click()
On Error GoTo Hata
If MsgBox("HEDEF klasördeki dosyları silmek istediğinizden emin misiniz?", vbOKCancel, "[PBİD®] Lütfen Dikkat!") = vbOK Then
Set FSObject = New FileSystemObject
Set FSFolder = FSObject.GetFolder(FSFHedef)
If Not FSFolder.Files.Count > 0 Then GoTo Hata
For Each FSFile In FSFolder.Files
FSFile.Attributes = Archive
FSFile.Delete False
Next FSFile
ListBox2.Clear
For Each FSFile In FSFolder.Files
ListBox2.AddItem FSFile.Name
Next FSFile
End If
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
Exit Sub
Hata:
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
MsgBox "İşlem Tamamlanamadı!", vbInformation, "[PBİD®] Lütfen Dikkat!"
End Sub
Private Sub CommandButton5_Click()
On Error GoTo Hata
If ListBox2.ListIndex > -1 Then
Dosya = ListBox2.Value
If MsgBox("HEDEF klasördeki seçili dosyayı silmek istediğinizden emin misiniz?", vbOKCancel, "[PBİD®] Lütfen Dikkat!") = vbOK Then
Set FSObject = New FileSystemObject
Set FSFolder = FSObject.GetFolder(FSFHedef)
If Not FSFolder.Files.Count > 0 Then GoTo Hata
For Each FSFile In FSFolder.Files
If FSFile.Name = Dosya Then
FSFile.Attributes = Archive
FSFile.Delete False
End If
Next FSFile
ListBox2.Clear
For Each FSFile In FSFolder.Files
ListBox2.AddItem FSFile.Name
Next FSFile
End If
Else
MsgBox "Silmek için; lütfen bir dosya seçiniz!", vbInformation, "[PBİD®] Lütfen Dikkat!"
End If
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
Exit Sub
Hata:
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
MsgBox "İşlem Tamamlanamadı!", vbInformation, "[PBİD®] Lütfen Dikkat!"
End Sub
Public Function Get_Browse_Folder(BrowseDialog As String) As String
On Error Resume Next
With BI
.hOwner = &H0
.lpszTitle = BrowseDialog
.ulFlags = &H1
End With
BrowsList = SHBrowseForFolder(BI)
BrowsPath = Space$(512)
BrowsReturn = SHGetPathFromIDList(ByVal BrowsList, ByVal BrowsPath)
If BrowsReturn Then
BrowsPos = InStr(BrowsPath, Chr(0))
Get_Browse_Folder = Left$(BrowsPath, BrowsPos - 1)
Else
Get_Browse_Folder = vbNullString
End If
End Function
Sub Yedekle()
On Error Resume Next
Kontrol = VBA.GetAttr(FSFHedef) And 0
If VBA.Err = 0 Then
FSPath = True
Else
FSPath = False
If FSPath = False Then VBA.MkDir FSFHedef
End If
Label3.Caption = " Source Folder; " & FSFKaynak
Label4.Caption = " Destination Folder; " & FSFHedef
On Error GoTo Hata2
Set FSObject = New FileSystemObject
Set FSFolder = FSObject.GetFolder(FSFKaynak)
No = 0
If Not FSFolder.Files.Count > 0 Then GoTo Hata1
For Each FSFile In FSFolder.Files
FSFile.Copy FSFHedef & "\" & VBA.Format(VBA.Now, "dd.mmm.yyyy ddd hh.mm.ss") & " " & FSFile.Name
ListBox1.AddItem FSFile.Name
ListBox2.AddItem VBA.Format(VBA.Now, "dd.mmm.yyyy ddd hh.mm.ss") & " " & FSFile.Name
No = No + 1
Next FSFile
Set FSFolder = FSObject.GetFolder(ThisWorkbook.Path)
Set FSFile = FSFolder.Files(ThisWorkbook.Name)
FSFile.Copy FSFHedef & "\" & VBA.Format(VBA.Now, "dd.mmm.yyyy ddd hh.mm.ss") & "_" & FSFile.Name
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
Exit Sub
Hata1:
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
Exit Sub
Hata2:
MsgBox "Hata No ve Tanımı: " & Err.Number & Err.Description & vbCrLf & vbCrLf & "Lütfen hedef klasördeki tüm dosyaların şu anda açık olmadığını ve kaynak dizinin kullanıma açık olduğunu kontrol ediniz.", vbInformation, "[PBİD®]"
VBA.Err.Clear
Set FSFile = Nothing
Set FSObject = Nothing
Set FSFolder = Nothing
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 316
.Width = 468
.Picture = Resim(URL1)
.PictureAlignment = fmPictureAlignmentCenter
.PictureSizeMode = fmPictureSizeModeClip
.PictureTiling = True
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 = 318
.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 = 318
.Caption = "01ulusarac@superonline.com"
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectFlat
.BackStyle = fmBackStyleTransparent
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = vbBlue
End With
With CommandButton1
.Caption = "Dosya Kopyalamak İçin Kaynak Klasör Seçimi"
.Left = 6
.Top = 36
.Height = 24
.Width = 450
.BackStyle = fmBackStyleTransparent
.Picture = Resim(URL3)
.PicturePosition = fmPicturePositionLeftCenter
.ForeColor = &H808000
.Enabled = True
End With
With Label3
.Left = 6
.Top = 66
.Height = 24
.Width = 222
.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = &H808000
End With
With Label4
.Left = 234
.Top = 66
.Height = 24
.Width = 222
.Caption = ""
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = &H808000
End With
With ListBox1
.Left = 6
.Top = 90
.Height = 172.55
.Width = 222
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = vbBlue
End With
With CommandButton2
.Caption = "Tüm Orjinal Dosyaları Sil"
.Left = 6
.Top = 264
.Height = 24
.Width = 108
.BackStyle = fmBackStyleTransparent
Call Icon_Make(CommandButton2, 1668)
.PicturePosition = fmPicturePositionLeftCenter
.ForeColor = &H808000
.Enabled = False
End With
With CommandButton3
.Caption = "Seçili Orjinal Dosyayı Sil"
.Left = 120
.Top = 264
.Height = 24
.Width = 108
.BackStyle = fmBackStyleTransparent
Call Icon_Make(CommandButton3, 1019)
.PicturePosition = fmPicturePositionLeftCenter
.ForeColor = &H808000
.Enabled = True
End With
With ListBox2
.Left = 234
.Top = 90
.Height = 172.55
.Width = 222
.BorderStyle = fmBorderStyleNone
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = vbBlue
End With
With CommandButton4
.Caption = "Tüm Kopya Dosyaları Sil"
.Left = 234
.Top = 264
.Height = 24
.Width = 108
.BackStyle = fmBackStyleTransparent
Call Icon_Make(CommandButton4, 1668)
.PicturePosition = fmPicturePositionLeftCenter
.ForeColor = &H808000
.Enabled = True
End With
With CommandButton5
.Caption = "Seçili Kopya Dosyayı Sil"
.Left = 348
.Top = 264
.Height = 24
.Width = 108
.BackStyle = fmBackStyleTransparent
Call Icon_Make(CommandButton5, 1019)
.PicturePosition = fmPicturePositionLeftCenter
.ForeColor = &H808000
.Enabled = True
End With
End With
End Sub
Private Sub Icon_Make(ByVal Obj As Object, ByVal ID As Double)
On Error Resume Next
Set CB = Application.CommandBars.Add("", msoBarPopup, , True)
Set CBB = CB.Controls.Add(1, , , , True)
CBB.FaceId = ID
Obj.Picture = CBB.Picture
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 Const URL3 As String = "http://3.bp.blogspot.com/-T8LAuWdsz_U/TcXIq0lIpPI/AAAAAAAACw4/UnomGxo3OEM/s1600/Dosya_A%25C3%25A7.gif"
Public URL As String
Sub Form_Aç() 'Open UserForm
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

10 Ekim 2011 Pazartesi

Source Array


'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: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE11\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL
'B. Available Tools List
'1) İmage1, Label1, Label2
'2) TextBox1, TextBox2, TextBox3
'3) ListBox1, ListBox2
Option Explicit
Private Veriler As Variant
Private Bellek(1 To 118, 1 To 3)
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®] Source Array"
Call Ekran_Duzenle
Call Veri_Duzenle
End Sub
Private Sub ListBox1_Click()
On Error Resume Next
TextBox1.Value = ListBox1.Value
ListBox2.Value = TextBox1.Value
TextBox2.Value = ListBox2.List(ListBox2.ListIndex, 1)
TextBox3.Value = ListBox2.List(ListBox2.ListIndex, 2)
End Sub
Private Sub TextBox1_Change()
On Error Resume Next
Veriler = Sheet1.Range("A1:A" & Sheet1.Range("A" & Cells.Rows.Count).End(xlUp).Row)
Veriler = Application.Transpose(Veriler)
Veriler = VBA.Filter(SourceArray:=Veriler, Match:=TextBox1.Value, Include:=True, Compare:=vbTextCompare)
With ListBox1
.Clear
.List = Veriler
End With
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 298
.Width = 270
.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 TextBox1
.Left = 6
.Top = 36
.Height = 18
.Width = 168
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H808000
.TextAlign = fmTextAlignLeft
End With
With TextBox2
.Left = 174
.Top = 36
.Height = 18
.Width = 42
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With TextBox3
.Left = 216
.Top = 36
.Height = 18
.Width = 42
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleOpaque
.Font.Bold = True
.Font.Name = "Arial"
.ForeColor = &H808000
.TextAlign = fmTextAlignCenter
End With
With ListBox1
.Left = 6
.Top = 54
.Height = 84.2
.Width = 252
.ColumnCount = 3
.ColumnWidths = "168;42;42"
.SpecialEffect = fmSpecialEffectEtched
End With
With ListBox2
.Left = 6
.Top = 138
.Height = 132.2
.Width = 252
.ColumnCount = 3
.ColumnWidths = "168;42;42"
.SpecialEffect = fmSpecialEffectEtched
End With
End With
End Sub
Private Sub Veri_Duzenle()
On Error Resume Next
Bellek(1, 1) = "Hidrojen": Bellek(1, 2) = "H": Bellek(1, 3) = 1
Bellek(2, 1) = "Helyum": Bellek(2, 2) = "He": Bellek(2, 3) = 2
Bellek(3, 1) = "Lityum": Bellek(3, 2) = "Li": Bellek(3, 3) = 3
Bellek(4, 1) = "Berilyum": Bellek(4, 2) = "Be": Bellek(4, 3) = 4
Bellek(5, 1) = "Bor": Bellek(5, 2) = "B": Bellek(5, 3) = 5
Bellek(6, 1) = "Karbon": Bellek(6, 2) = "C": Bellek(6, 3) = 6
Bellek(7, 1) = "Azot": Bellek(7, 2) = "N": Bellek(7, 3) = 7
Bellek(8, 1) = "Oksijen": Bellek(8, 2) = "O": Bellek(8, 3) = 8
Bellek(9, 1) = "Flor": Bellek(9, 2) = "F": Bellek(9, 3) = 9
Bellek(10, 1) = "Neon": Bellek(10, 2) = "Ne": Bellek(10, 3) = 10
Bellek(11, 1) = "Sodyum": Bellek(11, 2) = "Na": Bellek(11, 3) = 11
Bellek(12, 1) = "Magnezyum": Bellek(12, 2) = "Mg": Bellek(12, 3) = 12
Bellek(13, 1) = "Aluminyum": Bellek(13, 2) = "Al": Bellek(13, 3) = 13
Bellek(14, 1) = "Silisyum": Bellek(14, 2) = "Si": Bellek(14, 3) = 14
Bellek(15, 1) = "Fosfor": Bellek(15, 2) = "P": Bellek(15, 3) = 15
Bellek(16, 1) = "Kükürt": Bellek(16, 2) = "S": Bellek(16, 3) = 16
Bellek(17, 1) = "Klor": Bellek(17, 2) = "Cl": Bellek(17, 3) = 17
Bellek(18, 1) = "Argon": Bellek(18, 2) = "Ar": Bellek(18, 3) = 18
Bellek(19, 1) = "Potasyum": Bellek(19, 2) = "K": Bellek(19, 3) = 19
Bellek(20, 1) = "Kalsiyum": Bellek(20, 2) = "Ca": Bellek(20, 3) = 20
Bellek(21, 1) = "Skandiyum": Bellek(21, 2) = "Sc": Bellek(21, 3) = 21
Bellek(22, 1) = "Titanyum": Bellek(22, 2) = "Ti": Bellek(22, 3) = 22
Bellek(23, 1) = "Vanadyum": Bellek(23, 2) = "V": Bellek(23, 3) = 23
Bellek(24, 1) = "Krom": Bellek(24, 2) = "Cr": Bellek(24, 3) = 24
Bellek(25, 1) = "Mangan": Bellek(25, 2) = "Mn": Bellek(25, 3) = 25
Bellek(26, 1) = "Demir": Bellek(26, 2) = "Fe": Bellek(26, 3) = 26
Bellek(27, 1) = "Kobalt": Bellek(27, 2) = "Co": Bellek(27, 3) = 27
Bellek(28, 1) = "Nikel": Bellek(28, 2) = "Ni": Bellek(28, 3) = 28
Bellek(29, 1) = "Bakır": Bellek(29, 2) = "Cu": Bellek(29, 3) = 29
Bellek(30, 1) = "Çinko": Bellek(30, 2) = "Zn": Bellek(30, 3) = 30
Bellek(31, 1) = "Galyum": Bellek(31, 2) = "Ga": Bellek(31, 3) = 31
Bellek(32, 1) = "Germanyum": Bellek(32, 2) = "Ge": Bellek(32, 3) = 32
Bellek(33, 1) = "Arsenik": Bellek(33, 2) = "As": Bellek(33, 3) = 33
Bellek(34, 1) = "Selenyum": Bellek(34, 2) = "Se": Bellek(34, 3) = 34
Bellek(35, 1) = "Brom": Bellek(35, 2) = "Br": Bellek(35, 3) = 35
Bellek(36, 1) = "Kripton": Bellek(36, 2) = "Kr": Bellek(36, 3) = 36
Bellek(37, 1) = "Rubidyum": Bellek(37, 2) = "Rb": Bellek(37, 3) = 37
Bellek(38, 1) = "Strontiyum": Bellek(38, 2) = "Sr": Bellek(38, 3) = 38
Bellek(39, 1) = "İtriyum": Bellek(39, 2) = "Y": Bellek(39, 3) = 39
Bellek(40, 1) = "Zirkon": Bellek(40, 2) = "Zr": Bellek(40, 3) = 40
Bellek(41, 1) = "Niobyum": Bellek(41, 2) = "Nb": Bellek(41, 3) = 41
Bellek(42, 1) = "Molibden": Bellek(42, 2) = "Mo": Bellek(42, 3) = 42
Bellek(43, 1) = "Tekhnetyum": Bellek(43, 2) = "Tc": Bellek(43, 3) = 43
Bellek(44, 1) = "Rutenyum": Bellek(44, 2) = "Ru": Bellek(44, 3) = 44
Bellek(45, 1) = "Rodyum": Bellek(45, 2) = "Rh": Bellek(45, 3) = 45
Bellek(46, 1) = "Palladyum": Bellek(46, 2) = "Pd": Bellek(46, 3) = 46
Bellek(47, 1) = "Gümüş": Bellek(47, 2) = "Ag": Bellek(47, 3) = 47
Bellek(48, 1) = "Kadmiyum": Bellek(48, 2) = "Cd": Bellek(48, 3) = 48
Bellek(49, 1) = "İndiyum": Bellek(49, 2) = "In": Bellek(49, 3) = 49
Bellek(50, 1) = "Kalay": Bellek(50, 2) = "Sn": Bellek(50, 3) = 50
Bellek(51, 1) = "Antimon": Bellek(51, 2) = "Sb": Bellek(51, 3) = 51
Bellek(52, 1) = "Tellür": Bellek(52, 2) = "Te": Bellek(52, 3) = 52
Bellek(53, 1) = "Iyot": Bellek(53, 2) = "I": Bellek(53, 3) = 53
Bellek(54, 1) = "Ksenon": Bellek(54, 2) = "Xe": Bellek(54, 3) = 54
Bellek(55, 1) = "Sezyum": Bellek(55, 2) = "Cs": Bellek(55, 3) = 55
Bellek(56, 1) = "Baryum": Bellek(56, 2) = "Ba": Bellek(56, 3) = 56
Bellek(57, 1) = "Lantan": Bellek(57, 2) = "La": Bellek(57, 3) = 57
Bellek(58, 1) = "Seryum": Bellek(58, 2) = "Ce": Bellek(58, 3) = 58
Bellek(59, 1) = "Praseodim": Bellek(59, 2) = "Pr": Bellek(59, 3) = 59
Bellek(60, 1) = "Neodim": Bellek(60, 2) = "Nd": Bellek(60, 3) = 60
Bellek(61, 1) = "Prometyum": Bellek(61, 2) = "Pm": Bellek(61, 3) = 61
Bellek(62, 1) = "Samaryum": Bellek(62, 2) = "Sm": Bellek(62, 3) = 62
Bellek(63, 1) = "Evropyum": Bellek(63, 2) = "Eu": Bellek(63, 3) = 63
Bellek(64, 1) = "Gadolinyum": Bellek(64, 2) = "Gd": Bellek(64, 3) = 64
Bellek(65, 1) = "Terbiyum": Bellek(65, 2) = "Tb": Bellek(65, 3) = 65
Bellek(66, 1) = "Disprosiyum": Bellek(66, 2) = "Dy": Bellek(66, 3) = 66
Bellek(67, 1) = "Holmiyum": Bellek(67, 2) = "Ho": Bellek(67, 3) = 67
Bellek(68, 1) = "Erbiyum": Bellek(68, 2) = "Er": Bellek(68, 3) = 68
Bellek(69, 1) = "Tulyum": Bellek(69, 2) = "Tm": Bellek(69, 3) = 69
Bellek(70, 1) = "İtterbiyum": Bellek(70, 2) = "Yb": Bellek(70, 3) = 70
Bellek(71, 1) = "Lutetyum": Bellek(71, 2) = "Lu": Bellek(71, 3) = 71
Bellek(72, 1) = "Hafniyum": Bellek(72, 2) = "Hf": Bellek(72, 3) = 72
Bellek(73, 1) = "Tantal": Bellek(73, 2) = "Ta": Bellek(73, 3) = 73
Bellek(74, 1) = "Tungsten": Bellek(74, 2) = "W": Bellek(74, 3) = 74
Bellek(75, 1) = "Renyum": Bellek(75, 2) = "Re": Bellek(75, 3) = 75
Bellek(76, 1) = "Osmiyum": Bellek(76, 2) = "Os": Bellek(76, 3) = 76
Bellek(77, 1) = "İridyum": Bellek(77, 2) = "Ir": Bellek(77, 3) = 77
Bellek(78, 1) = "Platin": Bellek(78, 2) = "Pt": Bellek(78, 3) = 78
Bellek(79, 1) = "Altın": Bellek(79, 2) = "Au": Bellek(79, 3) = 79
Bellek(80, 1) = "Civa": Bellek(80, 2) = "Hg": Bellek(80, 3) = 80
Bellek(81, 1) = "Talyum": Bellek(81, 2) = "Tl": Bellek(81, 3) = 81
Bellek(82, 1) = "Kurşun": Bellek(82, 2) = "Pb": Bellek(82, 3) = 82
Bellek(83, 1) = "Bizmut": Bellek(83, 2) = "Bi": Bellek(83, 3) = 83
Bellek(84, 1) = "Polonyum": Bellek(84, 2) = "Po": Bellek(84, 3) = 84
Bellek(85, 1) = "Astatin": Bellek(85, 2) = "At": Bellek(85, 3) = 85
Bellek(86, 1) = "Radon": Bellek(86, 2) = "Rn": Bellek(86, 3) = 86
Bellek(87, 1) = "Fransiyum": Bellek(87, 2) = "Fr": Bellek(87, 3) = 87
Bellek(88, 1) = "Radyum": Bellek(88, 2) = "Ra": Bellek(88, 3) = 88
Bellek(89, 1) = "Aktinyum": Bellek(89, 2) = "Ac": Bellek(89, 3) = 89
Bellek(90, 1) = "Toryum": Bellek(90, 2) = "Th": Bellek(90, 3) = 90
Bellek(91, 1) = "Protaktinyum": Bellek(91, 2) = "Pa": Bellek(91, 3) = 91
Bellek(92, 1) = "Uranyum": Bellek(92, 2) = "U": Bellek(92, 3) = 92
Bellek(93, 1) = "Neptünyum": Bellek(93, 2) = "Np": Bellek(93, 3) = 93
Bellek(94, 1) = "Plutonyum": Bellek(94, 2) = "Pu": Bellek(94, 3) = 94
Bellek(95, 1) = "Amerikyum": Bellek(95, 2) = "Am": Bellek(95, 3) = 95
Bellek(96, 1) = "Kuriyum": Bellek(96, 2) = "Cm": Bellek(96, 3) = 96
Bellek(97, 1) = "Berkelyum": Bellek(97, 2) = "Bk": Bellek(97, 3) = 97
Bellek(98, 1) = "Kaliforniyum": Bellek(98, 2) = "Cf": Bellek(98, 3) = 98
Bellek(99, 1) = "Einsteinium": Bellek(99, 2) = "Es": Bellek(99, 3) = 99
Bellek(100, 1) = "Fermiyum": Bellek(100, 2) = "Fm": Bellek(100, 3) = 100
Bellek(101, 1) = "Mendelevyum": Bellek(101, 2) = "Md": Bellek(101, 3) = 101
Bellek(102, 1) = "Nobelyum": Bellek(102, 2) = "No": Bellek(102, 3) = 102
Bellek(103, 1) = "Lavrensiyum": Bellek(103, 2) = "Lr": Bellek(103, 3) = 103
Bellek(104, 1) = "Rutherfordiyum": Bellek(104, 2) = "Rf": Bellek(104, 3) = 104
Bellek(105, 1) = "Dubniyum": Bellek(105, 2) = "Db": Bellek(105, 3) = 105
Bellek(106, 1) = "Seaborgiyum": Bellek(106, 2) = "Sg": Bellek(106, 3) = 106
Bellek(107, 1) = "Bohriyum": Bellek(107, 2) = "Bh": Bellek(107, 3) = 107
Bellek(108, 1) = "Hassiyum": Bellek(108, 2) = "Hs": Bellek(108, 3) = 108
Bellek(109, 1) = "Meitneriyum": Bellek(109, 2) = "Mt": Bellek(109, 3) = 109
Bellek(110, 1) = "Darmstadtiyum": Bellek(110, 2) = "Ds": Bellek(110, 3) = 110
Bellek(111, 1) = "Ununnilyum": Bellek(111, 2) = "Uuu": Bellek(111, 3) = 111
Bellek(112, 1) = "Ununbiyum": Bellek(112, 2) = "Uub": Bellek(112, 3) = 112
Bellek(113, 1) = "Ununtriyum": Bellek(113, 2) = "Uut": Bellek(113, 3) = 113
Bellek(114, 1) = "Ununkuadyum": Bellek(114, 2) = "Uuq": Bellek(114, 3) = 114
Bellek(115, 1) = "Ununpentiyum": Bellek(115, 2) = "Uup": Bellek(115, 3) = 115
Bellek(116, 1) = "Ununheksiyum": Bellek(116, 2) = "Uuh": Bellek(116, 3) = 116
Bellek(117, 1) = "Ununseptiyum": Bellek(117, 2) = "Uus": Bellek(117, 3) = 117
Bellek(118, 1) = "Ununoktiyum": Bellek(118, 2) = "Uuo": Bellek(118, 3) = 118
ThisWorkbook.Sheets(1).Range("A1:C118") = Bellek
Veriler = Sheet1.Range("A1:C" & Sheet1.Range("A" & Cells.Rows.Count).End(xlUp).Row)
ListBox2.List = Veriler
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

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





Blog Arşivi

Gadget

Bu içerik henüz şifreli bağlantı üzerinden kullanılamıyor.

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
Anadolu Üniversitesi Açık Öğretim Fakültesi