Browse Folder Screen (Windows 2016 Server (64 bits))

cheer

Registered User.
Local time
Tomorrow, 02:57
Joined
Oct 30, 2009
Messages
222
Anyone know how to write API codes to display the Folder Browse under the Windows 2016 Server (64 bits). My previous API codes fine under the Windows 2013 Server (64 bits) and the Windows 7 (64 bits).

The previous API codes (compliance with the Windows 2013 Server [64 bits[ and the Windows 7 [64 bits] but not to the Windows 2016 Server [64 bits]) are as followed

Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
(ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long
Private Const BIF_RETURNONLYFSDIRS As Long = 1
Private Const CSIDL_DRIVES As Long = &H11
Private Const WM_USER As Long = &H400
Private Const MAX_PATH As Long = 260
Public Type BrowseInfo
hWndOwner As LongPtr
pIDLRoot As LongPtr
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfnCallback As LongPtr
lParam As LongPtr
iImage As Long
End Type
Public Function FolderBrowse(ByVal sDialogTitle As String, ByVal sInitFolder As String) As String
Dim ReturnPath As String

Dim b(MAX_PATH) As Byte
Dim pItem As Long
Dim sFullPath As String
Dim bi As BrowseInfo
Dim ppidl As Long

sInitFolder = CorrectPath(sInitFolder)

' Note VBA windows and dialogs do not have an hWnd property.
bi.hWndOwner = 0 'Windows Main Screen handle.

' SHGetSpecialFolderLocation bi.hWndOwner, CSIDL_DRIVES, ppidl
bi.pIDLRoot = 0 'ppidl

bi.pszDisplayName = VarPtr(b(0))
bi.lpszTitle = sDialogTitle
bi.ulFlags = BIF_RETURNONLYFSDIRS
If FolderExists(sInitFolder) Then bi.lpfnCallback = PtrToFunction(AddressOf BFFCallback)
bi.lParam = StrPtr(sInitFolder)

pItem = SHBrowseForFolder(bi)

If pItem Then ' Succeeded
sFullPath = Space$(MAX_PATH)
If SHGetPathFromIDList(pItem, sFullPath) Then
ReturnPath = Left$(sFullPath, InStr(sFullPath, vbNullChar) - 1) ' Strip nulls
CoTaskMemFree pItem
End If
End If

If ReturnPath <> "" Then
If Right$(ReturnPath, 1) <> "" Then
ReturnPath = ReturnPath & ""
End If
End If

FolderBrowse = ReturnPath
End Function
 
you may try this, just change the name
of the function to FolderBrowse, currently
the name is BrowseFolder.

Code:
Option Compare Database
Option Explicit

'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft

'Some modifications made by Peter De Baets of
'Peter's Software - http://www.peterssoftware.com
'
'FYI: The file open/save dialog module can be found here:
'http://www.mvps.org/access/api/api0001.htm
'
'-----------------------------------------------------
' MODIFIED by agpuzon for x64 system
' now, can be used both on x86 and x64 Access
'-----------------------------------------------------

#If VBA7 Or Win64 Then

    Private Type BROWSEINFO
        hOwner As LongPtr
        pidlRoot As LongPtr
        pszDisplayName As String
        lpszTitle As String
        ulFlags As Long
        lpfn As LongPtr
        lParam As LongPtr
        iImage As Long
    End Type
    
    Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" Alias "SHGetPathFromIDListA" _
            (ByVal pidl As LongPtr, ByVal pszPath As String) As Long
            
    Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" Alias "SHBrowseForFolderA" _
        (lpBrowseInfo As BROWSEINFO) As LongPtr
#Else

    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 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
            
#End If
Private Const BIF_RETURNONLYFSDIRS = &H1

Sub a_test()
Dim strFolderName As String

strFolderName = BrowseFolder("Please select a folder.")

MsgBox strFolderName

End Sub


Public Function BrowseFolder(Optional szDialogTitle As String = "") As String
'* This function returns a folder selected in the Windows folder browse common dialog
'* it was modified by Peter De Baets to always return a folder string with a trailing "\"
  Dim x As Long, bi As BROWSEINFO
#If Win64 Or VBA7 Then
  Dim dwIList As LongPtr
#Else
  Dim dwIList As Long
#End If
  Dim szPath As String, wPos As Integer
  Dim strRtn As String
  
    strRtn = ""
  
    With bi
        .hOwner = hWndAccessApp
        .lpszTitle = szDialogTitle
        .ulFlags = BIF_RETURNONLYFSDIRS
    End With
    
    dwIList = SHBrowseForFolder(bi)
    szPath = Space$(512)
    'szPath = String$(512, Chr(0))
    x = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)
    
    If x Then
        wPos = InStr(szPath, Chr(0))
        strRtn = left$(szPath, wPos - 1)
    Else
        strRtn = ""
    End If
    
    '* Make sure that the folder is always returned with a backslash at the end
    If right(strRtn, 1) = "\" Then
    Else
        If IsNull(strRtn) Or strRtn = "" Then
        Else
            strRtn = strRtn & "\"
        End If
    End If
    BrowseFolder = strRtn
End Function
 
Thanks !It works !

Solved!
 

Users who are viewing this thread

Back
Top Bottom