[AC-2010] Formulaire d'attente (sans boucle) sujet

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:

---

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:

---

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:

---

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:

---

'---------------------------------------------------------------------------------------
' 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:

---

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