XL 2016 Ouverture fichier via msgbox avec fréquence

MickaeL_D

XLDnaute Junior
Bonjour à tous les experts,

Comment puis-je adapter le code ci-dessous pour que le fichier cité en lien hypertexte s'ouvre seulement à la première ouverture de celui-ci et une seule fois par semaine.

VB:
Private Sub Workbook_Open()
        MsgBox "Renseigner la carte de ctrl XXXXX", vbExclamation, "Remplir la carte de ctrl"
            If Reponse = vbOK Then
        ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\AUMA\VITESSE TAPIS\CDC-2011-96 vitesse_tapis_ed00.xlsm"
    End If
End Sub

Merci d'avance,
 
Solution
oui mais je ne l'entendais pas comme cela en fait
quand je dis transformer en fonction c'est vraiment rendre la fonctionnalité indépendante de la sub
pour le coup voici un exemple avec la fonction indépendante dans la quelle j'ai mergé ma méthode isoweek
donc fonction (tout en un) que l'on appelle par la sub
donc !!
voila la sub pour 2 fichiers
VB:
Sub test4()
    Dim fichier1$, Fichier2$, reponse As VbMsgBoxResult
    fichier1 = "C:\Users\polux\DeskTop\fichierAouvrir.xlsm"
    Fichier2 = "C:\Users\polux\DeskTop\fichierAouvrir2.xlsm"

    If ouvrable(fichier1) Then
        reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
        If reponse = vbOK Then...

MickaeL_D

XLDnaute Junior
Ah ouais je n'y avais pas pensé!!! 😂
J'ai adapté le code comme ça
VB:
Private Sub Workbook_Open()
Dim fichier$, OldWeek As Long, ActualWeek As Long, réponse As VbMsgBoxResult
  
    fichier = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\DISSO\CDC_75064.xlsm"
    fichier1 = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\DISSO\CDC_608868.xlsm"
  
    'récupération de la date du dernier accès (Attention!!!! en string !!!!!!)
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
        OldWeek = ISOWEEK2007(CDate(Mid(.DateLastAccessed, 1, 10)))
    ActualWeek = ISOWEEK2007(Date)
    End With
     If ActualWeek = OldWeek Then Exit Sub  ' si cette date + 7 jour est plus grand que la date du jour on sort de la sub
    
     With CreateObject("Scripting.FileSystemObject").GetFile(fichier1)
        OldWeek = ISOWEEK2007(CDate(Mid(.DateLastAccessed, 1, 10)))
    ActualWeek = ISOWEEK2007(Date)
    End With
     If ActualWeek = OldWeek Then Exit Sub
  
    'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl 75064", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
         ThisWorkbook.FollowHyperlink fichier, , True
    End If
    reponse = MsgBox("Renseigner la carte de ctrl 608868", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
         ThisWorkbook.FollowHyperlink fichier1, , True
    End If
End Sub
Function ISOWEEK2007(dat As Date)
    Dim X&
    X = CLng(dat)
    ISOWEEK2007 = Evaluate("= TRUNC((" & X & "-WEEKDAY(" & X & ",2)+11-DATE(YEAR(" & X & "-WEEKDAY(" & X & " ,2)+4),1,1))/7)")
End Function
ça à l'air de fonctionner 👍
 

patricktoulon

XLDnaute Barbatruc
oui mais je ne l'entendais pas comme cela en fait
quand je dis transformer en fonction c'est vraiment rendre la fonctionnalité indépendante de la sub
pour le coup voici un exemple avec la fonction indépendante dans la quelle j'ai mergé ma méthode isoweek
donc fonction (tout en un) que l'on appelle par la sub
donc !!
voila la sub pour 2 fichiers
VB:
Sub test4()
    Dim fichier1$, Fichier2$, reponse As VbMsgBoxResult
    fichier1 = "C:\Users\polux\DeskTop\fichierAouvrir.xlsm"
    Fichier2 = "C:\Users\polux\DeskTop\fichierAouvrir2.xlsm"

    If ouvrable(fichier1) Then
        reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
        If reponse = vbOK Then
            ThisWorkbook.FollowHyperlink fichier1, , True
        End If
    Else
        MsgBox "le fichier a deja été ouvert cette semaine "
    End If


    If ouvrable(Fichier2) Then
        reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
        If reponse = vbOK Then
            ThisWorkbook.FollowHyperlink fichier2, , True
        End If
    Else
        MsgBox "le fichier a deja été ouvert cette semaine "
    End If
End Sub

bon maintenant voilà la fonction (tout en un) qui renvoie un bouleen (true ou false)
VB:
Function ouvrable(fichier As String)
    Dim OldWeek&, ActualWeek&, ISOWEEK1&, ISOWEEK2&
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
        OldWeek = CLng(CDate(Mid(.DateLastAccessed, 1, 10)))
        ActualWeek = CLng(Date)
    End With
    ISOWEEK1 = Evaluate("= TRUNC((" & OldWeek & "-WEEKDAY(" & OldWeek & ",2)+11-DATE(YEAR(" & OldWeek & "-WEEKDAY(" & OldWeek & " ,2)+4),1,1))/7)")
    ISOWEEK2 = Evaluate("= TRUNC((" & ActualWeek & "-WEEKDAY(" & ActualWeek & ",2)+11-DATE(YEAR(" & ActualWeek & "-WEEKDAY(" & ActualWeek & " ,2)+4),1,1))/7)")
    'MsgBox "semaine precedente " & ISOWEEK1 & vbCrLf & "semaine actuelle " & ISOWEEK2 'ligne a supprimer
    ouvrable = ISOWEEK1 < ISOWEEK2
End Function
et voilà ;)
bon j'ai bloqué le message de test dans la fonction ;libre a toi de le debloquer pour faire tes test et comprendre le schmilblick
 
