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...

Dudu2

XLDnaute Barbatruc
Bonjour,
Eh bien, tu valorises dans une cellule la date du jour après l'activation de l'hyperlien, suivi par un Save du classeur pour être sûr de ne pas la perdre.
Et avant d'activer l'hyperlien tu vérifies que la date dans la cellule est bien inférieur d'une semaine, sinon tu rejettes avec un message.
 

patricktoulon

XLDnaute Barbatruc
Bonjour
c'est un peu compliqué dans le sens 1 fois par semaine c'est vague
en effet tu peux trèsbien ouvrir ton fichier le samedi de la semaine dernière et le rouvrir le lundi de la suivante
il ne c'est donc pas passé 7 jours

donc si ce fait ne tient pas alors c'est simple on vérifie la date du dernier accès avant "reponse"
VB:
Sub test()

    Dim fichier$, OldDate As Date, réponse As VbMsgBoxResult
  
    fichier = "C:\Users\polux\DeskTop\fichierAouvrir.xlsm"
  
    'récupération de la date du dernier accès (Attention!!!! en string !!!!!!)
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
        OldDate = CDate(Mid(.DateLastAccessed, 1, 10))
    End With
  
   If OldDate + 7 > Date Then Exit Sub ' si cette date + 7 jour est plus grand que la date du jour on sort de la sub
  
    'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
         ThisWorkbook.FollowHyperlink fichier, , True
    End If
End Sub
voilà
je regarde pour faire un exemple par semaine quelque soit le jour d'ouverture
 
Dernière édition:

patricktoulon

XLDnaute Barbatruc
re
et avec ma fonction perso isoweek2007 là cette fois ci on teste vraiment la semaine quelque soit le jour ou il a été ouvert
VB:
Sub test()

    Dim fichier$, OldWeek As Long, ActualWeek As Long, réponse As VbMsgBoxResult
   
    fichier = "C:\Users\polux\DeskTop\fichierAouvrir.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
   
    'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
         ThisWorkbook.FollowHyperlink fichier, , 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

le lien de ma fonction isoweek

maintenant tu a tes deux solution
Enjoy;)
 

MickaeL_D

XLDnaute Junior
Bonjour patricktoulon,

Merci beaucoup. par contre j'ai inséré le code dans "Thisworkbook" mais rien ne se passe :oops:

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\AUMA\VITESSE TAPIS\CDC-2011-96 vitesse_tapis_ed00.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
  
    'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl 2011-96", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
         ThisWorkbook.FollowHyperlink fichier, , 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
 

Dudu2

XLDnaute Barbatruc
Tu dois ajuster les constantes NomFeuilleDateModif et AdresseCelluleDateModif.
VB:
Option Explicit

Private Sub Workbook_Open()
    Dim Réponse As Variant
    Dim CelluleDateModif As Range
    Dim DateModif As Date
    Dim TakeIt As Boolean
    '
    Const NomFeuilleDateModif = "Feuil1"
    Const AdresseCelluleDateModif = "A1"
 
    'Cellule de la date de dernière modification
    Set CelluleDateModif = Me.Worksheets(NomFeuilleDateModif).Range(AdresseCelluleDateModif)
 
    'Si cette cellule contient une date
    If IsDate(CelluleDateModif.Value) Then
        DateModif = CelluleDateModif.Value
        If DateDiff("d", DateModif, Date) >= 7 Then TakeIt = True
 
    'Si cette cellule ne contient pas une date
    Else
        TakeIt = True
    End If
 
    If TakeIt Then
        Réponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo + vbQuestion, "Remplir la carte de ctrl")
        If Réponse = vbNo Then Exit Sub
    
        ThisWorkbook.FollowHyperlink "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\AUMA\VITESSE TAPIS\CDC-2011-96 vitesse_tapis_ed00.xlsm"
        CelluleDateModif = Date
        ThisWorkbook.Save
    End If
End Sub

Edit: La méthode de @patricktoulon est plus sûre dans la mesure où il regarde la date de mise à jour du fichier.
La méthode de ce post est applicable si chaque utilisateur a son propre fichier et n'a droit qu'à une mise à jour par semaine tout en acceptant que le fichier soit mis à jour plusieurs fois par semaine par différents utilisateurs.
 

patricktoulon

XLDnaute Barbatruc
d'autre te proposeront peut etre d'utiliser filedatetime interne dans VBA
elle donne en général la date de création du fichier ou la date de dernier accès
cela dit c'est pas toujours exacte c'est pour cela que je ne l'ai pas proposé
mais au cas ou voila les 3 méthodes

