TheSwamp
Code Red => VB(A) => Topic started by: Amsterdammed on June 18, 2005, 10:09:31 AM
-
Hello,
I want to add a button to a Excel sheet that allows the user to browse to a desired directory and this path should be than written to a cell (ok, that’s not the problem).
With all the thanks in advance,
Bernd
-
Google for "frank oquendo common dialog control". The class he compiled is top shelf and works quite well.
Or you could look at the sweet API tutorial that Keith put together and make your own.
-
:?: Tim,
API tutorial ?
Obviously I'm not that familiar with all the Swamp features. Can you help me out, please?
Thanks, Bernd
-
I'm refering to an item posted in the "VBA Course" forum. Since you are unaware I assume you are not a member of that group. I'm sure if you contact Mark he'd be more than happy to give you access to that forum.
-
:) Thanks Tim,
I will do so. VBA is normally not what I'm doing (but i want to focus more on), so any source off Help is very welcome.
Bernd
-
I'm sure if you contact Mark he'd be more than happy to give you access to that forum.
Actually CmdrDuh (http://www.theswamp.org/phpBB2/profile.php?mode=viewprofile&u=332) is in charge of that group. But I'm sure he'd be glad to add you to it.
-
Oops. :oops:
-
Tanks Mark
Bernd
-
Here is a simple one that won't require to much knowledge of VBA
Option Explicit
Public 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
Public Const MAX_PATH = 2600
Declare Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32.dll" _
Alias "SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long
Public Function ReturnFolder(ByVal Prompt As String) As String
Dim Browser As BROWSEINFO
Dim lngFolder As Long
Dim strPath As String
With Browser
.hOwner = 0&
.lpszTitle = Prompt
.pszDisplayName = String(MAX_PATH, 0)
End With
strPath = String(MAX_PATH, 0)
lngFolder = SHBrowseForFolder(Browser)
If lngFolder Then
SHGetPathFromIDList lngFolder, strPath
ReturnFolder = Left(strPath, InStr(strPath, vbNullChar) - 1)
End If
End Function
Put it in a new module and then call the dialog like so:
Path = Module1.ReturnFolder("Select Folder")
Enjoy
-
:D Keith,
you are great.
That's true; thanks to you it doesn't require knowledge of VBA
at all. It works perfect.
This helps me a lot to make my stuff look really pro. :cheesy:
Thanks a lot, Bernd
-
you are very welcome
-
If you wanna have a default path for the folder dialog use:
Declare Function SHBrowseForFolder Lib "shell32" Alias "SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) As Long
Declare Function SHGetPathFromIDList Lib "shell32" Alias "SHGetPathFromIDListA" (ByVal pidl As Long, ByVal pszPath As String) As Long
Declare Sub CoTaskMemFree Lib "ole32" (ByVal pv As Long)
Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Public Const WM_USER = &H400
Public Const BFFM_INITIALIZED = 1
Public Const BFFM_SETSTATUSTEXTA As Long = (WM_USER + 100)
Public Const BFFM_SETSTATUSTEXTW As Long = (WM_USER + 104)
Public Const BFFM_ENABLEOK As Long = (WM_USER + 101)
Public Const BFFM_SETSELECTIONA As Long = (WM_USER + 102)
Public Const BFFM_SETSELECTIONW As Long = (WM_USER + 103)
Public Const LMEM_FIXED = &H0
Public Const LMEM_ZEROINIT = &H40
Public Const LPTR = (LMEM_FIXED Or LMEM_ZEROINIT)
Public Const MAX_PATH = 2600
Public 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
'
' - Function MeBrowseForFolderByPath
' Description:
' Opens the folder dialog with a default path.
' Arguments:
' - DefPth = Default path
' - DlgTit = Dialog title
' Returns:
' - Path
' - "" on cancel or error
' Exceptions:
' - None
' Notes:
' - Based on 'Pre-selecting a Folder using the Browse Callback'
' by Randy Birch, VBnet
' Copyright ©1996-2004 VBnet, Randy Birch, All Rights Reserved.
'
Public Function MeBrowseForFolderByPath(ByVal DefPth As String, ByVal DlgTit As String) As String
Dim BrwInf As BROWSEINFO
Dim FoPidl As Long
Dim SelPth As Long
Dim RetVal As String * MAX_PATH
With BrwInf
.hOwner = ThisDrawing.hWnd
.pidlRoot = 0
.lpszTitle = DlgTit
.lpfn = MeFarProc(AddressOf MeBrowseCallbackProcStr)
SelPth = LocalAlloc(LPTR, Len(DefPth) + 1)
CopyMemory ByVal SelPth, ByVal DefPth, Len(DefPth) + 1
.lParam = SelPth
End With
FoPidl = SHBrowseForFolder(BrwInf)
If FoPidl Then
If SHGetPathFromIDList(FoPidl, RetVal) Then
MeBrowseForFolderByPath = MeCutNulls(RetVal)
Else
MeBrowseForFolderByPath = ""
End If
Call CoTaskMemFree(FoPidl)
Else
MeBrowseForFolderByPath = ""
End If
Call LocalFree(SelPth)
End Function
'
' Callback for the Browse STRING method.
' On initialization, set the dialog's
' pre-selected folder from the pointer
' to the path allocated as BrwInf.lParam,
' passed back to the callback as lpData param.
'
Public Function MeBrowseCallbackProcStr(ByVal CurHdl As Long, ByVal UsrMsg As Long, ByVal TmpPrm As Long, _
ByVal CurDat As Long) As Long
Select Case UsrMsg
Case BFFM_INITIALIZED
Call SendMessage(CurHdl, BFFM_SETSELECTIONA, True, ByVal CurDat)
Case Else:
End Select
End Function
'
' A dummy procedure that receives and returns
' the value of the AddressOf operator.
' This workaround is needed as you can't
' assign AddressOf directly to a member of a
' user-defined type, but you can assign it
' to another long and use that instead!
'
Public Function MeFarProc(AdrVal As Long) As Long
MeFarProc = AdrVal
End Function
'
' Removes 'Nulls' in a string.
'
Public Function MeCutNulls(ByVal StrNul As String) As String
MeCutNulls = Left$(StrNul, InStr(StrNul, Chr$(0)) - 1)
End Function
Cheers
-
Juerg,
I'm just back in Amsterdam and my Internet at home is disconected (can happen when you are in Florida to long with an expensive girlfriend, not taking care of all the bills :( ), so I'm in an Internet cafe and can't try your code but i know it will work.
But i wonder, don't you sleep some times? :?:
I know in German "selbststaendig" means working "selbst" and "staendig" :mrgreen:
Bernd
-
But i wonder, don't you sleep some times?
Yeah, some times...but just back from my holidays I've enough power to keep things alive... :mrgreen:
I know in German "selbststaendig" means working "selbst" and "staendig"
You hit the nail on his head :D
Cheers