XL 2016 Ouverture fichier via msgbox avec fréquence

MickaeL_D · 7 Octobre 2021

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,

patricktoulon · 7 Octobre 2021

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 · 7 Octobre 2021

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.

MickaeL_D · 7 Octobre 2021

Bonjour Dudu2,

Peux-tu m'aider à initier le code stp

patricktoulon · 7 Octobre 2021

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

patricktoulon · 7 Octobre 2021

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

FONCTION ISOWEEK pour ceux qui ne l'ont pas dans leur version excel

bonjour a tous voici 2 fonctions vous permettant d'obtenir le numero iso de la semaine d'une date quand votre version excel n'a pas cette fonction methode 1°(@patricktoulon ) utilisation de "evaluate" 'LA fonction Function ISOWEEK2007(dat As...

www.excel-downloads.com

maintenant tu a tes deux solution
Enjoy

MickaeL_D · 7 Octobre 2021

Bonjour patricktoulon,

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

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

patricktoulon · 7 Octobre 2021

re

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

la bonne blague peut être justement que le fichier a déjà été ouvert cette semaine
c'est le but de la manœuvre non??????
ou alors il va falloir t'expliquer

Dudu2 · 7 Octobre 2021

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 · 7 Octobre 2021

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

Dudu2 · 7 Octobre 2021

Pour tester les méthodes de @patricktoulon, il faut que tu installes Attribute Changer pour gérer la date de mise à jour de ton fichier et vérifier le code.

patricktoulon · 7 Octobre 2021

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

MickaeL_D · 7 Octobre 2021

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?

patricktoulon · 7 Octobre 2021

MickaeL_D à dit:
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 · 7 Octobre 2021

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 · 7 Octobre 2021

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

XL 2016 Ouverture fichier via msgbox avec fréquence

MickaeL_D

XLDnaute Junior

patricktoulon

Dudu2

XLDnaute Barbatruc

MickaeL_D

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

FONCTION ISOWEEK pour ceux qui ne l'ont pas dans leur version excel

MickaeL_D

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

Dudu2

XLDnaute Barbatruc

patricktoulon

XLDnaute Barbatruc

MickaeL_D

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

MickaeL_D

XLDnaute Junior

patricktoulon

XLDnaute Barbatruc

Discussions similaires