Dernière édition:

fanch55

XLDnaute Barbatruc
Bonjour à tous
Pour ne pas être tributaire du fichier cible qui a pu être ouvert par n'importe qui ou n'importe quand,
Il vous faut indiquer la date prévisionnelle d'ouverture du fichier cible dans une cellule .
En supposant que la cellule est A1 et que le jour d'ouverture du fichier est le Lundi .
VB:
Private Sub Workbook_Open()
    If Date >= [A1] Then
       If MsgBox("Renseigner la carte de ctrl XXXXX", vbExclamation + vbOKCancel, "Remplir la carte de ctrl") = vbOK Then
            ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\AUMA\VITESSE TAPIS\CDC-2011-96 vitesse_tapis_ed00.xlsm"
            J = 1  ' 1:Lundi 2:Mardi etc...
            [A1] = Date + (8 + (J - Weekday(Date))) Mod 7
        End If
    End If
End Sub
 

MickaeL_D

XLDnaute Junior
Merci beaucoup patricktoulon

VB:
Private Sub Workbook_Open()
    Dim fichier1$, Fichier2$, reponse As VbMsgBoxResult
    fichier1 = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\DISSO\CDC_75064.xlsm"
    Fichier2 = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\AUMA\TEMPERATURE AUMA AVANT DEMARRAGE\CDC-2011-94 température AUMA au démarrage_ed02.xlsm"

    If ouvrable(fichier1) Then
        reponse = MsgBox("Renseigner la carte de ctrl 75064", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
        If reponse = vbOK Then
            ThisWorkbook.FollowHyperlink fichier1, , True
        End If
    Else
        MsgBox "la carte de ctrl 75064 a déjà été renseignée cette semaine "
    End If


    If ouvrable(Fichier2) Then
        reponse = MsgBox("Renseigner la carte de ctrl 2011-94", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
        If reponse = vbOK Then
            ThisWorkbook.FollowHyperlink Fichier2, , True
        End If
    Else
        MsgBox "la carte de ctrl 2011-94 a déjà été renseignée cette semaine "
    End If
End Sub

En intégrant la fonction bien sûr

VB:
Function ouvrable(fichier As String)
    Dim OldWeek&, ActualWeek&, ISOWEEK1&, ISOWEEK2&
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
        OldWeek = CLng(CDate(Mid(.DateLastAccessed, 1, 10)))
        ActualWeek = CLng(Date)
    End With
    ISOWEEK1 = Evaluate("= TRUNC((" & OldWeek & "-WEEKDAY(" & OldWeek & ",2)+11-DATE(YEAR(" & OldWeek & "-WEEKDAY(" & OldWeek & " ,2)+4),1,1))/7)")
    ISOWEEK2 = Evaluate("= TRUNC((" & ActualWeek & "-WEEKDAY(" & ActualWeek & ",2)+11-DATE(YEAR(" & ActualWeek & "-WEEKDAY(" & ActualWeek & " ,2)+4),1,1))/7)")
    'MsgBox "semaine precedente " & ISOWEEK1 & vbCrLf & "semaine actuelle " & ISOWEEK2 'ligne a supprimer
    ouvrable = ISOWEEK1 < ISOWEEK2
End Function

Tout fonctionne parfaitement ;)
 

MickaeL_D

XLDnaute Junior
J'ai adapté le code comme suit :

VB:
Private Sub Workbook_Open()
    Dim fichier1$, Fichier2$, reponse As VbMsgBoxResult
    fichier1 = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\AUMA\VITESSE TAPIS\CDC-2011-96 vitesse_tapis_ed00.xlsm"
    Fichier2 = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\AUMA\TEMPERATURE AUMA AVANT DEMARRAGE\CDC-2011-94 température AUMA au démarrage_ed02.xlsm"

    If ouvrableByMonth(fichier1) Then
        reponse = MsgBox("Renseigner la carte de ctrl 2011-96", vbYesNo And vbInformation, "Information : Vitesse tapis AUMA à mesurer")
        If reponse = vbOK Then
            ThisWorkbook.FollowHyperlink fichier1, , True
        End If
    Else
        MsgBox "La vitesse tapis AUMA a déjà été mesurée ce mois-ci "
    End If


    If ouvrable(Fichier2) Then
        reponse = MsgBox("Renseigner la carte de ctrl 2011-94", vbYesNo And vbInformation, "Information : Température AUMA à mesurer")
        If reponse = vbOK Then
            ThisWorkbook.FollowHyperlink Fichier2, , True
        End If
    Else
        MsgBox "La température AUMA a déjà été mesurée cette semaine "
    End If
End Sub

Code:
Function ouvrable(fichier As String)
    Dim OldWeek&, ActualWeek&, ISOWEEK1&, ISOWEEK2&
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
        OldWeek = CLng(CDate(Mid(.DateLastAccessed, 1, 10)))
        ActualWeek = CLng(Date)
    End With
    ISOWEEK1 = Evaluate("= TRUNC((" & OldWeek & "-WEEKDAY(" & OldWeek & ",2)+11-DATE(YEAR(" & OldWeek & "-WEEKDAY(" & OldWeek & " ,2)+4),1,1))/7)")
    ISOWEEK2 = Evaluate("= TRUNC((" & ActualWeek & "-WEEKDAY(" & ActualWeek & ",2)+11-DATE(YEAR(" & ActualWeek & "-WEEKDAY(" & ActualWeek & " ,2)+4),1,1))/7)")
    ouvrable = ISOWEEK1 < ISOWEEK2
End Function

Code:
Function ouvrableByMonth(fichier As String)
    Dim OldDate As Date
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
    OldDate = CDate(Mid(.DateLastAccessed, 1, 10))
    End With
    ouvrableByMonth = Month(oldate) < Month(Date)
End Function

Par contre, j'ai fait un essai avec un fichier qui n'a pas été enregistré depuis plus d'un mois. Mais il ne s'ouvre pas...
 

Statistiques des forums

Discussions
315 088
Messages
2 116 088
Membres
112 657
dernier inscrit
jpb3