Hello
I had already seen this technique but I would have liked to select a
Maybe a missing reference?
Check out this topic if you find the right solution:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:QG0F7bLmQaOUb70yb4BJfw
I've tried several macros, Christian Chu's one works but it doesn't open the dialog box I want, it's the simplified version of folder selection that it opens for my part the other macros don't work
an old macro crashes excel and SW
Private Type BrowseInfo
hWndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Declare ptrsafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare ptrsafe Function lstrcat Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare ptrsafe Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare ptrsafe Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal lpBuffer As String) As Long
Public Function ChoixDossier(Titre)
Dim Rien As Integer
Dim Liste As Long
Dim Resultat As String
Dim Browse_info As BrowseInfo
With Browse_info
.lpszTitle = lstrcat(Titre, "")
.ulFlags = 1
End With
Liste = SHBrowseForFolder(Browse_info)
If Liste Then
Resultat = String$(260, 0)
SHGetPathFromIDList Liste, Resultat
CoTaskMemFree Liste
Rien = InStr(Resultat, vbNullChar)
If Rien Then
ChoixDossier = Left$(Resultat, Rien - 1)
End If
End If
End Function
Sub Test()
MsgBox ChoixDossier("Choisissez le dossier")
End Sub
what I'm looking for is the equivalent of msoFileDialogFolderPicker / Application.FileDialog(4). Show
This dialog can be activated as on the screenshot but I don't see how to launch it from vba
capture_000130.png
I just found this topic on this same forum:
https://www.lynkoa.com/forum/import-export-formats-neutres/vba-afficher-bo%C3%AEte-de-dialogue-de-s%C3%A9lection-de-dossier-avec-chem
With a little luck you will find what you want.
Hello
This does not display the correct dialog box
You have to look at the last post of the previous link which refers to a link and a post of @liryc
https://www.lynkoa.com/forum/solidworks/bouton-parcourir-macro-vba
Hoping it's the right dialog box this time:
For the code in the 1st module:
Dim swApp As SldWorks.SldWorks
Dim FileName As String
Dim Filter As String
Dim fileConfig As String
Dim fileDispName As String
Dim fileOptions As Long
'Sub main()
'Set swApp = Application.SldWorks
'Filter = "SolidWorks Files (*.slddrw)|*.slddrw" 'Filtre les types de fichiers
'FileName = swApp.GetOpenFileName("File to Attach", "", Filter, fileOptions, fileConfig, fileDispName)
'End Sub
Dim MonDoss As String
Sub main()
MonDoss = FolderBrowse("Choisir un répertoire à traiter...", "C:\")
End Sub
In another module for the same swp file:
Private Declare PtrSafe Function SHBrowseForFolder Lib "shell32.dll" _
Alias "SHBrowseForFolderA" (lpBrowseInfo As BrowseInfo) As Long
Private Declare PtrSafe Function SHGetPathFromIDList Lib "shell32.dll" _
(ByVal pidList As LongPtr, ByVal lpBuffer As String) As Long
Public Declare PtrSafe Function SendMessageA Lib "user32" _
(ByVal Hwnd As LongPtr, ByVal wMsg As Long, _
ByVal wParam As LongPtr, lParam As Any) As LongPtr
Private Declare PtrSafe Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As LongPtr)
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
'// message from browser
Private Const BFFM_INITIALIZED As Long = 1
Private Const BFFM_SELCHANGED As Long = 2
Private Const BFFM_VALIDATEFAILEDA As Long = 3 '// lParam:szPath ret:1(cont),0(EndDialog)
Private Const BFFM_VALIDATEFAILEDW As Long = 4 '// lParam:wzPath ret:1(cont),0(EndDialog)
Private Const BFFM_IUNKNOWN As Long = 5 '// provides IUnknown to client. lParam: IUnknown*
'// messages to browser
Private Const BFFM_SETSTATUSTEXTA As Long = WM_USER + 100
Private Const BFFM_ENABLEOK As Long = WM_USER + 101
Private Const BFFM_SETSELECTIONA As Long = WM_USER + 102
Private Const BFFM_SETSELECTIONW As Long = WM_USER + 103
Private Const BFFM_SETSTATUSTEXTW As Long = WM_USER + 104
Private Const BFFM_SETOKTEXT As Long = WM_USER + 105 '// Unicode only
Private Const BFFM_SETEXPANDED As Long = WM_USER + 106 '// Unicode only
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
'====== Folder Browser for 64 bit VBA 7 ========
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
' typedef int (CALLBACK* BFFCALLBACK)(HWND hwnd, UINT uMsg, LPARAM lParam, LPARAM lpData);
Private Function BFFCallback(ByVal Hwnd As LongPtr, ByVal uMsg As LongPtr, ByVal lParam As LongPtr, ByVal sData As String) As LongPtr
If uMsg = BFFM_INITIALIZED Then
SendMessageA Hwnd, BFFM_SETSELECTIONA, True, ByVal sData
End If
End Function
Private Function PtrToFunction(ByVal lFcnPtr As LongPtr) As LongPtr
PtrToFunction = lFcnPtr
End Function
Private Function CorrectPath(ByVal sPath As String) As String
If Right$(sPath, 1) = "\" Then
If Len(sPath) > 3 Then sPath = Left$(sPath, Len(sPath) - 1) ' Strip backslash from non-root
Else
If Len(sPath) = 2 Then sPath = sPath & "\" ' Append backslash to root
End If
CorrectPath = sPath
End Function
Public Function FolderExists(ByVal sFolderName As String) As Boolean
Dim att As Long
On Error Resume Next
att = GetAttr(sFolderName)
If Err.Number = 0 Then
FolderExists = True
Else
Err.Clear
FolderExists = False
End If
On Error GoTo 0
End Function
Hello
it's not the right dialog box that is displayed moreover it's a real gas factory, which crashes SW at home and which can be written with a much shorter code in the exes I've already seen
Hello @ll,
The code for your initial macro refers to the fileDialog object that exists in Microsoft's Office galaxy, but not in VBA or SolidWorks APIs.
If you have Excel installed on your PC, the following code, which uses the Excel Application object, might work.
Kind regards.
Option Explicit
Sub selectionDossier()
' Valeur de constante à passer à fileDialog en fonction de l'usage attendu (cf. aide Microsoft)
Const msoFileDialogOpen = 1 ' Permet à l'utilisateur d'ouvrir un fichier.
Const msoFileDialogSaveAs = 2 ' Permet à l'utilisateur d'enregistrer un fichier.
Const msoFileDialogFilePicker = 3 ' Permet à l'utilisateur de sélectionner un fichier.
Const msoFileDialogFolderPicker = 4 ' Permet à l'utilisateur de sélectionner un dossier.
Dim xlsheet As Object
Dim xlFileDialog As Object
Dim dossier As String
Set xlsheet = CreateObject("Excel.Sheet")
Set xlFileDialog = xlsheet.Application.FileDialog(msoFileDialogFolderPicker)
With xlFileDialog
.Title = "Selectionner dossier"
.InitialFileName = "C:\"
.Show
dossier = .SelectedItems(1)
End With
Set xlsheet = Nothing
If Len(dossier) > 0 Then
MsgBox "Dossier sélectionné : " & dossier
Else
MsgBox "Abandon"
End If
End Sub
1 Like
It works well, thank you
If someone has the code for the SW dialog box rather than excel it should be shorter
I added the case of the undo button
Sub selectionDossier()
'Const msoFileDialogOpen = 1 ' Ouvrir un fichier
'Const msoFileDialogSaveAs = 2 ' Enregistrer un fichier
'Const msoFileDialogFilePicker = 3 ' Sélectionner un fichier
Const msoFileDialogFolderPicker = 4 ' Sélectionner un dossier
Dim xlsheet As Object
Dim xlFileDialog As Object
Dim dossier As String
Set xlsheet = CreateObject("Excel.Sheet")
Set xlFileDialog = xlsheet.Application.FileDialog(msoFileDialogFolderPicker)
With xlFileDialog
.Title = "Selectionner dossier"
.InitialFileName = "C:\"
If .Show <> 0 Then '<> BT Annuler
dossier = .SelectedItems(1)
End If
End With
Set xlsheet = Nothing
End Sub
Nothing to do with the subject
I have made available a Minecraft macro on SW for those who are interested: Lynkoa Community / TUTORIALS
Thanks for the code @m.blt
you just have to replace the With block with this code to handle the error on cancellation:
dossier = vbNullString
With xlFileDialog
.Title = "Selectionner dossier"
.InitialFileName = "C:\"
.Show
On Error Resume Next 'gère la cancel error
dossier = .SelectedItems(1)
End With
Via solidworks directly = impossible with FileDialog as @m.blt says:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:oJZLfucoQ9OmlIPXWjDnzA
Found 2 roundabout methods:
https://thecadcoder.com/vba/browse-solidworks-file/
one via Excel like @m.blt and another one that doesn't really look better (not faster or shorter) via userform (to be tested if you want).
I don't necessarily ask for the call of the box by FileDialog, no matter the code
This dialog exists in SolidWorks because it can be opened as follows
capture_000131.png
It exists but unfortunately SW is not coded in vba so not everything that exists in SW exists in vba.
I don't master all forms of programming but I've sometimes seen codes that call 'shell something' I think that if someone knows programming well it may be possible to call this dialog, just like the options of the built-in SW dialog box use it
The basic problem is vba under 64 bits, because under 32 there are many more controls available, including dialogs, incompatible with vba 64... it's aberrant, heartbreaking, and frustrating...
I also need this dialog and it's driving me crazy. The excel dialog is a stopgap (thanks @m.blt ) but it's so slow to open...
Well so this slowness of opening the dialog box pushed me to test on the basis of @m.blt to make it faster. Which I did, in addition to reducing the size of the code. I made it a function in passing. Here is:
Dim xlFolderDlg As Office.FileDialog
Private Sub UserForm_Initialize()
Set xlFolderDlg = Excel.Application.FileDialog(4)
End Sub
Function FolderDialog$(Optional folder$)
With xlFolderDlg
.Title = "Sélectionner un dossier"
.ButtonName = "Sélectionner"
.InitialFileName = folder
If .Show Then folder = .SelectedItems(1)
End With
FolderDialog = folder
End Function
Private Sub CMDfolderDlg_Click()
TXTfolder = FolderDialog(TXTfolder)
End Sub
.
Where CMDfolderDlg is a CommandButton, and TXTfolder is a TextBox.
However, there is one drawback; When the dialog box closes, the form does not recover the hand (the window is deselected). Too bad but not dramatic.
interesting
I have a compilation error on the 1st line
Hello
The @Sylk code requires the use of a form (UserForm in VBA) with a button and a text box to activate the function.
Don't forget to add references to Office and Excel to the VBA references page by ticking the corresponding boxes (see image below).
The attached macro should be functional.
Kind regards.
explorerfiles.swp
2 Likes
Indeed @m.blt thank you. Just that as I edited my message in the meantime and the name of the button from CMDopenFolder to CMDfolderDlg (to make it more consistent) I need to replace the name of the button in the attached swp file.
Personally I use the TextBox in Locked true mode, so that its content is visible, selectable and scrollable (when it is longer than the textbox) but without the possibility to modify it by typing, in order to avoid a management of forbidden characters.
To set a default folder, simply change its Text property when the control is created. Or leave it blank, which will open "my documents" by default.