Getting a Folder's ID

'UserForm1


'A. Available References List

'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\PROGRA~2\COMMON~1\MICROS~1\VBA\VBA7\VBE7.DLL
'2) Name: Excel, Description: Microsoft Excel 14.0 Object Library, FullPath: C:\Program Files (x86)\Microsoft Office\Office14\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\Windows\SysWOW64\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 14.0 Object Library, FullPath: C:\Program Files (x86)\Common Files\Microsoft Shared\OFFICE14\MSO.DLL
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\Windows\SysWOW64\FM20.DLL

'A. Available Tools List

'1) İmage1
'2) Label1
'3) Label2
'4) ComboBox1
'5) ComboBox2
'6) Label3

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 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 i As Single
Private GF As String
Private BI As BROWSEINFO
Private GFPath As String
Private GFList As Long
Private GFFolder As Long
Private GFPosition As Integer
Private pidlRootList(1 To 62, 1 To 1)
Private ulFlagsList(1 To 12, 1 To 2)
Private Sub UserForm_Initialize()

Me.Caption = "[PBİD®] Getting a Folder's ID"
Call pidlRootList_Kur
Call ulFlagsList_Kur
Call Ekran_Duzenle

End Sub
Sub ComboBox1_Click()

On Error Resume Next
GF = GetFolder("[PBİD®] Klasör Seçimi", ComboBox1.ListIndex, ComboBox2.List(ComboBox2.ListIndex, 1))
If GF = "" Then Exit Sub
Label3.Caption = GF

End Sub
Sub ComboBox2_Click()

On Error Resume Next
GF = GetFolder("[PBİD®] Klasör Seçimi", ComboBox1.ListIndex, ComboBox2.List(ComboBox2.ListIndex, 1))
If GF = "" Then Exit Sub
Label3.Caption = GF

End Sub
Function GetFolder(Optional Msg, Optional RN As Long, Optional FN As Long) As String

On Error Resume Next
BI.pidlRoot = RN&
BI.lpszTitle = Msg
BI.ulFlags = FN
GFFolder = SHBrowseForFolder(BI)
GFPath = Space$(512)
GFList = SHGetPathFromIDList(ByVal GFFolder, ByVal GFPath)
If GFList Then

GFPosition = InStr(GFPath, Chr$(0))
GetFolder = Left(GFPath, GFPosition - 1)

Else

GetFolder = ""

End If

End Function
Private Sub Ekran_Duzenle()

On Error Resume Next
With Me

.BackColor = vbWhite
.Height = 250
.Width = 240
.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 ComboBox1

.ColumnCount = 1
.Left = 6
.Top = 36
.Height = 18
.Width = 222
.BackStyle = fmBackStyleOpaque
.BackColor = vbWhite
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectEtched
.List() = pidlRootList

End With
With ComboBox2

.ColumnCount = 2
.ColumnWidths = "160;42"
.Left = 6
.Top = 60
.Height = 18
.Width = 222
.BackStyle = fmBackStyleOpaque
.BackColor = vbWhite
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = vbBlue
.SpecialEffect = fmSpecialEffectEtched
.List() = ulFlagsList

End With
With Label3

.Left = 6
.Top = 84
.Height = 138
.Width = 222
.Caption = ""
.SpecialEffect = fmSpecialEffectEtched
.BackStyle = fmBackStyleTransparent
.Font.Bold = False
.Font.Name = "Arial"
.ForeColor = &H404000

End With

End With

End Sub
Private Sub pidlRootList_Kur()

