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

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