Selection multiple de fichiers solidworks

Question

Bonjour,
Je cherche a pouvoir faire une sélection de plusieurs  fichiers solidworks en VBA.
Le code suivant  me permet de sélectionner un fichier , et le nom ainsi que le chemin est facilement récupérer par un message (Msgbox).
Ma problématique est de pouvoir récupérer les noms de tous les fichiers sélectionner dans la boite de dialogue ouverte par VBA.
Commande 1:

Private Sub CommandButton1_Click()
Dim FileName As Variant
FileName = GetFiles()

End Sub

Commande 2 :

Private Function GetFiles() As String()
    Dim strArray()          As String
    Dim strReturn           As String
    Dim strPath             As String
    Dim lngX                As Long
    Dim lngFirst            As Long
    Dim lngLastExt          As Long
    Dim lnglast             As Long
    
    ReDim strArray(0)
    strReturn = BrowseForFile("Choisir files...", "Solidworks drawings (*.slddrw)" & vbNullChar & "*.slddrw" & vbNullChar, "E:\Macro ")
      ' strReturn = fr.Label1
      MsgBox strReturn
       If Len(strReturn) > 1 Then
            lngFirst = InStrRev(strReturn, "") - 1
            lngLastExt = InStrRev(strReturn, ".")
            lnglast = InStr(lngLastExt, strReturn, vbNullChar) - 1
            strPath = Left(strReturn, lngFirst) & ""
            'strReturn = Left(strReturn, lnglast)
            strReturn = Mid(strReturn, lngFirst + 1)
                If Left(strReturn, 1) = "" Then strReturn = Right(strReturn, Len(strReturn) - 1)
            strReturn = Trim(strReturn)
                While InStr(1, strReturn, vbNullChar) = 1
                    strReturn = Mid(strReturn, 2)
                Wend
           
                strArray = Split(strReturn, vbNullChar)
        
                For lngX = LBound(strArray) To UBound(strArray)
                    strArray(lngX) = strPath & strArray(lngX)
                Next
       End If
    GetFiles = strArray
   ' MsgBox GetFiles
End Function


Module :


Option Explicit

Public Declare PtrSafe Function GetOpenFileName Lib "comdlg32.dll" Alias _
            "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
    
Public Const OFN_ALLOWMULTISELECT As Long = &H200
Public Const OFN_CREATEPROMPT As Long = &H2000
Public Const OFN_ENABLEHOOK As Long = &H20
Public Const OFN_ENABLETEMPLATE As Long = &H40
Public Const OFN_ENABLETEMPLATEHANDLE As Long = &H80
Public Const OFN_EXPLORER As Long = &H80000
Public Const OFN_EXTENSIONDIFFERENT As Long = &H400
Public Const OFN_FILEMUSTEXIST As Long = &H1000
Public Const OFN_HIDEREADONLY As Long = &H4
Public Const OFN_LONGNAMES As Long = &H200000
Public Const OFN_NOCHANGEDIR As Long = &H8
Public Const OFN_NODEREFERENCELINKS As Long = &H100000
Public Const OFN_NOLONGNAMES As Long = &H40000
Public Const OFN_NONETWORKBUTTON As Long = &H20000
Public Const OFN_NOREADONLYRETURN As Long = &H8000& '*see comments
Public Const OFN_NOTESTFILECREATE As Long = &H10000
Public Const OFN_NOVALIDATE As Long = &H100
Public Const OFN_OVERWRITEPROMPT As Long = &H2
Public Const OFN_PATHMUSTEXIST As Long = &H800
Public Const OFN_READONLY As Long = &H1
Public Const OFN_SHAREAWARE As Long = &H4000
Public Const OFN_SHAREFALLTHROUGH As Long = 2
Public Const OFN_SHAREWARN As Long = 0
Public Const OFN_SHARENOWARN As Long = 1
Public Const OFN_SHOWHELP As Long = &H10
Public Const OFN_ENABLESIZING As Long = &H800000
Public Const OFS_MAXPATHNAME As Long = 260

Public Type OPENFILENAME
    lStructSize As Long
    hwndOwner As LongPtr
    hInstance As LongPtr
    lpstrFilter As String
    lpstrCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    lpstrFile As String
    nMaxFile As Long
    lpstrFileTitle As String
    nMaxFileTitle As Long
    lpstrInitialDir As String
    lpstrTitle As String
    flags As Long
    nFileOffset As Integer
    nFileExtension As Integer
    lpstrDefExt As String
    lCustData As Long
    lpfnHook As LongPtr
    lpTemplateName As String
