Re : Filtre sur GetOpenFilename
Merci de votre aide. J'ai trouvé la solution à mon problème. Voir ci-dessous:
Private Declare Function SetCurrentDirectoryA Lib "Kernel32" (ByVal lpPathName As String) As Long
Public 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
Public Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenFileName As OPENFILENAME) As Long
Public Const OFN_ALLOWMULTISELECT = &H200&
Public Const OFN_EXPLORER = &H80000
Public Const OFN_FILEMUSTEXIST = &H1000&
Public Const OFN_HIDEREADONLY = &H4&
Public Const OFN_PATHMUSTEXIST = &H800&
Dim messources(500) As String ' indice de 0 a 500
' _________________________________________________________________
Sub Import()
Application.ScreenUpdating = False
' saisir le nom du tableau à générer
Worksheets("recap").Select
Worksheets("recap").Activate
ctrerreur_file = 0
monfichierlu = ActiveWorkbook.Name
monfichier = InputBox("Entrer le nom du fichier récapitulatif souhaité", "FICHIER A GENERER")
monfichier = monfichier & ".xls"
If monfichier = monfichierlu Then
mesg0 = monfichier & " : Le fichier à créer porte le même nom que le fichier lu. STOP"
msg = mesg0
Style = vbAnnul
Title = "Fichier Recap déjà existant et ouvert "
response = MsgBox(msg, Style, Title)
' arreter la macro
Else
SetUNCPath "C:\XXX"
varout = monfichier
vardir = "C:\XXX"
ChDir (vardir)
' """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""
vartest = vardir & "\" & varout
' Test l'existence d'un fichier
Set objFSO = CreateObject("Scripting.FileSystemObject")
If objFSO.FileExists(vartest) Then
mesg1 = varout & " : Le fichier existe déjà, voulez-vous le remplacer ?"
msg = mesg1
Style = vbYesNo
Title = "Fichier Recap déjà existant "
response = MsgBox(msg, Style, Title)
If response = vbYes Then
' si oui deleter le fichier and le saveas
Set objFSO = CreateObject("Scripting.FileSystemObject")
objFSO.DeleteFile (vartest)
Else
' si non arreter la macro
ctrerreur_file = 1
End If
End If
If ctrerreur_file = 0 Then
' """"""""""""""""""""""""""""""""""""""""""""""""""""""""""""
' préparation du fichier à générer
ActiveWorkbook.SaveAs Filename:= _
varout, FileFormat:= _
xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _
, CreateBackup:=False
'sauvegarde du nom du document actif
Worksheets("recap").Select
Worksheets("recap").Activate
Range("G6:FS6").Select
Selection.ClearContents
Range("G8:FS8").Select
Selection.ClearContents
Range("G4:FS4").Select
Selection.ClearContents
'###########################################################################
'lecture des données du tableau
varlig = 4
Range("FW3") = 7
varcol = Range("FW3")
varcow = Range("fv3")
varadr = varcow & varlig
ActiveSheet.Unprotect
Application.ScreenUpdating = False
' ___________________________________________________________________
SetUNCPath "C:\CVS"
' maselection = InputBox("Voulez vous appliquer une sélection sur les noms des fichiers à traiter? ", "FICHIER A SELECTIONNER")
mesg1 = "Voulez vous appliquer une sélection sur les noms des fichiers à traiter? "
Style = vbYesNo
Title = "Fichiers à sélectionner "
response = MsgBox(mesg1, Style, Title)
If response = vbYes Then
maselection = InputBox("Entrer la sélection. (exemples 201408*RM1, ou 2014, ou 201408) ", "Début des noms des fichiers à sélectionner")
If maselection = "" Or maselection = "*" Then
sfilter = "Excel Files (*.xls), *.xls"
Else
' string de sélection
filt1 = "Classeurs Excel Spéciaux ("
filt2 = maselection
filt3 = "*.xls)"
filt4 = "*.xls"
sfilter = filt1 & filt2 & filt3 & Chr(0) & filt2 & filt4 & Chr(0)
End If
Else
' selection les fichiers XLS seulement
sfilter = "Excel Files (*.xls), *.xls"
End If
' ouverture de la fenetre de selection des fichiers et sauvegarde de leurs noms dans le tableau messources
Dim FileList As New Collection
Dim I As Long
Dim S As String
ShowFileOpenDialog FileList, sfilter
With FileList
If .Count > 0 Then
For I = 1 To .Count
' messources = messources + .Item(I) + vbCrLf
' stockage des noms de fichiers sélectionnés
X = I - 1
messources(X) = .Item(I)
Next
Msgfil = I & " Fichiers sélectionnés"
'MsgBox Msgfil
Else
MsgBox "aucun fichier n'a été sélectionné!"
I = 0
End If
End With
If I > 0 Then
'
' ______________________________________________________________________________
For I = LBound(messources) To X
'code pour l'import des données
'
Range(varadr).Select
varnam = messources(I)
ctrerr = 0
ctrtabl = 0
suffixe = Right(varnam, 4)
ctrtabl = ctrtabl + 1
mylen = Len(varnam) - 4
varfich = Left(varnam, mylen)
mylen = mylen - 7
varfich = Right(varfich, mylen)
' Afficher les messages d'alerte
DisplayAlerts = True
' ---------------------------------------------------
' stocker les "varnam" dans une zone reprise dans un onglet "composants"
'
Range(varadr) = varfich
varcol = varcol + 1
Range("FW3") = varcol
varcow = Range("fv3")
varadr = varcow & varlig
Next I
'________________________________________________________________________
ActiveSheet.Protect DrawingObjects:=False, Contents:=True, Scenarios:= _
False
Application.ScreenUpdating = True
vardir = "C:\XXX"
ChDir (vardir)
ActiveWorkbook.Save
'sauvegarde
DisplayAlerts = True
' MsgBox ("fin selection par fichier ")
End If
End If
End If ' fin en cas de nom du fichier lu = nom du fichier à créer
End Sub
' ______________________________________________________________________
Sub ShowFileOpenDialog(ByRef FileList As Collection, sfilter)
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim FileDir As String
Dim FilePos As Long
Dim PrevFilePos As Long
With OpenFile
.lStructSize = Len(OpenFile)
.hwndOwner = 0
.hInstance = 0
'.lpstrFilter = "Classeurs Excel Spéciaux (201407*.xls)" & Chr(0) & "201407*.xls" & Chr(0)
.lpstrFilter = sfilter
.nFilterIndex = 1
.lpstrFile = String(4096, 0)
.nMaxFile = Len(.lpstrFile) - 1
.lpstrFileTitle = .lpstrFile
.nMaxFileTitle = .nMaxFile
.lpstrInitialDir = "C:\CVS"
.lpstrTitle = "Multi Select Drawings"
.flags = OFN_HIDEREADONLY + _
OFN_PATHMUSTEXIST + _
OFN_FILEMUSTEXIST + _
OFN_ALLOWMULTISELECT + _
OFN_EXPLORER
lReturn = GetOpenFileName(OpenFile)
If lReturn <> 0 Then
FilePos = InStr(1, .lpstrFile, Chr(0))
If Mid(.lpstrFile, FilePos + 1, 1) = Chr(0) Then
FileList.Add .lpstrFile
Else
FileDir = Mid(.lpstrFile, 1, FilePos - 1)
Do While True
PrevFilePos = FilePos
FilePos = InStr(PrevFilePos + 1, .lpstrFile, Chr(0))
If FilePos - PrevFilePos > 1 Then
FileList.Add FileDir + "\" + _
Mid(.lpstrFile, PrevFilePos + 1, _
FilePos - PrevFilePos - 1)
Else
Exit Do
End If
Loop
End If
End If
End With
End Sub
' ________________________________________________________________________________
'fonction qui modifie le chemin par défaut
Function SetUNCPath(sPath As String) As Long
Dim lReturn As Long
lReturn = SetCurrentDirectoryA(sPath)
SetUNCPath = lReturn
End Function
