Bonjour,
Confronté à une requête relativement longue, je cherchais un moyen d'afficher une progress bar , ou plus précisément un gif d'attente, qui ne bloque pas quand Access tourne à plein régime et alors que je n'ai pas de boucle qui me permette de mettre à jour une progress bar et plus voyant que
alors voici adapté d'un code que j'avais fait pour Excel.
Code : Sélectionner tout - Visualiser dans une fenêtre à part SysCmd acSysCmdInitMeter, "Exécution en cours 10mn restantes", 100
Vous aurez besoin d'un gif animé de votre choix exemple
Dans mon formulaire Access :
Dans un Module Dans ACCESS
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Private Sub LANCEMENT_Click() DoCmd.Hourglass (True) SysCmd acSysCmdInitMeter, "Exécution en cours 10mn restantes", 100 ' Définit le texte à afficher et la valeur maximale de la jauge. 'ICI ON LANCE LE GIF D'ATTENTE Call AttentExcelAutomation(Me) DoEvents Dim qdf As DAO.QueryDef Set qdf = CurrentDb.QueryDefs("MA_REQUETEl") qdf.Execute DoEvents Set qdf = Nothing SysCmd acSysCmdRemoveMeter ' Supprime la jauge d'avancement DoCmd.Hourglass (False) 'ici on referme excel xlBookAttente.Close False set xlBookAttente = nothing If xlappAttente.Workbooks.Count = 0 Then xlappAttente.Quit 'False set xlappAttente =nothing End If MsgBox "Traitement terminé" End Sub
Dans EXCEL, il faut créer un fichier
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 Public xlappAttente As Object 'Excel.Application Public xlBookAttente As Object Sub AttentExcelAutomation(MonForm As Object) Dim xlBook As Object 'Excel.Workbook Const fichierAttenteXl = "U:\ATTENTE_ACCESS.xlsm" On Error GoTo AttentExcelAutomation_Error 'Initialisations Set xlappAttente = CreateObject("Excel.Application") Set xlBook = xlappAttente.Workbooks.Open(fichierAttenteXl, 0, True) xlappAttente.Run "ShowFrmAttenteExterne", MonForm.WindowTop, MonForm.WindowLeft, MonForm.WindowWidth 'xlappAttente.Visible = True On Error GoTo 0 Exit Sub AttentExcelAutomation_Error: xlappAttente.ScreenUpdating = True xlappAttente.DisplayAlerts = True xlappAttente.Visible = True Dim choixErreur choixErreur = MsgBox("Erreur " & Err.Number & vbCr & " (" & Err.Description & ") " & vbCr & "dans la procédure [TransfertExcelAutomation] " & vbCr & "du Module [Mod_export] " & vbCr & " ligne:[" & Erl & "]", vbAbortRetryIgnore + vbCritical + vbDefaultButton1, "Erreur ") 'dans " & xlappAttente.thisworkbook.Name) Select Case choixErreur Case vbCancel Exit Sub Case vbRetry 'stop Resume Case vbIgnore Resume Next End Select End Sub
ICI U:\ATTENTE_ACCESS.xlsm
Avec un userform nommé FrmAttenteGifexterne, contenant un composant WebBrowser1 ( "Microsoft Web Browser" ) et un textbox1
DANS LE CODE du USERFORM FrmAttenteGifexterne
DAns un module Excel :
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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 '--------------------------------------------------------------------------------------- ' Module : FrmAttenteGifexterne ' Author : Oliv ' Date : 31/01/2014 ' Purpose : '--------------------------------------------------------------------------------------- Option Explicit ' Private Sub UserForm_Initialize() Dim Tmp As String ' Me.StartUpPosition = 1 '// just call it ONCE to get Tmp Directory Tmp = Environ("temp") e_strFilePathHtml = Tmp & Application.PathSeparator & "AttenteACCESS.html" '// Do the job..... '// Create Gif from Sheet data 'CreatGif '// Write html code to file WriteHtml_GifExt '// get Gif info 'fGif g_strFilePathGif '// Change Browser size & Reposition With WebBrowser1 '// you may need to change the Ratios! .Height = (gifSizeV / 1.25) .Width = (gifSizeH / 1.25) .Top = 5 .Left = (Me.InsideWidth - .Width) / 2 End With Me.Caption = ThisWorkbook.Sheets("GifAttente").Range("U1").Value Application.Visible = True 'False WebBrowser1.Navigate2 (g_strFilePathHtml) End Sub Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer) Application.Visible = True '// Clean-up On Error Resume Next Kill g_strFilePathHtml End Sub
Si vous avez une boucle dans votre traitement vous pouvez lire
Code : Sélectionner tout - Visualiser dans une fenêtre à part
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
56
57
58
59
60
61
62
63 '--------------------------------------------------------------------------------------- ' Module : basAttenteExterne ' Author : Oliv ' Date : 31/01/2014 ' Purpose : '--------------------------------------------------------------------------------------- Option Explicit Public Const gifSizeV = 425 Public Const gifSizeH = 425 Public e_strFilePathHtml As String Public Const e_strFilePathGif = "U:\mongif.gif" Sub WriteHtml_GifExt() '// Writes html code that references '// the GIF File location Dim hdl As Integer hdl = FreeFile Open g_strFilePathHtml For Output As #hdl Print #hdl, "<HTML>" Print #hdl, "<CENTER>" Print #hdl, "<BODY" Print #hdl, "bgColor = ""WHITE""" Print #hdl, "Scroll = ""NO""" Print #hdl, "LEFTMARGIN=0" Print #hdl, "TOPMARGIN=0" Print #hdl, "</BODY>" ' Print #hdl, "<a href=""http://www.xcelfiles.com "">" Print #hdl, "<IMG SRC=" & Chr$(34) & g_strFilePathGif & Chr$(34) Print #hdl, "Border = 0" Print #hdl, "Align = ABSMIDDLE" ' Print #hdl, "</a>" Print #hdl, "</CENTER>" Print #hdl, "</HTML>" Close #hdl End Sub Sub ShowFrmAttenteExterne(pTop, pLeft, pWidth) 'Run maMacro.Name & "!traitement_x" Load FrmAttente With FrmAttente .Top = pTop .Left = pLeft + (pWidth / 2) - (FrmAttente.Width / 2) End With FrmAttente.Show vbModeless End Sub Private Sub goShowAttenteExterne() 'pour tester Dim pTop, pLeft, pWidth pTop = Application.Top pLeft = Application.Left pWidth = Application.Width ShowFrmAttenteExterne pTop, pLeft, pWidth End Sub
http://arkham46.developpez.com/artic...s/formattente/
Pour les positionnements d'un UserForm, voir Définir la position d'USF à l'écran de SilkyRoad
Partager