amiben
-
Modifié par pijaku le 26/09/2014 à 11:42
jordane45
Messages postés38137Date d'inscriptionmercredi 22 octobre 2003StatutModérateurDernière intervention17 avril 2024
-
26 sept. 2014 à 18:06
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
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
Messages postés38137Date d'inscriptionmercredi 22 octobre 2003StatutModérateurDernière intervention17 avril 2024344 26 sept. 2014 à 18:06
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