Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

XL 2016 Ouverture fichier via msgbox avec fréquence

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

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
 
Vote positif 0 Vote négatif

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:
Vote positif 0 Vote négatif
Solution

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
 
Vote positif 0 Vote négatif
M

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
 
Vote positif 0 Vote négatif
M

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...
 
Vote positif 0 Vote négatif
Identifiez-vous ou inscrivez-vous pour participer.

Discussions similaires

M
  • Résolu(e)
XL 2016 Erreur de compilation "FOR"
Réponses
5
Affichages
851
MickaeL_D
M
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
463
arnoldbrice19
A
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
Menu
Connexion
S'inscrire
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…