Option Explicit
Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
(ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Const SDossierCorr As String = "DVF Corrigés"
Private Function Chemin(sFichier As String, p As Integer) As String
Dim i As Long
If Dir$(sFichier) = "" Then Exit Function
For i = 0 To UBound(Split(sFichier, "\")) - p
Chemin = Chemin & Split(sFichier, "\")(i) & "\"
Next i
End Function
Private Sub Correction(sNomFichier As String)
Dim sChaine As String
Dim sCorr As String
Dim iNumFichierIn As Integer, iNumFichierOut As Integer
Dim sNomFichierOut As String, sCheminFichierIn As String
Close
sCheminFichierIn = Chemin(sNomFichier, 1)
CreationDossier Chemin(sNomFichier, 2) & SDossierCorr
sNomFichierOut = Chemin(sNomFichier, 2) & SDossierCorr & "\" & NomFichier(sNomFichier)
sCorr = ShDatas.Range("A2")
iNumFichierIn = FreeFile
Open sNomFichier For Input As #iNumFichierIn
iNumFichierOut = FreeFile
Open sNomFichierOut For Output As #iNumFichierOut
Print #iNumFichierOut, sCorr
Do While Not EOF(iNumFichierIn)
Line Input #iNumFichierIn, sChaine
Print #iNumFichierOut, sChaine
Loop
Close #iNumFichierOut
Close #iNumFichierIn
End Sub
Private Function CreationDossier(sDossier) As Long
CreationDossier = SHCreateDirectoryEx(0&, sDossier, 0&)
End Function
Private Function NomFichier(sFichier As String) As String
With CreateObject("Scripting.FileSystemObject")
On Error Resume Next
NomFichier = .GetFileName(sFichier)
On Error GoTo 0
End With
End Function
Sub SelFichiers()
Dim FD As FileDialog
Dim i As Long
ChDir ThisWorkbook.Path & "\"
Set FD = Application.FileDialog(msoFileDialogFilePicker)
With FD
.Filters.Clear
.Filters.Add "Fichiers DVF (*.dvf)", "*.dvf", 1
.InitialFileName = "*.dvf"
.AllowMultiSelect = True
.ButtonName = "Corriger fichier(s)"
.Title = "Sélectionner un ou plusieurs fichier(s)"
End With
If FD.Show = True Then
DoEvents
Application.StatusBar = ""
For i = 1 To FD.SelectedItems.Count
Correction FD.SelectedItems(i)
Application.StatusBar = i & " / " & FD.SelectedItems.Count
Next i
Application.StatusBar = Application.StatusBar & " " & "Correction(s) Terminée(s)"
End If
Set FD = Nothing
End Sub