Microsoft Office Excel ® Kod Kılavuzu

Microsoft Office Excel® Code Guide

10 Haziran 2011 Cuma

Browse For Folder Functions

'UserForm1

'A References List
'1) Name: VBA, Description: Visual Basic For Applications, FullPath: C:\Program Files\Common Files\Microsoft Shared\VBA\VBA6\VBE6.DLL
'2) Name: Excel, Description: Microsoft Excel 11.0 Object Library, FullPath: C:\Program Files\Microsoft Office\OFFICE11\EXCEL.EXE
'3) Name: stdole, Description: OLE Automation, FullPath: C:\WINDOWS\system32\stdole2.tlb
'4) Name: Office, Description: Microsoft Office 11.0 Object Library, FullPath: C:\Program Files\Common Files\Microsoft Shared\OFFICE11\mso.dll
'5) Name: MSForms, Description: Microsoft Forms 2.0 Object Library, FullPath: C:\WINDOWS\system32\FM20.DLL
'B Additional Tolls List
'Image1, Label1, label2
'CommandButton1
'TextBox1
Option Explicit
Private GetFolderName As String
Private IStyle As Long
Private Sub UserForm_Initialize()
On Error Resume Next
Me.Caption = "[PBİD®]Browse For Folder Functions"
Call Ekran_Duzenle
TextBox1.Text = VBA.CurDir
UFhWnd = FindWindow("ThunderDFrame", Me.Caption)
End Sub
Private Sub CommandButton1_Click()
On Error Resume Next
GetFolderName = Folder_Browse(UFhWnd, "Select your folder", TextBox1.Text)
If VBA.Len(GetFolderName) = 0 Then Exit Sub
TextBox1.Text = GetFolderName
VBA.ChDrive VBA.Split(TextBox1.Text, "\")(0)
VBA.ChDir TextBox1.Text
End Sub
Private Sub Ekran_Duzenle()
On Error Resume Next
With Me
.BackColor = vbWhite
.Height = 92
.Width = 522
.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 = "Default Folder Chose"
.Left = 6
.Top = 36
.Height = 24
.Width = 84
End With
With TextBox1
.Left = 96
.Top = 36
.Height = 24
.Width = 414
.AutoSize = False
.BackStyle = fmBackStyleTransparent
.Locked = True
.MultiLine = True
.ScrollBars = fmScrollBarsBoth
.SpecialEffect = fmSpecialEffectEtched
.ForeColor = &H404000
.Font.Bold = True
End With
End With
End Sub


'Module1


Option Explicit
Public UFhWnd As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpFT As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private BI As BrowseInfo
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private CF As String 'Current Folder
Private FIDL As Long 'Folder ID List
Private FT As String 'Folder Title
Private FB As String 'Folder Buffer
Private RF As Long 'Folder Return
Public Function Folder_Browse(ByVal hWnd As Long, Title As String, StartDir As String) As String
On Error Resume Next
CF = StartDir & vbNullChar
FT = Title
With BI
.hWndOwner = hWnd
.lpFT = lstrcat(FT, "")
.ulFlags = 1 + 2 + &H4&
.lpfnCallback = Folder_Adress(AddressOf Browse_Procedure)
End With
FIDL = SHBrowseForFolder(BI)
If (FIDL) Then
FB = Space(260)
SHGetPathFromIDList FIDL, FB
FB = Left(FB, InStr(FB, vbNullChar) - 1)
Folder_Browse = FB
Else
Folder_Browse = ""
End If
End Function
Private Function Browse_Procedure(ByVal hWnd As Long, ByVal uMsg As Long, ByVal lp As Long, ByVal pData As Long) As Long
On Error Resume Next
Select Case uMsg
Case 1
Call SendMessage(hWnd, (&H400 + 102), 1, CF)
Case 2
FB = Space(260)
RF = SHGetPathFromIDList(lp, FB)
If RF = 1 Then
Call SendMessage(hWnd, (&H400 + 100), 0, FB)
End If
End Select
Browse_Procedure = 0
End Function
Private Function Folder_Adress(Additional As Long) As Long
On Error Resume Next
Folder_Adress = Additional
End Function


'Module2


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