Forms: Afficher une boîte de dialogue pour un laps de temps déterminé	Author(s) Michael Bedward

Afficher une boîte de dialogue pour un laps de temps déterminé.

     La boîte de dialogue  MsgBox ne permet pas de se fermer automatiquement après un certain temps. On peut cependant fermer cette boîte de dialogue en utilisant un Timer, par exemple.

    Une autre alternative et de construire un formulaire en mode d'exécution, utilisant CreateForm et CreateControl.  Cette fonction utilise ces méthodes pour créer un formulaire et le refermer après un intervalle de temps prédéterminé.

'************* Code Start **************
' Afficher un formulaire en popup pour un intervalle de temps
'
' This code was written by Michael Bedward
' mbedward@ozemail.com.au
' March 31, 1999.
'
' Il vous est permis de distribuer ce code comme il vous plaît
' mais il serait bien que vous attribuiez le crédit à l'auteur initial
' en laissant cette note intacte. Toutes améliorations seront 
' grandement appréciées.
'
' Modifications:
'   April 12, 1999
'   Added modifications suggested by Mark West (mrwest@engin.umich.edu):
'   code to auto-size form according to label size;
'   optional args to set font name and size;
'   code to delete form object.
'
'   April 16,1999
'   Added error handler as suggested by Dev Ashish (dash10@hotmail.com).
'
Sub mxbPopupMessage(ByVal message As String, _
                    Optional ByVal title As Variant, _
                    Optional ByVal duration As Single, _
                    Optional strFontName As String, _
                    Optional intFontSize As Integer)
    Dim f As Form
    Dim lbl As Label
    Dim dblWidth As Double
    Dim myName As String
    Dim savedForm As Boolean
    
    ' utilisé pour traitement d'erreurs
    '
    savedForm = False
    
    ' évite le peinturage de l'écran pour le temps
    ' où le formulaire est recréé
    '
    On Error GoTo ErrorHandler
    Application.Echo False
    
    ' un formulaire blanc
    '
    Set f = CreateForm
    myName = f.Name
    f.RecordSelectors = False
    f.NavigationButtons = False
    f.DividingLines = False
    f.ScrollBars = 0  ' none
    f.PopUp = True
    f.BorderStyle = acDialog
    f.Modal = True
    f.ControlBox = False
    f.AutoResize = True
    f.AutoCenter = True
    
    ' apposer le titre
    '
    If IsMissing(title) Then
        f.Caption = "Info"
    Else
        f.Caption = title
    End If
    
    ' une étiquette pour le message
    '
    Set lbl = CreateControl(f.Name, acLabel)
    lbl.Caption = message
    lbl.BackColor = 0 ' transparent
    lbl.ForeColor = 0
    lbl.Left = 100
    lbl.Top = 100
    If strFontName <> "" Then lbl.FontName = strFontName
    If intFontSize > 0 Then lbl.FontSize = intFontSize
    lbl.SizeToFit
    dblWidth = lbl.Width + 200
    f.Width = dblWidth - 200
    f.Section(acDetail).Height = lbl.Height + 200
    
    ' afficher (tout d'abord, fermer et sauvegarder de sorte qu'en réouverture,
    ' il se centre de lui-même)
    '
    DoCmd.Close acForm, myName, acSaveYes
    savedForm = True
    DoCmd.OpenForm myName
    DoCmd.MoveSize , , dblWidth
    DoCmd.RepaintObject acForm, myName

    ' permettre à l'écran de se repeindre.
    '
    Application.Echo True

    ' afficher pour le temps spécifier
    '
    If duration <= 0 Then duration = 2
    Dim startTime As Single
    startTime = Timer
    While Timer < startTime + duration
    Wend
    
    ' ferme et efface le formulaire
    '
    DoCmd.Close acForm, myName, acSaveNo
    DoCmd.DeleteObject acForm, myName
    Exit Sub
    
ErrorHandler:
    Application.Echo True
    Dim i As Integer
    For Each f In Forms
      If f.Name = myName Then
        DoCmd.Close acForm, myName, acSaveNo
        Exit For
      End If
    Next f
    If savedForm Then
      DoCmd.DeleteObject acForm, myName
    End If
               
End Sub
'************* Code End **************