SW VBA boite dialogue sélection dossier

Bonjour

depuis Solidworks je souhaite sélectionner via une boite de dialogue un dossier

voici la macro excel qui fonctionne mais pas dans Solidworks 64 bit

Sub Dossier()
    
Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)

fDialog.Title = "Selectionner dossier"
fDialog.InitialFileName = "C:\"
 
If fDialog.Show = -1 Then
Debug.Print fDialog.SelectedItems(1)
End If
End Sub

 

c'est cette boite de dialogue qui m'intéresse pas celle qui est simplifiée

Si vous avez une idée de code, je suis preneur

Bonjour;

Essayez plutôt avec la macro du lien (lynkoa) ci-dessous....
https://www.lynkoa.com/forum/solidworks/bo%C3%AEte-de-dialogue-ouvrir-macro-solidworks


Cordialement.

2 « J'aime »

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