XL 2016 Ouverture fichier via msgbox avec fréquence

Créer une discussion
Répondre

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
M

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
patricktoulon
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...
Trier par date Trier par votes
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 👍
 
Vote positif 0 Vote négatif
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:
Vote positif 0 Vote négatif
Solution
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
 
Vote positif 0 Vote négatif
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 😉
 
Vote positif 0 Vote négatif
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...
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

A
  • Résolu(e)
XL 2021 Céer un fichier (.text) avec VBA pour enregistrer les évènements dans un journal
Réponses
4
Affichages
668
arnoldbrice19
A
M
  • Résolu(e)
XL 2016 Erreur de compilation "FOR"
Réponses
5
Affichages
893
MickaeL_D
M
steph59940
  • Question Question
XL 2019 Ouverture fichier xlsx dans dossier nom variable.
2
Réponses
16
Affichages
1 K
steph59940
steph59940
M
  • Résolu(e)
XL 2016 Conditions VBA entre 2 colonnes
2
Réponses
20
Affichages
2 K
MickaeL_D
M
M
  • Résolu(e)
XL 2016 Pb avec code VBA
Réponses
10
Affichages
1 K
MickaeL_D
M
bellenm
  • Question Question
Gmail via CDO, attacher un fichier PDF, des adresses, un objet et un corps bien définit, code de Roland_M.
2 3
Réponses
43
Affichages
6 K
Roland_M
Roland_M
Retour