Bonjour
j'avais déjà vu cette technique mais j'aurais souhaiter sélectionner une dossier
Peut être une référence manquante?
Regarde ce sujet si tu y trouve la bonne solution:
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:QG0F7bLmQaOUb70yb4BJfw
J'ai essayé plusieurs macros, celle de Christian Chu fonctionne mais ça n'ouvre pas la boite de dialogue que je veux, c'est la version simplifié de sélection de dossier que ça ouvre pour ma part les autres macros ne fonctionnent pas
une ancienne macro fait planter excel et 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
ce que je cherche c'est l'équivalent de msoFileDialogFolderPicker / Application.FileDialog(4).Show
Cette boite de dialogue peut être activé comme sur la capture d'écran mais je ne vois pas comment la lancer depuis vba
capture_000130.png
Je viens de trouver ce sujet sur ce même 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
Avec un peut de chance tu y trouveras ce que tu souhaite.
Bonjour
cela n'affiche pas la bonne boite de dialogue
Il faut regarder le dernier post du lien précédent qui renvoit vers un lien et un post de @liryc
https://www.lynkoa.com/forum/solidworks/bouton-parcourir-macro-vba
En espérant que ce soit la bonne boite de dialogue cette fois:
Pour le code dans le 1er 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
Dans un autre module pour le mêm fichier swp:
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
Bonjour
ce n'est pas la bonne boite de dialogue qui s'affiche de plus c'est une véritable usine a gaz, qui fait planter SW chez moi et qui peut s'écrire avec un code beaucoup plus court dans les ex que j'ai déjà vu
Bonjour @ll,
Le code de votre macro initiale fait référence à l'objet fileDialog qui existe dans la galaxie Office de Microsoft, mais pas dans VBA ni dans les API de SolidWorks.
Si Excel est installé sur votre PC, le code ci-dessous, qui fait appel à l'objet Application d'Excel, pourrait fonctionner.
Cordialement.
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 « J'aime »
Ca fonctionne bien, merci
Si quelqu'un à le code pour pour la boite de dialogue SW plutot qu'excel ca devrait etre plus court
j'ai rajouter le cas du bouton annuler
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
Rien à voir avec le sujet
j'ai mis à dispo une macro Minecraft sur SW pour ceux que ca interesse : Communauté Lynkoa / TUTOS
Merci pour le code @m.blt
il faut juste remplacer le bloc With par ce code pour gérer l'erreur à l'annulation :
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 directement = impossible avec FileDialog comme le dit @m.blt :
https://r1132100503382-eu1-3dswym.3dexperience.3ds.com/#community:yUw32GbYTEqKdgY7-jbZPg/iquestion:oJZLfucoQ9OmlIPXWjDnzA
Trouvé 2 méthodes détournés:
https://thecadcoder.com/vba/browse-solidworks-file/
une via Excel comme @m.blt et une autre qui n'a pas vraiment l'air mieux (pas plus rapide ou courte) via userform (à tester si tu le souhaites).
je ne demande pas forcément l'appel de la boite par FileDialog, peux importe le code
cette boite de dialogue existe dans solidworks puisqu'on peut l'ouvrir comme suit
capture_000131.png
Elle existe mais malheureusement SW n'est pas codé en vba donc pas tout ce qui existe dans SW n'existe en vba.
je ne maitrise pas toutes les formes de programmation mais j'ai parfois vu des codes qui font appel à 'shell quelque chose' je me dit que si quelqu'un connait bien la programmation c'est peut être possible de faire appel à cette boite de dialogue, tout comme les options de la boite de dialogue intégré de SW y fait appel
Le problème de base c'est vba sous 64 bits, car sous 32 il y a beaucoup plus de contrôles disponibles, notamment les boites de dialogues, incompatibles avec vba 64... c'est aberrant, navrant, et frustrant...
J'ai aussi besoin de cette dialog et ça me rend fou. La dialog excel est un palliatif (merci @m.blt ) mais qu'est-ce qu'elle est lente à s'ouvrir...
Bon alors cette lenteur d'ouverture de la boite de dialogue m'a poussé à faire des essais sur la base de @m.blt pour la rendre plus rapide. Ce que j'ai réussi, en plus de réduire la taille du code. J'en ai fait une fonction au passage. Voici :
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
.
Où CMDfolderDlg est un CommandButton, et TXTfolder est une TextBox.
Un inconvénient toutefois ; à la fermeture de la boite de dialogue la form ne récupère pas la main (la fenêtre est désélectionnée quoi). Dommage mais pas dramatique.
interressant
j'ai une erreur de compilation sur la 1ere ligne
Bonjour,
Le code de @Sylk suppose d'utiliser une fiche (UserForm en VBA) comportant un bouton et une zone de texte pour activer la fonction.
Ne pas oublier d'ajouter dans la page des références de VBA les références à Office et à Excel en cochant les cases correspondantes (cf. image ci-dessous).
La macro jointe devrait être fonctionnelle.
Cordialement.
explorateurfichiers.swp
2 « J'aime »
En effet @m.blt merci. Juste que comme j'ai édité mon message entre temps et le nom du bouton de CMDopenFolder vers CMDfolderDlg (pour qu'il soit plus cohérent) il faut remplacer le nom du bouton dans le fichier swp joint.
Personnellement j'utilise la TextBox en mode Locked true, pour que son contenu soit visible, sélectionnable et défilable (quand il est plus long que la textbox) mais sans possibilité de le modifier par saisie, histoire d'éviter une gestion des caractères interdits.
Pour définir un dossier par défaut il suffit de modifier sa propriété Text à la création du contrôle. Ou la laisser vide, ce qui ouvrira "mes documents" par défaut.