On Error Resume Next
pidlRootList(1, 1) = "My Computer (Desktop)"
pidlRootList(2, 1) = "IE "
pidlRootList(3, 1) = "Programs"
pidlRootList(4, 1) = "ControlPanel"
pidlRootList(5, 1) = "InstalledPrinters"
pidlRootList(6, 1) = "Personal"
pidlRootList(7, 1) = "Favorites"
pidlRootList(8, 1) = "StartupPmGroup"
pidlRootList(9, 1) = "RecentDocDir"
pidlRootList(10, 1) = "SendToItemsDir"
pidlRootList(11, 1) = "RecycleBin"
pidlRootList(12, 1) = "StartMenu"
pidlRootList(13, 1) = "DesktopDirectory"
pidlRootList(14, 1) = "MyComputer"
pidlRootList(15, 1) = "NetworkNeighborhood"
pidlRootList(16, 1) = "NetHoodFileSystemDir"
pidlRootList(17, 1) = "Fonts"
pidlRootList(18, 1) = "Templates"
pidlRootList(19, 1) = "Network"
pidlRootList(20, 1) = "Network Shortcuts"
pidlRootList(21, 1) = "Fonts"
pidlRootList(22, 1) = "Templates"
pidlRootList(23, 1) = "Start Menu"
pidlRootList(24, 1) = "Programs"
pidlRootList(25, 1) = "Start-Fancy"
pidlRootList(26, 1) = "ShareDesktop"
pidlRootList(27, 1) = "Roaming"
pidlRootList(28, 1) = "MyPictures"
pidlRootList(29, 1) = "Local"
pidlRootList(30, 1) = "Start-OneNote"
pidlRootList(31, 1) = "Start-Bluetooth"
pidlRootList(32, 1) = "NetAndDialUpConnections"
pidlRootList(33, 1) = "Temporary Internet Files"
pidlRootList(34, 1) = "Cookies"
pidlRootList(35, 1) = "History"
pidlRootList(36, 1) = "ProgramData"
pidlRootList(37, 1) = "Windows"
pidlRootList(38, 1) = "System32"
pidlRootList(39, 1) = "Program Files (x86)"
pidlRootList(40, 1) = "MyPictures"
pidlRootList(41, 1) = "Administrator"
pidlRootList(42, 1) = "Syswow64"
pidlRootList(43, 1) = "Program Files (x86)"
pidlRootList(44, 1) = "Common Files"
pidlRootList(45, 1) = "Common Files"
pidlRootList(46, 1) = "Templates"
pidlRootList(47, 1) = "Share Documents"
pidlRootList(48, 1) = "Manegment Tools"
pidlRootList(49, 1) = "Manegment Tools"
pidlRootList(50, 1) = "Network Connections"
pidlRootList(51, 1) = ""
pidlRootList(52, 1) = ""
pidlRootList(53, 1) = ""
pidlRootList(54, 1) = "Share Music"
pidlRootList(55, 1) = "Share Picture"
pidlRootList(56, 1) = "Share Video"
pidlRootList(57, 1) = "Resources"
pidlRootList(58, 1) = ""
pidlRootList(59, 1) = "OEM Links"
pidlRootList(60, 1) = "Temporary Print Folder"
pidlRootList(61, 1) = ""
pidlRootList(62, 1) = "PC"

End Sub
Private Sub ulFlagsList_Kur()

On Error Resume Next
ulFlagsList(1, 1) = "RETURNONLYFSDIRS": ulFlagsList(1, 2) = "1"
ulFlagsList(2, 1) = "DONTGOBELOWDOMAIN": ulFlagsList(2, 2) = "2"
ulFlagsList(3, 1) = "STATUSTEXT": ulFlagsList(3, 2) = "4"
ulFlagsList(4, 1) = "RETURNFSANCESTORS": ulFlagsList(4, 2) = "8"
ulFlagsList(5, 1) = "EDITBOX": ulFlagsList(5, 2) = "16"
ulFlagsList(6, 1) = "VALIDATE": ulFlagsList(6, 2) = "32"
ulFlagsList(7, 1) = "NEWDIALOGSTYLE": ulFlagsList(7, 2) = "64"
ulFlagsList(8, 1) = "BROWSEINCLUDEURLS": ulFlagsList(8, 2) = "128"
ulFlagsList(9, 1) = "BROWSEFORCOMPUTER": ulFlagsList(9, 2) = "&H1000"
ulFlagsList(10, 1) = "BROWSEFORPRINTER": ulFlagsList(10, 2) = "&H2000"
ulFlagsList(11, 1) = "BROWSEINCLUDEFILES": ulFlagsList(11, 2) = "&H4000"
ulFlagsList(12, 1) = "SHAREABLE": ulFlagsList(12, 2) = "&H8000"

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}" 'It may take a few seconds, please wait.
Public Const URL1 As String = "http://2.bp.blogspot.com/-G3KDFVP7V0Q/TcUhtYtMifI/AAAAAAAACw0/Ta6mFpFJtZ8/s1600/39.bmp" 'Microsoft Office Excel® Kod Kılavuzu [PBİD BackroundPicture]
Public Const URL2 As String = "http://2.bp.blogspot.com/_hsHTxo_5L8E/S78EbvJyhRI/AAAAAAAACS0/txbOQ1qubg8/s1600/PB%C4%B0D_jpg.jpg" 'Microsoft Office Excel® Kod Kılavuzu [PBİD Icon]
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