IsFileOpen ?

[choupi_nette]

Bonjour le forum,
Dans un des codes que j'utilise, j'ai cette fonction qui verifie si un fichier est ouvert avant de commencer le script.
Mais le code renvoie toujours : "le fichier est ouvert" et j'ai l'impression que le fichier meme qui contient la macro (qui doit etre dans le meme dossier que les fichiers à classer) "se voit" ouvert et donc renvoie ce message.

Merci pour votre aide.

Voici le code

Sub testmacro()

Dim objFile1 As file
Dim objFile2 As file
Dim objFolder As Folder
Dim objFSO As FileSystemObject
Set objFSO = New FileSystemObject
Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
Dim leng As Integer
Dim newFoldName As String
Dim Fname As String
Dim fold As Boolean
fold = False

For Each objFile1 In objFolder.Files
    If IsFileOpen(objFile1.Path) Then Call MsgBox("One file is already open. Please make sure all files are closed and try again.", vbInformation): Exit Sub
Next
For Each objFile1 In objFolder.Files
Fname = objFile1.Name
leng = Len(Fname)

If InStr(Fname, ".csv") Or InStr(Fname, ".xad") Then
    Call MsgBox(Fname)
    If InStr(Fname, "_Results.csv") Then
    Fname = Mid(Fname, 1, leng - 12)
    Else
    Fname = Mid(Fname, 1, leng - 4)
    End If
    For Each objFile2 In objFolder.Files
        If InStr(objFile2.Name, Fname) And Not (objFile1.Name = objFile2.Name) Then
            If Not fold Then MkDir (ThisWorkbook.Path & "\" & Fname): fold = True
            objFile1.Move (ThisWorkbook.Path & "\" & Fname & "\")
            objFile2.Move (ThisWorkbook.Path & "\" & Fname & "\")
        End If
    Next
    fold = False
End If
Next
End Sub

Function IsFileOpen(filename As String) As Boolean
    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

 

[Theze]

Re : IsFileOpen ?

Bonjour,

Avec cette ligne de code :

Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)

il est évident que ça retournera toujours "Un fichier est déjà ouvert..." puisque tu passes en argument le classeur (ThisWorkbook.Path) où se trouve ce code !
Testes de cette façon :

Sub testmacro()

    Dim objFile1 As file
    Dim objFile2 As file
    Dim objFolder As Folder
    Dim objFSO As FileSystemObject
    Dim leng As Integer
    Dim newFoldName As String
    Dim Fname As String
    Dim fold As Boolean
    
    Set objFSO = New FileSystemObject
    Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
    fold = False
    
    For Each objFile1 In objFolder.Files
        If Dir(objFile1) <> ThisWorkbook.Name Then 'évite le classeur
            If IsFileOpen(objFile1.Path) Then MsgBox "Le fichier '" & Dir(objFile1) & "' est ouvert, veuillez le fermer !", vbInformation: Exit Sub
        End If
    Next
    
    For Each objFile1 In objFolder.Files
    
        If Dir(objFile1) <> ThisWorkbook.Name Then 'évite à nouveau le classeur
    
            Fname = objFile1.Name
            leng = Len(Fname)
            
            If InStr(Fname, ".csv") Or InStr(Fname, ".xad") Then
            
                MsgBox Fname
                
                If InStr(Fname, "_Results.csv") Then
                    Fname = Mid(Fname, 1, leng - 12)
                Else
                    Fname = Mid(Fname, 1, leng - 4)
                End If
                
                For Each objFile2 In objFolder.Files
                
                    If InStr(objFile2.Name, Fname) And Not (objFile1.Name = objFile2.Name) Then
                    
                        If Not fold Then MkDir (ThisWorkbook.Path & "\" & Fname): fold = True
                        
                        objFile1.Move (ThisWorkbook.Path & "\" & Fname & "\")
                        objFile2.Move (ThisWorkbook.Path & "\" & Fname & "\")
                        
                    End If
                    
                Next objFile2
                
                fold = False
                
            End If
    
        End If
    
    Next objFile1

End Sub

 

[choupi_nette]

Re : IsFileOpen ?

Hello Theze, le forum,

Merci pour ta réponse mais le script me renvoie encore et toujours la même MsgBox: Le fichier '" & Dir(objFile1) & "' est ouvert, veuillez le fermer !

J'ai l'impression que mettre un autre if apres If Dir(objFile1) <> ThisWorkbook.Name Then ne fonctionnne pas bien.

Qu'en pensez vous ?

 

[choupi_nette]

Re : IsFileOpen ?

Hello le forum,

Solution trouvée. Ca marche
Merci a Theze, au forum

Sub autpen()

     Dim objFile1 As file
     Dim objFile2 As file
     Dim objFolder As Folder
     Dim objFSO As FileSystemObject
     Dim leng As Integer
     Dim newFoldName As String
     Dim Fname As String
     Dim fold As Boolean
     
     Set objFSO = New FileSystemObject
     Set objFolder = objFSO.GetFolder(ThisWorkbook.Path)
     fold = False
     
   
     
     For Each objFile1 In objFolder.Files
     
         If Dir(objFile1) <> ThisWorkbook.Name Then 'évite à nouveau le classeur
     
             Fname = objFile1.Name
             leng = Len(Fname)
             
             If InStr(Fname, ".csv") Or InStr(Fname, ".xad") Then
             
           
                 
                 If InStr(Fname, "_Results.csv") Then
                     Fname = Mid(Fname, 1, leng - 12)
                 Else
                     Fname = Mid(Fname, 1, leng - 4)
                 End If
                 
                 For Each objFile2 In objFolder.Files
                 
                     If InStr(objFile2.Name, Fname) And Not (objFile1.Name = objFile2.Name) Then
                     
                         If Not fold Then MkDir (ThisWorkbook.Path & "\" & Fname): fold = True
                         
                         objFile1.Move (ThisWorkbook.Path & "\" & Fname & "\")
                         objFile2.Move (ThisWorkbook.Path & "\" & Fname & "\")
                         
                     End If
                     
                 Next objFile2
                 
                 fold = False
                 
             End If
     
         End If
     
     Next objFile1

 End Sub

Function IsFileOpen(filename As String) As Boolean
    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