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
Code : Sélectionner tout - Visualiser dans une fenêtre à part
 SysCmd acSysCmdInitMeter, "Exécution en cours 10mn restantes", 100
alors voici adapté d'un code que j'avais fait pour Excel.
Vous aurez besoin d'un gif animé de votre choix exemple


Dans mon formulaire 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 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
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
Dans EXCEL, il faut créer un fichier
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
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
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
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
Si vous avez une boucle dans votre traitement vous pouvez lire
http://arkham46.developpez.com/artic...s/formattente/

Pour les positionnements d'un UserForm, voir Définir la position d'USF à l'écran de SilkyRoad