End Type

'OFS_FILE_OPEN_FLAGS:
Public Const OFS_FILE_OPEN_FLAGS = OFN_EXPLORER Or _
             OFN_LONGNAMES Or _
             OFN_CREATEPROMPT Or _
             OFN_NODEREFERENCELINKS
             
'windows version constants
Private Const VER_PLATFORM_WIN32_NT As Long = 2
Private Const OSV_LENGTH As Long = 76
Private Const OSVEX_LENGTH As Long = 88
Public OSV_VERSION_LENGTH As Long

Public Const WM_INITDIALOG As Long = &H110
Private Const SW_SHOWNORMAL As Long = 1

Public Function BrowseForFile(strTitle As String, myFilter As String, Optional initialDir As String = "") As String
    Dim OpenFile    As OPENFILENAME
    Dim lReturn     As Long
    Dim BrowseForFileOpen As String
    Dim strReturn As String
  
    OpenFile.lpstrFilter = myFilter
    OpenFile.nFilterIndex = 1
    OpenFile.hwndOwner = 0
    OpenFile.lpstrFile = String(257, 0)
    #If VBA7 Then
        OpenFile.nMaxFile = LenB(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = LenB(OpenFile)
    #Else
        OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
        OpenFile.lStructSize = Len(OpenFile)
    #End If
    OpenFile.lpstrFileTitle = OpenFile.lpstrFile
    OpenFile.nMaxFileTitle = OpenFile.nMaxFile
    
    If initialDir <> "" Then OpenFile.lpstrInitialDir = initialDir
    OpenFile.lpstrTitle = strTitle
    
    '''''''''''''''''''''''''''''''''''''''
    'This next bit allows for multi-select:
    '''''''''''''''''''''''''''''''''''''''
    'OpenFile.flags = OFS_FILE_OPEN_FLAGS '+ OFN_ALLOWMULTISELECT
    OpenFile.flags = OFS_FILE_OPEN_FLAGS + OFN_ALLOWMULTISELECT
    
    lReturn = GetOpenFileName(OpenFile)
  
    If lReturn = 0 Then
    'MsgBox OpenFile
        BrowseForFileOpen = ""
    Else
     MsgBox Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1)) 'OpenFile.lpstrFile
       BrowseForFileOpen = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))
       'strReturn = BrowseForFileOpen
       MsgBox BrowseForFileOpen
    End If
  
End Function

Public Function OFNHookProc(ByVal hwnd As Long, _
                            ByVal uMsg As Long, _
                            ByVal wParam As Long, _
                            ByVal lParam As Long) As Long
   Select Case uMsg
      Case WM_INITDIALOG
      
      'Next line is not needed. Just left here as an example of how to hook the save dialog
      'Call SendMessage(hwnd, BFFM_SETSELECTION, 1, ByVal initFile$)
      
   End Select
   OFNHookProc = 0
End Function

Private Function GetAddress(ByVal Addr As Long) As Long
   GetAddress = Addr
End Function


Qui pourrait m'aider a résoudre ce problème 
D'avance merci

jordane45 · Answer

Bonjour,

Je ne sais pas où tu as récupéré ton code... mais il y a plus simple :

EDIT : Pour EXCEL :

Public Function GetFiles(typFiles As String, RepToOpen As String)
    Dim myXL As Excel.Application
    Dim i As Long
    Dim PickedFiles As Variant
    Dim varTemp As Variant
    Dim fdOpen As FileDialog

ReDim PickedFiles(1 To 1)

Set myXL = New Excel.Application
        myXL.DefaultFilePath = RepToOpen
    Set myXL = Nothing 'Close Excel to save this change
    Set myXL = New Excel.Application  'Open Excel again
    Set fdOpen = myXL.FileDialog(msoFileDialogOpen)
        With fdOpen
            .AllowMultiSelect = True
            .Show
                For Each varTemp In .SelectedItems
                 If Not IsEmpty(PickedFiles(UBound(PickedFiles))) Then ReDim Preserve PickedFiles(1 To UBound(PickedFiles) + 1)
                    PickedFiles(UBound(PickedFiles)) = varTemp
                Next
        End With
        GetFiles = PickedFiles
End Function

Sub MonTest()

