Salad,
It won't work on A97, you need to use the addrof code from Michael Kaplan
and Ken Getz for that
(
http://www.trigeminal.com/lang/1033/...?ItemID=19#19), but it should
work in AccessXp, I've tested it on A2003 and it certainly worked there.
The line you remmed out is the one which hooks the browse dialog to the
callback function. The callback function changes the start dir to whatever
you want, so I'm not surprised it didn't work after you remmed the line.
--
Terry Kreft
"Salad" <oil@vinegar.com> wrote in message
news:mjN9f.4555$yX2.3504@newsread2.news.pas.earthl ink.net...[color=blue]
> Terry Kreft wrote:
>
> Hi Terry. I can't get your code to work tho the fix looks minor. The
> problem exists on the statement line
> .lpfn = AddrOf2k(AddressOf BrowseCallbackProc)
>
> If I comment the line out, it works as a normal BrowseFolder and puts me
> at MyDocuments. I don't start at "c:\program files" using your example.
>
>[color=green]
>> The following works
>> '**************************************
>> ' Code Start
>> Option Explicit
>>
>> '******************************
>> 'Code Start
>> '******************************
>> Private Type BROWSEINFO
>> hOwner As Long
>> pidlRoot As Long
>> pszDisplayName As Long
>> lpszTitle As Long
>> ' lpszTitle As Byte
>> ulFlags As Long
>> lpfn As Long
>> lParam As Long
>> iImage As Long
>> End Type
>>
>> '******************************
>> 'Functions in BrowseFolder
>> '******************************
>> 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 Declare Sub ZeroMemory _
>> Lib "kernel32" Alias "RtlZeroMemory" _
>> (dest As Long, ByVal numBytes As Long)
>> Private Declare Function lstrcat _
>> Lib "kernel32" Alias "lstrcatA" _
>> (ByVal lpString1 As String, _
>> ByVal lpString2 As String) _
>> As Long
>> '******************************
>> '/Functions in BrowseFolder
>> '******************************
>>
>> Private Declare Function GetFileVersionInfoSize Lib "version.dll" _
>> Alias "GetFileVersionInfoSizeA" _
>> (ByVal lptstrFilename As String, _
>> lpdwHandle As Long) As Long
>>
>> Private Declare Function GetFileVersionInfo Lib "version.dll" _
>> Alias "GetFileVersionInfoA" _
>> (ByVal lptstrFilename As String, _
>> ByVal dwHandle As Long, _
>> ByVal dwLen As Long, _
>> lpData As Any) As Long
>>
>> Private Declare Function VerQueryValue Lib "version.dll" _
>> Alias "VerQueryValueA" _
>> (pBlock As Any, _
>> ByVal lpSubBlock As String, _
>> lpBuffer As Any, _
>> nVerSize As Long) As Long
>>
>> Private Declare Sub CopyMemory Lib "kernel32" _
>> Alias "RtlMoveMemory" _
>> (Destination As Any, _
>> Source As Any, _
>> ByVal Length As Long)
>>
>>
>>
>> '******************************
>> 'Functions used in call back
>> '******************************
>> Private Declare Function GetCurrentDirectory _
>> Lib "kernel32" Alias "GetCurrentDirectoryA" _
>> (ByVal nBufferLength As Long, _
>> ByVal lpBuffer As String) _
>> As Long
>> Private Declare Function SendMessage _
>> Lib "user32" Alias "SendMessageA" _
>> (ByVal hWnd As Long, ByVal wMsg As Long, _
>> ByVal wParam As Long, lParam As Any) _
>> As Long
>> '******************************
>> '/Functions used in call back
>> '******************************
>>
>> '******************************
>> 'Root pidls
>> '******************************
>> Private Const CSIDL_DESKTOP = &H0
>> Private Const CSIDL_PROGRAMS = &H2
>> Private Const CSIDL_CONTROLS = &H3
>> Private Const CSIDL_PRINTERS = &H4
>> Private Const CSIDL_PERSONAL = &H5
>> Private Const CSIDL_FAVORITES = &H6
>> Private Const CSIDL_STARTUP = &H7
>> Private Const CSIDL_RECENT = &H8
>> Private Const CSIDL_SENDTO = &H9
>> Private Const CSIDL_BITBUCKET = &HA
>> Private Const CSIDL_STARTMENU = &HB
>> Private Const CSIDL_DESKTOPDIRECTORY = &H10
>> Private Const CSIDL_DRIVES = &H11
>> Private Const CSIDL_NETWORK = &H12
>> Private Const CSIDL_NETHOOD = &H13
>> Private Const CSIDL_FONTS = &H14
>> Private Const CSIDL_TEMPLATES = &H15
>> '******************************
>> 'Root pidls
>> '******************************
>>
>> '******************************
>> 'uFlag consts
>> '******************************
>> Private Const BIF_DONTGOBELOWDOMAIN = &H2
>> Private Const BIF_STATUSTEXT = &H4
>> Private Const BIF_RETURNFSANCESTORS = &H8
>> Private Const BIF_BROWSEFORCOMPUTER = &H1000
>> Private Const BIF_BROWSEFORPRINTER = &H2000
>> Private Const BIF_RETURNONLYFSDIRS = &H1
>> Private Const BIF_EDITBOX = &H10
>> Private Const BIF_VALIDATE = &H20
>> Private Const BIF_NEWDIALOGSTYLE As Long = &H40
>> Private Const BIF_USENEWUI As Long = (BIF_NEWDIALOGSTYLE Or BIF_EDITBOX)
>> '******************************
>> '/uFlag consts
>> '******************************
>>
>> Private Const WM_USER = &H400
>>
>> '******************************
>> 'Messages from dialog consts
>> '******************************
>> Private Const BFFM_INITIALIZED = 1
>> Private Const BFFM_SELCHANGED = 2
>> Private Const BFFM_VALIDATEFAILEDA = 3
>> Private Const BFFM_VALIDATEFAILED = BFFM_VALIDATEFAILEDA
>> '******************************
>> '/Messages from dialog consts
>> '******************************
>>
>> '******************************
>> 'Messages to dialog consts
>> '******************************
>> Private Const BFFM_SETSELECTIONA = WM_USER + 102
>> Private Const BFFM_SETSELECTION = BFFM_SETSELECTIONA
>> Private Const BFFM_SETSTATUSTEXTA = WM_USER + 100
>> Private Const BFFM_SETSTATUSTEXT = BFFM_SETSTATUSTEXTA
>> '******************************
>> '/Messages to dialog consts
>> '******************************
>>
>> Private Const MAX_PATH = 260
>>
>> Private strStartDir As String
>> '
>>
>> Public Function BrowseFolder(szDialogTitle As String, _
>> Optional StartDir As String = vbNullString, Optional hWnd As Long = 0)
>> As String
>> '*******************************************
>> 'Name: BrowseFolder (Function)
>> 'Purpose: Open API browse for folder dialog
>> 'Author: Terry Kreft
>> 'Date: January 28, 2001, 09:50:20
>> 'Called by: Any
>> 'Calls: AddrOf _
>> Various API calls defined on this module
>> 'Inputs: szDialogTitle - dialog prompt _
>> StartDir - Directory to start the _
>> browse in (Optional)
>> 'Output: Directory selected in browse folder
>> '*******************************************
>>
>> Dim x As Long
>> Dim BI As BROWSEINFO
>> Dim dwIList As Long
>> Dim szPath As String
>> Dim wPos As Integer
>> Dim lngPtr As Long
>> Dim bytBuffer() As Byte
>>
>> strStartDir = StartDir
>> BrowseFolder = ""
>>
>> Call ZeroMemory(VarPtr(BI), Len(BI))
>>
>> ' This has to be 1 element larger than the length
>> ' of the string so that it contains the terminating
>> ' Null character
>> ReDim bytBuffer(0 To Len(szDialogTitle))
>> For lngPtr = 1 To Len(szDialogTitle)
>> bytBuffer(lngPtr - 1) = Asc(Mid(szDialogTitle, lngPtr, 1))
>> Next
>>
>> With BI
>> .pidlRoot = CSIDL_DESKTOP
>> .hOwner = hWnd
>> .lpszTitle = VarPtr(bytBuffer(0))
>> .ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT _
>> Or BIF_EDITBOX Or BIF_VALIDATE
>> If IsShellVersion(5) Then
>> .ulFlags = .ulFlags Or BIF_NEWDIALOGSTYLE
>> End If
>> .lpfn = AddrOf2k(AddressOf BrowseCallbackProc)
>> End With
>> dwIList = SHBrowseForFolder(BI)
>> If dwIList Then
>> szPath = Space$(512)
>> x = SHGetPathFromIDList(dwIList, szPath)
>> If x Then
>> wPos = InStr(szPath, Chr(0))
>> BrowseFolder = Left$(szPath, wPos - 1)
>> End If
>> End If
>> End Function
>>
>> Function BrowseCallbackProc(ByVal hWnd As Long, ByVal uMsg As Long, _
>> ByVal lp As Long, ByVal pData As Long) As Long
>> '*******************************************
>> 'Name: BrowseCallbackProc (Function)
>> 'Purpose: Call back function for BrowseFolder
>> 'Author: Terry Kreft
>> 'Date: January 28, 2001, 09:52:56
>> 'Called by: API Browse Folder dialog
>> 'Calls: Various API functions
>> 'Inputs: See MSDN for description of inputs
>> 'Output:
>> '*******************************************
>> Dim lngRet As Long
>> Dim nBufferLength As Long
>> Dim lpBuffer As String
>>
>> Const apiTrue = 1
>> Const apiFalse = 0
>> Const BAD_DIR = "The directory selected is invalid." _
>> & vbCrLf _
>> & "Do you want to try again"
>>
>> lngRet = apiFalse
>> Select Case uMsg
>> Case BFFM_INITIALIZED
>> If Len(strStartDir) < 1 Then
>> nBufferLength = MAX_PATH
>> lpBuffer = String(MAX_PATH, 0)
>> If GetCurrentDirectory(nBufferLength, lpBuffer) Then
>> Call SendMessage(hWnd, BFFM_SETSELECTION, apiTrue, ByVal
>> lpBuffer)
>> End If
>> Else
>> Call SendMessage(hWnd, BFFM_SETSELECTION, apiTrue, ByVal
>> strStartDir)
>> End If
>> Case BFFM_SELCHANGED
>> 'Set the status window to the currently selected path.
>> lpBuffer = String(MAX_PATH, 0)
>> If SHGetPathFromIDList(lp, lpBuffer) Then
>> lpBuffer = Left(lpBuffer, InStr(lpBuffer, Chr(0)) - 1)
>> Call SendMessage(hWnd, BFFM_SETSTATUSTEXT, apiTrue, ByVal lpBuffer)
>> End If
>> Case BFFM_VALIDATEFAILED
>> 'If the user types an invalid path
>> If MsgBox(BAD_DIR, vbYesNo) = vbYes Then
>> lngRet = apiTrue
>> End If
>> ' Case BFFM_IUNKNOWN
>>
>> Case Else
>> ' Debug.Print uMsg
>> End Select
>> BrowseCallbackProc = lngRet
>> End Function
>>
>> Function AddrOf2k(ByVal lngFnPtr As Long) As Long
>> AddrOf2k = lngFnPtr
>> End Function
>> '******************************
>> 'Code End
>> '******************************
>>
>>
>> Private Function IsShellVersion(ByVal Version As Long) As Boolean
>>
>> 'returns True if the Shell version
>> '(shell32.dll) is equal or later than
>> 'the value passed as 'version'
>> Dim nBufferSize As Long
>> Dim nUnused As Long
>> Dim lpBuffer As Long
>> Dim nVerMajor As Integer
>> Dim bBuffer() As Byte
>>
>> Const sDLLFile As String = "shell32.dll"
>>
>> nBufferSize = GetFileVersionInfoSize(sDLLFile, nUnused)
>>
>> If nBufferSize > 0 Then
>>
>> ReDim bBuffer(nBufferSize - 1) As Byte
>>
>> Call GetFileVersionInfo(sDLLFile, 0&, nBufferSize, bBuffer(0))
>>
>> If VerQueryValue(bBuffer(0), "\", lpBuffer, nUnused) = 1 Then
>>
>> CopyMemory nVerMajor, ByVal lpBuffer + 10, 2
>>
>> IsShellVersion = nVerMajor >= Version
>>
>> End If 'VerQueryValue
>> End If 'nBufferSize
>>
>> End Function
>> ' Code Start
>> '**************************************
>>
>> Copy and paste the code above into a module then call the BrowseFolder
>> function
>>
>> Sample call:-
>>
>> Dim strFolder as String
>>
>> strFolder = BrowseFolder("Find the Folder", "c:\program files")
>>[/color][/color]
