Test si fichier ouvert

Bonjour à tous,

Je viens vers vous car je bloque depuis plusieurs jours sur ce bout de code.

Mon code permets d'importer des valeurs présentes dans plusieurs fichiers d'un répertoire, est les transpose dans un tableau.

Le problème est que je voudrai qu'il importe les données seulement lorsque ces fichiers sont fermés , car d'autre utilisateurs peuvent modifier les données et donc avoir besoin d'ouvrir ces fichiers.

Du coup j'ai récupéré sur le net une fonction permettant de tester si le fichier est ouvert, seulement je n'arrive pas à l'adapter à mon code, l'import est annulé dans tous les cas (que le fichier soit ouvert ou non...).

Voici mon code:

Option Explicit
Dim Lig As Integer, p As String, nomfich As String, i As Integer
Sub ExportdonnéesIJ()
   Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
   Application.Calculation = xlCalculationManual
   Range("a2:Y65000").ClearContents
    Lig = 2 'restitution à partir de la ligne 2
    '***********************************************************************
    p = "D:\*****************\"  '
    '***********************************************************************
    nomfich = Dir(p & "*.xlsm") '1er fichier du dossier
    'If Dir(p) = "" Then
    'Exit Sub
    'Else

    If FileLocked(nomfich) Then

       Do While nomfich <> "" 'And IsFileOpen(nomfich)
        If nomfich <> ThisWorkbook.Name And nomfich <> "Dates" Then
            Cells(Lig, 1).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!G17"
            Cells(Lig, 2).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!B26"
            Cells(Lig, 3).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!E4"
            Cells(Lig, 4).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!B20"
            Cells(Lig, 5).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!B21"
            Cells(Lig, 6) = "C"
            Cells(Lig, 7).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!G19"
            Cells(Lig, 8).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!E26"
            Cells(Lig, 9).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!I4"
            Cells(Lig, 10).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!Y26"
            Cells(Lig, 11).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!E42"

            Lig = Lig + 1
        End If
        nomfich = Dir
        Loop

    End If

    With Workbooks("Tableau Dates.xlsm").Sheets("Recap2")
    For Lig = Range("A65536").End(xlUp).Row To 2 Step -1
         If Cells(Lig, 2) = 0 Then Cells(Lig, 2).Value = ""
    Next Lig
    End With

    With Workbooks("Tableau Dates.xlsm").Sheets("Recap2")
    For Lig = Range("A65536").End(xlUp).Row To 2 Step -1
         If Cells(Lig, 11) = "0" Then Cells(Lig, 11).Value = ""
    Next Lig
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

   End Sub

Function FileLocked(strFileName As String) As Boolean

   On Error Resume Next
   ' If the file is already opened by another process,
   ' and the specified type of access is not allowed,
   ' the Open operation fails and an error occurs.
   Open strFileName For Binary Access Read Write Lock Read Write As #1
   Close #1

   ' If an error occurs, the document is currently open.
   If Err.Number <> 0 Then
      ' Display the error number and description.
      'MsgBox "Error #" & Str(Err.Number) & " - " & Err.Description
      FileLocked = True
      Err.Clear
   End If
End Function

J'espère avoir été assez précis dans la description de mon problème..!!

Merci d'avance,

Bonne journée

Autant pour moi je m'étais trompé de fichier.

Voici le bon code :

Option Explicit
Dim Lig As Integer, p As String, nomfich As String, i As Integer
Sub ExportdonnéesIJ()
   Application.ScreenUpdating = False 'fige l'écran (pour accélérer)
   Application.Calculation = xlCalculationManual
   Range("a2:Y65000").ClearContents
    Lig = 2 'restitution à partir de la ligne 2
    '***********************************************************************
    p = "D:************************************\"  '
    '***********************************************************************
    nomfich = Dir(p & "*.xlsm") '1er fichier du dossier
    'If Dir(p) = "" Then
    'Exit Sub
    'Else

    If IsFileOpen(nomfich) Then

       Do While nomfich <> "" 'And IsFileOpen(nomfich)
        If nomfich <> ThisWorkbook.Name And nomfich <> "Dates" Then
            Cells(Lig, 1).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!G17"
            Cells(Lig, 2).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!B26"
            Cells(Lig, 3).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!E4"
            Cells(Lig, 4).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!B20"
            Cells(Lig, 5).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!B21"
            Cells(Lig, 6) = "C"
            Cells(Lig, 7).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!G19"
            Cells(Lig, 8).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!E26"
            Cells(Lig, 9).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!I4"
            Cells(Lig, 10).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!Y26"
            Cells(Lig, 11).Formula = "='" & p & "[" & nomfich & "]Article_Livrable et Prestations'!E42"

            Lig = Lig + 1
        End If

        nomfich = Dir
        Loop

    End If

    With Workbooks("Tableau Dates.xlsm").Sheets("Recap2")
    For Lig = Range("A65536").End(xlUp).Row To 2 Step -1
         If Cells(Lig, 2) = 0 Then Cells(Lig, 2).Value = ""
    Next Lig
    End With

    With Workbooks("Tableau Dates.xlsm").Sheets("Recap2")
    For Lig = Range("A65536").End(xlUp).Row To 2 Step -1
         If Cells(Lig, 11) = "0" Then Cells(Lig, 11).Value = ""
    Next Lig
    End With

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True

   End Sub

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer

    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.

    ' Check to see which error occurred.
    Select Case errnum

        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False

        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True

        ' Another error occurred.
        Case Else
            Error errnum
    End Select

End Function

Je viens de trouver la solution , cela provenait d'un problème de chemin... mais pour ceux qui en aurait besoin, la fonction est bonne !