Dim FileName()
Dim RepToOpen As String
Dim extFile As String
    extFile = "Solidworks drawings (*.slddrw)" & vbNullChar & "*.slddrw" & vbNullChar
    extFile = "All Files (*.*)"
RepToOpen = "c:"
FileName = GetFiles(extFile, RepToOpen)

For x = 1 To UBound(FileName)
    Debug.Print FileName(x)
Next

End Sub

Si tu n'es pas sous Excel... il faudra peut être continuer à creuser sur ton code initiale...
mais il faudrait nous l'indiquer.
 
Avant de poser une question, merci de lire la charte du site.
Cordialement, Jordane

jordane45 · Answer

Voici une version basée sur ton code d'origine :

Option Explicit
Private Const OFN_ALLOWMULTISELECT = &H200
Private Const OFN_CREATEPROMPT = &H2000
Private Const OFN_ENABLEHOOK = &H20
Private Const OFN_ENABLETEMPLATE = &H40
Private Const OFN_ENABLETEMPLATEHANDLE = &H80
Private Const OFN_EXPLORER = &H80000                         '  new look commdlg
Private Const OFN_EXTENSIONDIFFERENT = &H400
Private Const OFN_FILEMUSTEXIST = &H1000
Private Const OFN_HIDEREADONLY = &H4
Private Const OFN_LONGNAMES = &H200000                       '  force long names for 3.x modules
Private Const OFN_NOCHANGEDIR = &H8
Private Const OFN_NODEREFERENCELINKS = &H100000
Private Const OFN_NOLONGNAMES = &H40000                      '  force no long names for 4.x modules
Private Const OFN_NONETWORKBUTTON = &H20000
Private Const OFN_NOREADONLYRETURN = &H8000
Private Const OFN_NOTESTFILECREATE = &H10000
Private Const OFN_NOVALIDATE = &H100
Private Const OFN_OVERWRITEPROMPT = &H2
Private Const OFN_PATHMUSTEXIST = &H800
Private Const OFN_READONLY = &H1
Private Const OFN_SHAREAWARE = &H4000
Private Const OFN_SHAREFALLTHROUGH = 2
Private Const OFN_SHARENOWARN = 1
Private Const OFN_SHAREWARN = 0
Private Const OFN_SHOWHELP = &H10
 
Private Type OPENFILENAME
        lStructSize As Long
        hwndOwner As Long
        hInstance As Long
        lpstrFilter As String
        lpstrCustomFilter As String
        nMaxCustFilter As Long
        nFilterIndex As Long
        lpstrFile As String
        nMaxFile As Long
        lpstrFileTitle As String
        nMaxFileTitle As Long
        lpstrInitialDir As String
        lpstrTitle As String
        flags As Long
        nFileOffset As Integer
        nFileExtension As Integer
        lpstrDefExt As String
        lCustData As Long
        lpfnHook As Long
        lpTemplateName As String
End Type
 
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Function AddBS(ByVal sPath As String) As String
  If Right$(sPath, 1) <> "" Then sPath = sPath & ""
  AddBS = sPath
End Function

Private Sub CommandButton1_Click()
Dim tOPENFILENAME As OPENFILENAME
    Dim lResult As Long
    Dim vFiles As Variant
    Dim lIndex As Long, lStart As Long
   
    With tOPENFILENAME
        .flags = OFN_ALLOWMULTISELECT Or OFN_EXPLORER Or OFN_FILEMUSTEXIST Or OFN_LONGNAMES
        .hwndOwner = hwnd
        .nMaxFile = 2048
        .lpstrFilter = "All Files" & Chr(0) & "*.*" & Chr(0) & Chr(0)
        .lpstrFile = Space(.nMaxFile - 1) & Chr(0)
        .lStructSize = Len(tOPENFILENAME)
    End With
   
    lResult = GetOpenFileName(tOPENFILENAME)
   
    If lResult > 0 Then
        With tOPENFILENAME
            vFiles = Split(Left(.lpstrFile, InStr(.lpstrFile, Chr(0) & Chr(0)) - 1), Chr(0))
        End With
       
        If UBound(vFiles) = 0 Then
            List1.AddItem vFiles(0)
        Else
            For lIndex = 1 To UBound(vFiles)
             'ICI tu traites tes fichiers !
               Debug.Print AddBS(vFiles(0)) & vFiles(lIndex)
            Next
        End If
    End If
End Sub

Selection multiple de fichiers solidworks

2 réponses

Votre réponse

Discussions similaires