Déterminer un temps d'utilisation d'un fichier

Version imprimable

02/10/2015, 17h03
graphikris

Déterminer un temps d'utilisation d'un fichier

Bonjour,

Devant réaliser des QCM, j'ai décidé de les réaliser avec Excel.
Ces QCM sont réalisés avec des boutons "Choix" regroupés par 5 dans des groupes.
Sur une seconde feuille, j'ai les cellules liées des réponses et en fonction du choix du candidat, soit il obtient "0" ou "1". "1" étant la note pour une bonne réponse.
une note finale sur 20 est également mise sur cette seconde feuille.

Je désirerai à l'ouverture du document, indiquer au candidat, qu'il possède 30mn pour effectuer son test (jusque là, je sais comment faire en VBA),
Dès que le candidat clique sur le bouton OK de cette boite de dialogue, Excel doit commençait le décompte.
A l'issue des 30mn, Excel averti le candidat que le test est fini et lui donne sa note sur 20 (on suppose que le résultat est sur 'Feuil2!B21') et enregistre le fichier sur (C:/TEST) puis transmet ce fichier avec Outlook à un destinataire bien précis.

Concernant l'envoi par mail, je sais faire, j'ai le code.

J'ai besoin uniquement de connaître le code pour avertir que le test est fini, qu'il donne la note sur 20 et l'enregistre sur C:/TEST

J'aimerai aussi que le candidat ne puisse plus rouvrir le questionnaire afin de refaire le test, mais là je crois que je rêve, meme en Vba, ça doit etre irrealisable.

Quelqu'un pourrait-il m'aider ?

Cordialement.

Bonjour,

Une piste. Au lancement du test (un bouton Formulaire affecté à la macro "DepartTest"), un message est affiché prévenant que le test commence sitôt le clic sur le bouton OK, le décompte est indiqué en cellule A1 de la feuille active. Les 30 mn passées, un message informe que le test est fini et indique le résultat obtenu. Ensuite, les case à cocher

Citation:

avec des boutons "Choix"

(je n'ai pas trop sue comment interpréter) sont cachées afin qu'il ne puisse plus y avoir de modification. Le classeur est enregistré sous.. avec le nom qu'il porte (je présume que c'est celui du candidat) puis fermé. A mettre dans un module standard et tester. Pour que ton test dure moins longtemps, tu peux réduire la valeur à l'appel de la Sub "Minuterie" sachant que 1000 représente une seconde ("GetTickCount " retourne des millisecondes) :
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 Declare Function GetTickCount Lib "Kernel32" () As Long Dim Finir As Boolean Sub Minuterie(Milliseconde As Long) Dim Arret As Long Arret = GetTickCount() + Milliseconde Do While GetTickCount() < Arret 'décompte en A1 de la feuille active Range("A1").Value = Format((Arret - GetTickCount()) / 1000, "00:00:00") DoEvents Loop End Sub Sub Chrono() Dim S As Shape Dim I As Integer MsgBox "Attention, après le clic sur le bouton OK le test commence et vous avez 30 minutes pour le réaliser !" '30 minutes 1000 x 60 x 30 Minuterie 1800000 'comptage des points, ici selon ce qui est inscrit par les contrôles liés il faut adapter... For I = 1 To 20 If Worksheets("Feuil2").Cells(I, 2).Value = True Then J = J + 1 Next I 'fin du test MsgBox "Le test est fini, vous ne pouvez plus apporter de modification !" _ & vbCrLf & "Votre résultat est de " & J & "/20" 'cache les cases à cocher For Each S In ActiveSheet.Shapes If S.FormControlType = xlCheckBox Then S.Visible = False Next S 'enregistre sous... avec le nom du classeur qui normalement porte le nom du candidat ThisWorkbook.SaveAs "C:\TEST\" & ThisWorkbook.Name 'et ferme le classeur ThisWorkbook.Close End Sub

03/10/2015, 10h23
graphikris

Bonjour et merci, je teste la semaine prochaine au boulot.
Bon W.E,

Je vous tiens au courant
03/10/2015, 12h37
graphikris

