Test de l’état ouverts/fermés de 2 classeurs, si ils existent

Hier à 11:26

Bonjour à tous & merci d’avance pour m’aider à résoudre ce problème, butant dessus depuis pas mal de temps

1 classeur de travail Automatismes.xlsm teste au lancement si 1-2 ou aucun des 2 classeurs suivants existe & son état

LIA maint.xlsm & LIA.xlsm sachant qu’ils sont placés respectivement dans 2 répertoires différents Crx-maint & Crx sur le bureau.

L’objectif est de mettre à 0 ou à 1 2 cellules (AF5-AF6) s’ils existent & 2 autres cellules (AG5-AG6) à 0 ou à 1 suivant leur état respectif.

Il ne peut il y avoir qu’un seul classeur ouvert à la fois sur les 2 & si l »un des classeurs ou les 2 n’existent pas, la ou les cellules d’état concernées reste(nt) vide(s).

Dans le code macro ci-dessous du classeur de travail, les seuls codes de test d’existence des 2 classeurs est bonne, mais

Aucun test des états n’est effectué pour aucun des 2 si il en existe au moins 1 des 2.

C’est EstClasseurouvert, des 2 fonctions ; qui demande un débogage

Merci d’avance de l’aide qui pourra m’être apportée.

Cordialement à tous

Public Sub Worksheet_Calculate()

‘Test si 2 classeurs existent ou pas

Dim Monclasseur1 As String, Monclasseur2 As String

Dim Verification As Boolean, Verification1 As Boolean, Verification2 As Boolean

Dim EstClasseurOuvert As String, EstClasseurOuvert1 As String, EstClasseurOuvert2 As String

If Range("AF5").Value <> "" And Range("AF6").Value <> "" And Range("AG5").Value <> "" And Range("AG6").Value <> "" Then Exit Sub

‘ chemin complet des 2 classeurs

Monclasseur1= Range("AK8").Value ‘ C:\Users\user\Desktop\Crx-maint\/LIA maint.xlsm

Monclasseur2= Range("AK9").Value ‘ C:\Users\user\Desktop\Crx\/LIA.xlsm

‘ Monclasseur1 existe ?

If Range("AF5").Value = "" And Dir(Monclasseur1, vbDirectory) <> vbNullString Then Range("AF5").Value = 1

If Range("AF5").Value = "" And Dir(Monclasseur1, vbDirectory) = vbNullString Then Range("AF5").Value = 0

‘ MonClasseur1 ouvert ?

' si Classeur1 existe, vérifier s'il est déjà ouvert

If Range("AF5").Value <> "" And Range("AF6").Value = "" Then Verification 1= EstClasseurOuvert(MonClasseur1)

If Verification1 = True Then

Range("AG5").Value =1

Else

Range("AG5").Value =0

End If

End If

‘ Monclasseur2 existe ?

If Range("AF6").Value = "" And Dir(Monclasseur2, vbDirectory) <> vbNullString Then Range("AF6").Value = 1

If Range("AF6").Value = "" And Dir(Monclasseur2, vbDirectory) = vbNullString Then Range("AF6").Value = 0

‘ MonClasseur2 ouvert ?

' si Classeur2 existe, vérifier s'il est déjà ouvert

If Range("AF5").Value <> "" And Range("AF6").Value <> "" Then Verification 2= EstClasseurOuvert(MonClasseur2)

If Verification2 = True Then

Range("AG6").Value =1

Else

Range("AG6").Value =0

End If

End If

‘ Si utilisation de EstClasseurOuvert1 & EstClasseurOuvert2 (Débogage Tableau attendu)

‘ Si utilisation de Verification1 & Vérification2 (Débogage Tableau attendu)

‘ Si utilisation de Verification (Débogage Tableau attendu)

‘ Fonction dans Module 2 Classeur1 ouvert-fermé

Function EstClasseurOuvert(MonClasseur1 As String)

Dim NumeroFichier1 As Long, NumeroErreur1 As Long

On Error Resume Next

NumeroFichier1 = FreeFile()

Open MonClasseur1 For Input Lock Read As #NumeroFichier1

Close NumeroFichier1

NumeroErreur1 = Err

On Error GoTo 0

Select Case NumeroErreur1

Case 0: EstClasseurOuvert = False

Case 70: EstClasseurOuvert = True

Case Else: Error NumeroErreur1

End Select

End Function

‘ Fonction dans Module 3 Classeur2 ouvert-fermé

Function EstClasseurOuvert(MonClasseur2 As String)

Dim NumeroFichier2 As Long, NumeroErreur2 As Long

On Error Resume Next

NumeroFichier2 = FreeFile()

Open MonClasseur2 For Input Lock Read As #NumeroFichier2

Close NumeroFichier2

NumeroErreur2 = Err

On Error GoTo 0

Select Case NumeroErreur2

Case 0: EstClasseurOuvert = False

Case 70: EstClasseurOuvert = True