methode 1 absolument 7 jours d'ecart
VB:
Sub test1()
    Dim fichier$, OldDate As Date, réponse As VbMsgBoxResult
      fichier = "C:\Users\polux\DeskTop\fichierAouvrir.xlsm"
      'récupération de la date du dernier accès (Attention!!!! en string !!!!!!)
    With CreateObject("Scripting.FileSystemObject").GetFile(fichier)
        OldDate = CDate(Mid(.DateLastAccessed, 1, 10))
    End With
  MsgBox "date de dernier accès " & OldDate & vbCrLf & "aujourd'hui " & Date
   If OldDate + 7 > Date Then Exit Sub ' si cette date + 7 jour est plus grand que la date du jour on sort de la sub
     'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
         ThisWorkbook.FollowHyperlink fichier, , True
    End If
End Sub

méthode 2 la semaine doit être différente quelque soit le jour de la dernière ouverture avec FSO et ma fonction isoweek2007
Code:
Sub test2()
    Dim fichier$, OldWeek As Long, ActualWeek As Long, réponse As VbMsgBoxResult
    fichier = "C:\Users\polux\DeskTop\fichierAouvrir.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
    MsgBox "semaine precedente " & OldWeek & vbCrLf & "semaine actuelle " & ActualWeek
    If ActualWeek = OldWeek Then Exit Sub  ' si cette date + 7 jour est plus grand que la date du jour on sort de la sub
    'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
        ThisWorkbook.FollowHyperlink fichier, , 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

et enfin la même que la précédente mais avec filedatetime et ma fonction isoweek2007
Code:
Sub test3()
    Dim fichier$, OldWeek As Long, ActualWeek As Long, réponse As VbMsgBoxResult
    fichier = "C:\Users\polux\DeskTop\fichierAouvrir.xlsm"
    'récupération de la date du dernier accès (Attention!!!! en string !!!!!!)
    OldWeek = ISOWEEK2007(CDate(Mid(FileDateTime(fichier), 1, 10)))
    ActualWeek = ISOWEEK2007(Date)
    MsgBox "semaine precedente " & OldWeek & vbCrLf & "semaine actuelle " & ActualWeek
    If ActualWeek = OldWeek Then Exit Sub  ' si cette date + 7 jour est plus grand que la date du jour on sort de la sub
    'sinon on a la question avec le message (si on veut ou pas l'ouvrir)
    reponse = MsgBox("Renseigner la carte de ctrl XXXXX", vbYesNo And vbExclamation, "Remplir la carte de ctrl")
    If reponse = vbOK Then
        ThisWorkbook.FollowHyperlink fichier, , 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

voila les 3 versions ont été testées;)
 

patricktoulon

XLDnaute Barbatruc
re
Bonjour @Dudu2 ou alors il teste avec un autre fichier qui n'a pas été ouvert il y a longtemps
ensuite il le ferme et il le rouvre pour voir si le 2d tour bloque l'ouverture
pas compliqué il y a juste a changer le chemin de "fichier"
;)

ps:
dans le post ou je donne les 3 versions j'ai placé un msgbox qu'il faudra enlever c'est juste pour te montrer que le calcul date /semaine est bien effectué
ne pas oublier de l'enlever cette ligne !!!!
 

patricktoulon

XLDnaute Barbatruc
Merci beaucoup patricktoulon. J'ai testé le code avec un fichier qui n'a pas été ouvert cette semaine. ça marche parfaitement.
Ce code peut-il être adapté pour tester 2 fichiers indépendant?
tu peux etre plus clair dans tes demandes c'est quoi deux fichiers indépendants
tu dois ouvrir deux fichiers c'est ça ??????
mais d'abords quelle solution a tu adopté ???????,
 

MickaeL_D

XLDnaute Junior
Ajouter un fichier 1 par exemple puis faire les mêmes vérifications

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"
    'fichier 1 = "S:\PRODUCTION\2010-2011\01 - Cartes de contrôle\DISSO\CDC_75000.xlsm"' 'Puis continuer le code ci-dessous'
    
    '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
  
    '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
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
 

patricktoulon

XLDnaute Barbatruc
a ben on peut transformer cela en fonction pour tester 36 fichiers si tu veux
it's not a problème

néanmoins
reste un tout petit problème avec ce raisonnement
imaginons que j'ai ouvert le fichier précédemment a la même semaine ou le même jour et même mois mais!!! une ou x année(s) en arrière
c'est ballo!! hein
qu'est ce que je me marre avec ces trucs moi 😂😂😂
 
Haut Bas