Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

15 Mayıs 2011 Pazar

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

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