Case Else: Error NumeroErreur2

End Select

End Function

Hier à 13:35

Bonjour

code a tester

Public Sub Worksheet_Calculate()

    ' Test si 2 classeurs existent ou pas

    Dim Monclasseur1 As String, Monclasseur2 As String
    Dim Verification1 As Boolean, Verification2 As Boolean

    If Range("AF5").Value <> "" And Range("AF6").Value <> "" And Range("AG5").Value <> "" And Range("AG6").Value <> "" Then Exit Sub

    ' chemin complet des 2 classeurs
    Monclasseur1 = Range("AK8").Value ' C:\Users\user\Desktop\Crx-maint\LIA maint.xlsm
    Monclasseur2 = Range("AK9").Value ' C:\Users\user\Desktop\Crx\LIA.xlsm

    ' Monclasseur1 existe ?
    If Range("AF5").Value = "" Then
        If Dir(Monclasseur1) <> vbNullString Then
            Range("AF5").Value = 1
        Else
            Range("AF5").Value = 0
        End If
    End If

    ' MonClasseur1 ouvert ?
    If Range("AF5").Value <> "" And Range("AF6").Value = "" Then
        Verification1 = EstClasseurOuvert(Monclasseur1)
        If Verification1 = True Then
            Range("AG5").Value = 1
        Else
            Range("AG5").Value = 0
        End If
    End If

    ' Monclasseur2 existe ?
    If Range("AF6").Value = "" Then
        If Dir(Monclasseur2) <> vbNullString Then
            Range("AF6").Value = 1
        Else
            Range("AF6").Value = 0
        End If
    End If

    ' MonClasseur2 ouvert ?
    If Range("AF5").Value <> "" And Range("AF6").Value <> "" Then
        Verification2 = EstClasseurOuvert(Monclasseur2)
        If Verification2 = True Then
            Range("AG6").Value = 1
        Else
            Range("AG6").Value = 0
        End If
    End If

End Sub

' Fonction pour vérifier si un classeur est ouvert
Function EstClasseurOuvert(MonClasseur As String) As Boolean
    Dim NumeroFichier As Long, NumeroErreur As Long

    On Error Resume Next
    NumeroFichier = FreeFile()

    Open MonClasseur For Input Lock Read As #NumeroFichier
    Close NumeroFichier
    NumeroErreur = Err

    On Error GoTo 0

    Select Case NumeroErreur
        Case 0: EstClasseurOuvert = False
        Case 70: EstClasseurOuvert = True
        Case Else: Error NumeroErreur
    End Select
End Function
Hier à 17:34

Bonjour le fil,

Pourquoi faire simple quand on peu faire compliqué ?
Matysek35, Vous avez la collection 'Workbooks qui est disponible et qui vous donne tous les classeurs qui sont ouverts.

Un simple boucle vous indiquera si un classeur est ouvert ou non.

Public Function WorkbookIsOpen(ByVal path As String) As Boolean
    Dim wb As Workbook
    If path > vbNullString Then
        Dim fullPath As String
        fullPath = LCase$(path)

        For Each wb In Application.Workbooks
            If LCase$(wb.FullName) = fullPath Then
                WorkbookIsOpen = True
                Exit Function
            End If
        Next wb
    Else
        WorkbookIsOpen = False
    End If
End Function

Et pour savoir si le classeur est présent sur le disque:

Public Function WorkbookExists(ByVal value As String) As Boolean
    If value > vbulstring Then
        WorkbookExists = Dir$(value, vbNormal) > vbNullString
    Else
        WorkbookExists = False
    End If
End Function

Joco7915, vous êtes sûr de cette ligne ?

    If Range("AF5").Value <> "" And Range("AF6").Value <> "" And Range("AG5").Value <> "" And Range("AG6").Value <> "" Then Exit Sub

Maintenant est-il judicieux de faire le test quand la feuille se calcule ?

Pour mettre à jour la cellule "AF5"

Option Explicit

Private Sub Workbook_Open()
    '// Teste si les classeurs sont présents sur le disque, et mets à jour les cellules
    With Feuil1 '// mettez le véritable nom de la feuille (son Code Name)
        .Range("AF5").value = WorkbookExists(.Range("AK8").value)
        .Range("AF6").value = WorkbookExists(.Range("AK9").value)
    End With

    '// Test si less classeurs sont ouverts et met à jour les cellules
    With Feuil1
        .Range("AG5").value = WorkbookIsOpen(.Range("AK8").value)
        .Range("AF6").value = WorkbookIsOpen(.Range("AK9").value)
    End With
End Sub
Aujourd'hui à 13:40

