I think I remember having this problem long ago and I believe I decided it was something to do with the common dialog control. At least I think that is the reason I wrote a function that uses the SHBrowseForFolder API function to select a file. Feel free to use this or not, but it will avoid the problem you are having. The function returns a file name, or an empty string if no file was selected. I hope I got all the declarations in the sample code, I pulled the pieces from a larger general utility module.
Option Explicit
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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As String) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function CreateFile Lib "kernel32" Alias "CreateFileA" (ByVal lpFileName As String, ByVal dwDesiredAccess As Long, ByVal dwShareMode As Long, lpSecurityAttributes As SECURITY_ATTRIBUTES, ByVal dwCreationDisposition As Long, ByVal dwFlagsAndAttributes As Long, ByVal hTemplateFile As Any) As Long
Private Const BIF_INITIALIZED = 1
Private Const BIF_SELCHANGED = 2
Private Const WM_USER = &H400
Private Const BFFM_SETSTATUSTEXT = (WM_USER + 100)
Private Const BFFM_SETSELECTION = (WM_USER + 102)
Private Const BIF_EDITBOX = &H10
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const BIF_STATUSTEXT = &H4&
Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000
Private Const MAX_PATH = 260
Private Const OPEN_EXISTING = 3
Private Const FILE_SHARE_READ = &H1
Private Const FILE_SHARE_WRITE = &H2
Private Const INVALID_HANDLE_VALUE = -1
Private Const GENERIC_READ = &H80000000
Private Const GENERIC_WRITE = &H40000000
Private Const ERROR_SHARING_VIOLATION = 32&
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type BROWSEINFO
hwndOwner As Long
pidlRoot As Long
pszDisplayName As Long
lpszTitle As String
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private mstrInitDir As String 'holds the path from the getfolder function
Private mstrFindFile As String 'holds the filename from the getfolder function
Public Function BrowseForFolder(ByVal hwndOwner As Long, ByVal sDefaultPath As String, ByVal sFindFile As String, _
Optional ByVal sTitle As String = "Select Folder", Optional ByVal ShowMsg As Boolean = True, Optional ShowFiles As Boolean = True) As String
Dim lpIDList As Long
Dim sBuffer As String
Dim szTitle As String
Dim tBrowseInfo As BROWSEINFO
Dim MSG As String
mstrInitDir = sDefaultPath & vbNullChar
mstrFindFile = sFindFile
If ShowMsg = True Then
'display what's happening to the user
MSG = ProgramTitle & " was unable to find the file, '" & sFindFile & "'. " _
& "Please use the following dialog box to set path to this file." _
& vbCrLf & vbCrLf & "If this path is not set " _
& ProgramTitle() & " will be unable to continue."
MsgBox MSG, vbOKOnly + vbInformation, "File Not Found"
End If
'give the user the box
szTitle = sTitle
With tBrowseInfo
.hwndOwner = hwndOwner
.lpszTitle = szTitle 'lstrcat(szTitle, "")
.ulFlags = BIF_RETURNONLYFSDIRS Or BIF_STATUSTEXT '
If ShowFiles = True Then
.ulFlags = .ulFlags Or BIF_BROWSEINCLUDEFILES
End If
.pidlRoot = 0
.lpfnCallback = GetAddressOf(AddressOf BrowseCallBack)
End With
lpIDList = SHBrowseForFolder(tBrowseInfo)
If (lpIDList) Then
sBuffer = Space(MAX_PATH)
SHGetPathFromIDList lpIDList, sBuffer
sBuffer = Left(sBuffer, InStr(sBuffer, vbNullChar) - 1)
BrowseForFolder = sBuffer
End If
End Function
Private Function BrowseCallBack(ByVal hwnd As Long, ByVal uMsg As Long, ByVal lParam As Long, ByVal lpData As Long) As Long
Dim Rtn As Long
Dim sBuffer As String * MAX_PATH
Dim strPath As String
On Error Resume Next 'attempt to prevent error propagation to caller
Select Case uMsg
Case Is = BIF_SELCHANGED
sBuffer = Space$(MAX_PATH)
Rtn = SHGetPathFromIDList(lParam, sBuffer)
If Rtn = 1 Then
If Len(mstrFindFile) > 1 Then
strPath = Left$(sBuffer, InStr(sBuffer, vbNullChar) - 1)
If Right$(strPath, 1) <> "\" Then
strPath = strPath & "\"
End If
If FileExists(strPath & mstrFindFile) = True Then
Rtn = SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, ByVal (mstrFindFile & " found!" & vbNullChar))
Else
Rtn = SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, ByVal ("not found, " & mstrFindFile))
End If
Else
Rtn = SendMessage(hwnd, BFFM_SETSTATUSTEXT, 0, ByVal FormatPath(sBuffer))
End If
End If
Case Is = BIF_INITIALIZED
Rtn = SendMessage(hwnd, BFFM_SETSELECTION, 1, ByVal (mstrInitDir))
End Select
End Function
Function FileExists(ByVal fSpec As String) As Boolean
Dim lngResult As Long
Dim udtSA As SECURITY_ATTRIBUTES
On Error GoTo errFileExists
If Len(fSpec) > 0 Then
udtSA.nLength = Len(udtSA)
udtSA.bInheritHandle = 1&
udtSA.lpSecurityDescriptor = 0&
lngResult = CreateFile(fSpec, GENERIC_READ, FILE_SHARE_READ, udtSA, OPEN_EXISTING, 0&, 0&)
If lngResult <> INVALID_HANDLE_VALUE Then
Call CloseHandle(lngResult)
FileExists = True
Else
Select Case Err.LastDllError 'some errors may indicate the file exists, but there was an error opening it
Case Is = ERROR_SHARING_VIOLATION
FileExists = True
Case Else
FileExists = False
End Select
End If
End If
Exit Function
errFileExists:
Err.Raise Err.Number, Err.Source, Err.Description, Err.HelpFile, Err.HelpContext
End Function
Private Function GetAddressOf(ByVal lpAddr As Long) As Long
GetAddressOf = lpAddr
End Function
Public Function ProgramTitle() As String
Dim sDefaultTitle As String
On Error GoTo errProgramTitle
sDefaultTitle = StrConv(App.EXEName, vbProperCase)
ProgramTitle = IIf(Len(App.ProductName) > 0, App.ProductName, sDefaultTitle)
Exit Function
errProgramTitle:
ProgramTitle = sDefaultTitle
End Function
'format a path to look like C:\Windows\Folder from c:\windows\folder
Public Function FormatPath(ByVal Path As String) As String
Dim sReturn As String
Dim sCurChar As String * 1
Dim sLastChar As String * 1
Dim i As Integer
For i = 1 To Len(Trim$(Path))
sCurChar = Mid$(Path, i, 1)
If sLastChar = vbNullChar Then
sReturn = StrConv(sCurChar, vbUpperCase)
ElseIf sLastChar Like "[/\: ]" Then
sReturn = sReturn & StrConv(sCurChar, vbUpperCase)
Else
sReturn = sReturn & StrConv(sCurChar, vbLowerCase)
End If
sLastChar = sCurChar
Next i
FormatPath = sReturn
End Function
https://stackoverflow.com/questions/19453460
italiano
english
français
española
中国
日本の
العربية
Deutsch
한국어
Português
Russian