J'ai voulu faire un test chez moi mais je dispose de la version 2013 en 64 bits et j'ai le msg suivant (j'ai placé le code Vba sur Feuil1) :
Pièce jointe 189325
03/10/2015, 13h23
Philippe Tulliez

Bonjour,

Citation:

J'ai voulu faire un test chez moi mais je dispose de la version 2013 en 64 bits et j'ai le msg suivant (j'ai placé le code Vba sur Feuil1)

Je ne sais pas qui à pris la décision de choisir la version 64 bits mais voici un petit lien intéressant à lire qui nous "rassure" quant à la portabilité des produits Microsoft http://arkham46.developpez.com/artic...ice/vba64bits/. Article qui t'apportera sûrement une partie de la solution.
En tous les cas, j'ai pris la décision de rester en 32 bits et déconseille à toutes personnes qui m'en parlent de passer à la version 64 bits
03/10/2015, 13h47
graphikris

LE P.O etait installé d'origine sur mon PC quand je l'ai acheté.
03/10/2015, 13h50
Philippe Tulliez

Bonjour,

Citation:

LE P.O etait installé d'origine sur mon PC quand je l'ai acheté.

Rien n'est parfait dans ce monde. En tous les cas courage.

Bonjour,

tiens voila un exemple de temporisation sans appel API , les fonctions standard d'Excel suffisent ..

la "temporisation" est lancée grâce à la procédure t_boucle, une fois lancée cette procédure est appelée toutes les secondes grâce à application.onTime...

à chaque mise à jour (toutes les secondes) la procédure à adapter t_Maj est appelée ..

lorsque le temps est atteint ( ici heure de lancement + 20 secondes) c'est la procédure t_Fin() qui est lancée...

à toi d'adapter t_Maj et t_Fin

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
Sub LanceTempo()
    t_boucle True, Now + TimeSerial(0, 0, 20)
End Sub
'
' Procedure t_boucle appelée toutes les secondes pour contrôle fin temporisation
'
' Parametres :
'   bEncours = mettre à True pour activer timer, à false pour fin timer
'   tFin  = Date de fin boucle ...
'
Sub t_boucle(Optional bEnCours As Boolean = True, Optional tFin As Date = 0)
    Debug.Print Now
    Static m_tfin As Date 'Date de fin
    If tFin > 0 Then m_tfin = tFin
    Static t As Date
    If bEnCours Then
            t = Now + TimeSerial(0, 0, 1)
            Application.OnTime t, "t_Boucle"
            If Now >= m_tfin Then t_Fin Else t_Maj (m_tfin - Now)
      Else
         Application.OnTime t, "t_Boucle", , False
    End If
 
End Sub
'
' procédure appellée toutes les secondes durant déroulement temporisation
'
Private Sub t_Maj(t As Date)
 Debug.Print "temps restant = " & t
 
End Sub
'
' Procédure exécutée sur fin timer..
'
Private Sub t_Fin()
   MsgBox "Temps terminé"
   t_boucle False
End Sub

03/10/2015, 18h31
graphikris

Bonjour Theze,

Je viens de désinstaller la Version 64 bits et j'ai remis celle en 32 bits.
Nouveau bug avec ton code :
Pièce jointe 189341

Pour les autres réponses, j'ai besoin d'un peu plus d'explications, je suis blonde (lol). Par exemple, je colle où le code (Feuil1 ou ThisWorkbook avec quelle déclaration (before open ???)

Merci a vous tous
04/10/2015, 08h40
Theze
Bonjour,

Tu as mis le code dans le module de la feuille et dans ce cas, les APIs doivent être déclarées "Private" Donc comme ceci :
Code:

1 2 Private Declare Function GetTickCount Lib "Kernel32" () As Long
04/10/2015, 10h25
graphikris

Bonjour Theze,

J'ai fait ce que tu m'as dit mais je n'ai pas le msgbox au demarrage du fichier, il faut que je crais un bouton pour déclencher la macro et ce n'est pas ce que je veux.

J'ai mis ton code dans Thisworkbook avec OPEN mais y a erreur.

Cordialement

Bon déjà j'ai oublié de déclarer une variable donc, je te re-poste le code.
Mets ce code dans un module standard :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
 
Declare Function GetTickCount Lib "Kernel32" () As Long
 
Dim Finir As Boolean
 
Sub Minuterie(Milliseconde As Long)
 
    Dim Arret As Long
 
    Arret = GetTickCount() + Milliseconde
 
    Do While GetTickCount() < Arret
 
        'décompte en A1 de la feuille active
        Range("A1").Value = Format((Arret - GetTickCount()) / 1000, "00:00:00")
        DoEvents
 
    Loop
 
End Sub
 
Sub DepartTest()
 
    Dim S As Shape
    Dim I As Integer
    Dim J As Integer
 
    MsgBox "Attention, après le clic sur le bouton OK le test commence et vous avez 30 minutes pour le réaliser !"
 
    '30 minutes 1000 x 60 x 30
    Minuterie 1800000
 
    'comptage des points, ici selon ce qui est inscrit par les contrôles liés il faut adapter...
    For I = 1 To 20
 
        If Worksheets("Feuil2").Cells(I, 2).Value = True Then J = J + 1
 
    Next I
 
    'fin du test
    MsgBox "Le test est fini, vous ne pouvez plus apporter de modification !" _
           & vbCrLf & "Votre résultat est de " & J & "/20"
 
    'cache les cases à cocher
    For Each S In ActiveSheet.Shapes
        If S.FormControlType = xlCheckBox Then S.Visible = False
    Next S
 
    'enregistre sous... avec le nom du classeur qui normalement porte le nom du candidat
    ThisWorkbook.SaveAs "C:\TEST\" & ThisWorkbook.Name
 
    'et ferme le classeur
    ThisWorkbook.Close
 
End Sub

et celui-ci dans le module du classeur :

Code:

1
2
3
4
5
6
 
Private Sub Workbook_Open()
 
    DepartTest
 
End Sub

tu enregistre, tu ferme et tu ré-ouvre, le message s'affiche sitôt le classeur ouvert.

Bonjour Theze,

Je viens de construire ma feuille concernant le questionnaire puis j'ai mis les 2 codes au bon endroit.

Nickel, ça fonctionne

Concernant le msgbox donnant le resultat (voir code ci dessous) je ne comprend pas trop bien car j'ai en Feuil2 un tableau (voir plus bas une copie ecran avec en cellule D44 le total sur 20, mais je ne sais pas comment lui dire d'aller mettre dans le msgbox ce résultat.
Code:

1 2 3 4 5 6 7 8 9 10 'comptage des points, ici selon ce qui est inscrit par les contrôles liés il faut adapter... For I = 1 To 20 If Worksheets("Feuil2").Cells(I, 2).Value = True Then J = J + 1 Next I 'fin du test MsgBox "Le test est fini, vous ne pouvez plus apporter de modification !" _ & vbCrLf & "Votre résultat est de " & J & "/20"
Pièce jointe 189385

J'ai mis ce code mais ce n'est pas correct
Code:

1 2 3 'fin du test MsgBox "Le test est fini, vous ne pouvez plus apporter de modification !" _ & vbCrLf & "Votre résultat est de " & Worksheets("Reponses").Cells(D, 44).Value
J'ai remarqué que si le repertoire TEST n'est pas créé, ça bug, il faudrait dans ce cas que le repertoire ce créé automatiquement s'il n'existe pas.

Merci à toi THEZE.

04/10/2015, 22h09
Philippe Tulliez
Bonjour,
Pour le code, c'est soit Cells(44, "D") soit Range("D" & 44)

Lorsque l'on effectue un calcul en testant FALSE OU TRUE, une autre syntaxe est possible en ne passant pas par un IF
Exemple
Code:

1 2 3 4 5 6 7 Dim R As Byte, Total As Byte With Worksheets("Feuil2") For R = 1 To 10 Total = Total + Abs(.Cells(R, 2)) Next End With MsgBox "Votre résultat est égal à " & Total & "/10"

Bonjour,

Il me semble que sur ta capture d'écran les cellules de A à D en ligne 44 sont probablement fusionnées donc, si il y a du texte erreur !
Avec le code proposé par Philippe pour totaliser car je vois que tu as des 0 (et probablement 1 ou -1). J'ai rajouté 3 lignes pour la création du dossier "TEST" au cas où il n'existerait pas :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
 
Sub DepartTest()
 
    Dim S As Shape
    Dim I As Integer
    Dim Total As Integer
 
    MsgBox "Attention, après le clic sur le bouton OK le test commence et vous avez 30 minutes pour le réaliser !"
 
    '30 minutes 1000 x 60 x 30
    Minuterie 1800000
 
    'comptage des points, ici selon ce qui est inscrit par les contrôles liés il faut adapter...
    For I = 5 To 43 Step 2
 
        Total = Total + Abs(Worksheets("Feuil2").Cells(I, 4).Value)
 
    Next I
 
    'fin du test
    MsgBox "Le test est fini, vous ne pouvez plus apporter de modification !" _
           & vbCrLf & "Votre résultat est de " & Total & "/20"
 
    'cache les cases à cocher
    For Each S In ActiveSheet.Shapes
        If S.FormControlType = xlCheckBox Then S.Visible = False
    Next S
 
    'création du dossier
    On Error Resume Next 'saute si existe déjà
    ChDir "C:\"
    MkDir "TEST"
 
    'enregistre sous... avec le nom du classeur qui normalement porte le nom du candidat
    ThisWorkbook.SaveAs "C:\TEST\" & ThisWorkbook.Name
 
    'et ferme le classeur
    ThisWorkbook.Close
 
End Sub