Merci Joco7915 de ton code à tester (avec 1 fonction dans le module (au lieu de 2). Au bilan :

Si les 2 fichiers existent mais non ouverts, c’est bon, les 4 cellules sont remplies, 2 à 1 (existent) & 2 à 0 (état)

Si 1 des fichiers est ouvert, son test d’existence est bon =1, mais son test d’état ="" au lieu de 1

Débogage & arrêt de la fonction à la ligne Open MonClasseur For Input Lock Read As #NumeroFichier

Le test du fichier 2 n’est pas effectué.

Dans le Sub, la ligne :

If Range("AF5").Value <> "" And Range("AF6").Value <> "" And Range("AG5").Value <> "" And Range("AG6").Value <> "" Then Exit Sub

Evite de passer par la macro lorsque les 4 cellules sont remplies (existence & état), dans le cas ou les 2 fichiers existent

La proposition de Jean-Paul fonctionne très bien. La macro de la feuille de calcul est supprimée & remplacée par les tests dans Workbook & il n’y a plus qu’1/2fonction dans un des Modules.

Merci Jean-Paul de ton code qui fonctionne parfaitement, après avoir supprimé celui de la feuille de calcul, placé le nouveau dans Workbook, supprimé 1 Module & créé 4 nouvelles cellules 0/1 adaptées aux résultats des 4 cellules initiales dont le résultat est vrai/faux dans ton code, pour retrouver ce que je souhaitais initialement et que j’utilise par ailleurs. L’équation ??? effectivement n’est plus utile.

Si vous le souhaitez, pour vous remercier, je peux, en message privé, puis par lien Dropbox, vous offrir ce petit cadeau numérique Excel pouvant lire l’heure en lettres & 26 langues, que j’ai réalisé il y a quelques temps voire, suivant un vrai intérêt, un autre Excel, bien plus complexe, de cryptage/décryptage, de data personnelles, messages, longs textes, tableur A4, formules, qui utilise le fichier de travail (dont je parlais), pour en visualiser certaines progressions.

Par ailleurs, pour éviter de coller directement mon code, directement dans un message sur le forum, j’ai bien essayé d’utiliser l’icône code, mais sans résultat, pour l’insérer, comme le font les posters.

Aujourd'hui à 16:32

Bonjour le fil,

Si vous le souhaitez, pour vous remercier, je peux, en message privé, puis par lien Dropbox, vous offrir ce petit cadeau numérique Excel pouvant lire l’heure en lettres & 26 langues, que j’ai réalisé il y a quelques temps voire, suivant un vrai intérêt, un autre Excel, bien plus complexe, de cryptage/décryptage, de data personnelles, messages, longs textes, tableur A4, formules, qui utilise le fichier de travail (dont je parlais), pour en visualiser certaines progressions.

Merci c'est gentil mais je pense que cela pourrait être mis dans la section téléchargements, cela permettrait à certains d'en bénéficier, et d'avoir des retours et qui sait peut-être des mouvements de codes qui seraient bénéfiques.

Par ailleurs, pour éviter de coller directement mon code, directement dans un message sur le forum, j’ai bien essayé d’utiliser l’icône code, mais sans résultat, pour l’insérer, comme le font les posters.

Cela me parait bizarre, utilisez-vous la bonne icônes ?

image

Puis un simple copier/Coller...

image

Et voilà le résultat.

' // Déclarations WithEvents spécifiques pour chaque type de contrôle
Private WithEvents commandLabel As MSForms.Label
Private WithEvents textBoxControl As MSForms.TextBox
Private WithEvents comboBoxControl As MSForms.ComboBox
Private WithEvents listBoxControl As MSForms.ListBox

Friend Property Set HoverButton(ByRef Value As MSForms.control)
    mControlType = typeName(Value)
    Select Case mControlType
        Case "Label"
            Set commandLabel = Value
            Dim ctrlType As String
            ctrlType = GetTheValue(commandLabel.Tag, "Type")
            mIsMenuButton = (ctrlType = BUTTON_MENU)
        Case "TextBox"
            Set textBoxControl = Value
        Case "ComboBox"
            Set comboBoxControl = Value
        Case "ListBox"
            Set listBoxControl = Value
    End Select
End Property

'Description :  Couleur de fond initiale du contrôle.
Public Property Get InitialBackColor() As Long
    InitialBackColor = mInitialBackColor
End Property
Private Property Let InitialBackColor(ByVal Value As Long)
    mInitialBackColor = Value
End Property

'Description :  Couleur de bordure initiale du contrôle.
Public Property Get InitialBorderColor() As Long
    InitialBorderColor = mInitialBorderColor
End Property
Private Property Let InitialBorderColor(ByVal Value As Long)
    mInitialBorderColor = Value
End Property

Bonne programmation.

Aujourd'hui à 17:43

Pour les cadeaux potentiels, je les ai conçu et individualisé pour des amis ou des personnes d'intérêt, mais pas pour une diffusion massive ou potentiellement dangereuse à des personnes mal intentionnées...

Concernant le code à joindre au message, après plusieurs essais précédents, en utilisant la bonne icône, j'arrivais à copier/coller, mais la touche insersion n'apparaissait pas...

Rechercher des sujets similaires à "test etat ouverts fermes classeurs existent"