IsFileOpen ?

C

choupi_nette

XLDnaute Occasionnel
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

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
 
Trier par date Trier par votes
T

Theze

XLDnaute Occasionnel
Re : IsFileOpen ?

Bonjour,

Avec cette ligne de code :
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 :
Code: 
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
 
Vote positif 0 Vote négatif
C

choupi_nette

XLDnaute Occasionnel
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 ?
 
Vote positif 0 Vote négatif
C

choupi_nette

XLDnaute Occasionnel
Re : IsFileOpen ?

Hello le forum,

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


Code: 
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
 
Vote positif 0 Vote négatif

Discussions similaires

M
  • Question
XL 2016 Impression d'un rapport PDF depuis une URL avec VBA
Réponses
3
Affichages
544
mrcooll
M
B
  • Résolu(e)
Microsoft 365 Besoin d'aide pour faire fonctionner 2 codes VBA ensemble
Réponses
2
Affichages
145
BenExcel
B
M
  • Question
Microsoft 365 Joindre une copie de 2 feuilles Excel dans outlook
Réponses
0
Affichages
303
Mika07
M
M
  • Résolu(e)
XL 2019 Excel - générer .PDF avec envoie mail
Réponses
12
Affichages
1 K
Mika07
M
P
  • Question
Outlook Outlook imprimer mail et PJ en PDF
Réponses
2
Affichages
507
paulng
P
D
  • Question
XL 2013 Importation calendrier Outlook
Réponses
0
Affichages
583
degards
D
F
  • Résolu(e)
XL 2019 Enregistrer sous la feuille active dans répertoire du fichier père en vba
2
Réponses
23
Affichages
695
Fabrice16ct
F
M
  • Question
XL 2016 Envoi courriel copier/coller avec mise en forme (corps couuriel)
Réponses
2
Affichages
1 K
MONTREAL2020
M
M
  • Question
XL 2019 Afficher l'explorer via vba
Réponses
2
Affichages
936
patricktoulon
patricktoulon
J
  • Question
Microsoft 365 Envoi fichier sur serveur FTP VBA - Erreur 12029 INTERNETConnect
Réponses
1
Affichages
929
sylvanu
sylvanu

Membres actuellement en ligne

10 membres et 118 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 305
Messages
2 087 077
Membres
103 455
dernier inscrit
saramachado