MsgBox toujours affiché pour YOda Résolu

Question

Bonjour,Yoda ,

Je reviens pour te demander comment faire pour que la boite msgBox " Enregistrement Classeur en cours" reste affichée pendant l'Enregistrement et disparaisse à la fin, laissant la macro continuer.

Merci.

Configuration: Windows XP / Internet Explorer 7.0

Yoda · Answer

Bonjour,

Avec une boite MsgBox ça ne marche pas.
Tu dois faire un formulaire UserForm, et rajouter une procédure spéciale.

Dans la fenêtre VBAProject, click droit, Insertion , Userform.

Tu dimensionne ton UserForm et tu lui ajoutes un Label au milieu, (dans la boite à outils tu click sur le A , ensuite tu click deux points sur le UserForm).

Tu modifies le texte par défaut et inscris ton propre message. tu redimenssionnes pour voir tout le texte.

Si tu arrives à faire déjà ça, je te dirais ce qu'il fau faire ensuite.

Tiens moi au courant.

acha · Answer

Yoda, je viens de faire un UserForm avec le texte 
ENREGISTREMENT DU CLASSEUR

que faire maintenant?

acha · Answer

Bonjour Yoda,
L'essai de la macro complète donne:Impossible de trouver la macro
"DépMimi.Xls!CopieClasseurMimi"

Lorsque je supprime les lignes Private,Public, hProcess à End sub
la macro fontionne en affichant UserForm1"ENREGITREMENT CLASSEUR EN COURS" ainsi que MsgBox "ENREGISTREMENT CLASSEUR EN COURS" et bouton OK
un clic sur OK Fait disparaitre MsgBox tandis que UserForm1 reste affiché pendant que le classeur s'enregistre pour disparaitre avec" Sauvegarde effectuée avec succès"
Après contôle sur H: la copy est bien effectuée.

acha · Answer

Yoda, désolé j'ai supprimé ' mis au début des lignes Private à End sub et toujours:impossible de trouver la macro DépMimi.xls!CopieClasseurXPMimi

acha · Answer

Yoda, voici la macro:

'
Sub CopieClasseurXPMimi()


Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400

Public Sub ShellWait(ByVal JobToDo As String)
Dim hProcess As Long, RetVal As Long

    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(JobToDo, vbMinimizedNoFocus))
    Do
        GetExitCodeProcess hProcess, RetVal
        DoEvents
        Sleep 100
    Loop While RetVal = STILL_ACTIVE
End Sub


'enregistre le classeur
DEBUT:
    
 Rep = MsgBox("Sauvegarde du Fichier" & vbCrLf _
              & "Veuillez vérifier que le disque H: est branché", vbOKCancel + vbExclamation)
If Rep = vbOK Then
    On Error GoTo ERR1
    
'  test si le lecteur H:\ est prêt
ChDir ("H:\")
     
On Error GoTo 0

'afficher message
    UserForm1.Show (0)
    
            MsgBox "ENREGISTREMENT CLASSEUR EN COURS"


            'MsgBox Format(Now() - vChrono, "h:mm:ss"), vbOK, "PATIENTEZ"
            Application.EnableEvents = False
            ActiveWorkbook.Save
            Application.EnableEvents = True

'sauve sur disque extérieur H


'Nom des fichiers origine et destination
Orig = "D:\DépMalAs\DépMimi.xls"
Dest = "H:\DépMimi.xls" & " " & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh\Hmm")

'ne pas mofifier ces 2 lignes
commandeDos = "cmd /c copy " & Chr(34) & Orig & Chr(34) & " " & Chr(34) & Dest & Chr(34)
ShellWait (commandeDos)

'cacher message
UserForm1.Hide

'On Error GoTo 0

MatailleD = FileLen("D:\DépMalAs\DépMimi.xls")
ChDir ("H:\")
MatailleH = FileLen("\DépMimi.xls")

MsgBox "Sauvegarde effectuée avec succès" & " " & MatailleD & " " & "octets" _
                                              & " " & MatailleH
    
   ' MsgBox "taille fichier sur disque H" = MatailleH
    
Else
    MsgBox " Sauvegarde annulée"
End If

Call Auto_Close
ActiveSheet.Protect
Application.Quit
Exit Sub

ERR1:
MsgBox "Erreur: le lecteur H:\ n'est pas prêt", vbCritical
Resume DEBUT


End Sub

acha · Answer

Bonjour Yoda,
L'essai de cette macro donne: Impossible de trouver la macro DépMimi.xls!Copie ClasseurXPMimi et
en quittant
Seul des commentaires peuvent apparaître après End Sub ou EndFonction ou End Property
 En dessous le copier/coller de la Macro en place, j'espère ne pas y avoir
fait d'erreurs

A+

Sub CopieClasseurXPMimi()


'Déclaration de variables globales, ne pas modifier
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Long, lpExitCode As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Private Const STILL_ACTIVE = &H103
Private Const PROCESS_QUERY_INFORMATION = &H400

'Procédure ShellWait, ne pas modifier
Public Sub ShellWait(ByVal JobToDo As String)
Dim hProcess As Long, RetVal As Long

    hProcess = OpenProcess(PROCESS_QUERY_INFORMATION, False, Shell(JobToDo, vbMinimizedNoFocus))
    Do
        GetExitCodeProcess hProcess, RetVal
       DoEvents
        Sleep 100
    Loop While RetVal = STILL_ACTIVE


'Ta procédure d'enregistrement


'enregistre le classeur
Application.StatusBar = Space(15) & "ENREGISTREMENT CLASSEUR EN COURS"
Application.EnableEvents = False
'ActiveWorbook.Save
Application.EnableEvents = True

'sauve sur disque extérieur H
DEBUT:
Rep = MsgBox("Sauvegarde du Fichier" & vbCrLf _
             & "Veuillez monter le disque sur le lecteur H:", vbOKCancel + vbExclamation)
If Rep = vbOK Then
   On Error GoTo ERR1
   'test si le lecteur H:\ est prêt
   ChDir ("H:\")
   On Error GoTo 0

    'afficher ton message
    UserForm1.Show (0)

   'Nom des fichiers origine et destination
   Orig = "D:\DépMalAs\DépMimi.xls"
   Dest = "H:\DépMimi.xls_" & Format(Date, "yyyy-mm-dd") & "_" & Format(Time, "hh\Hmm")
   
   'ne pas modifier ces 2 lignes
   commandeDOS = "cmd /c copy " & Chr(34) & Orig & Chr(34) & " " & Chr(34) & Dest & Chr(34)
   ShellWait (commandeDOS)
    
   'chacher ton message
   UserForm1.Hide
   MsgBox "Sauvegarde effectuée avec succès"
Else
    MsgBox "Sauvegarde annulée"
End If

Call Auto_Close
ActiveSheet.Protect
Application.Quit
Exit Sub

ERR1:
MsgBox "Erreur: le lecteur H:\ n'est pas prêt", vbCritical
Resume DEBUT

End Sub

acha · Answer

Bonjour Yoda,

La macro copier/coller foctionne à condition de supprimer ActiveWorbook.save pourquoi?
Inconvénient, la fermeture demande "Voulez-vous enregistrer le classeur OUI NON"

la macro ci dessous fonctionne parfaitement et enregitre le classeur au début.
 


Sub CopieClasseurXPMimi()

'enregistre le classeur
DEBUT:
    
 Rep = MsgBox("Sauvegarde du Fichier" & vbCrLf _
              & "Veuillez vérifier que le disque H: est branché", vbOKCancel + vbExclamation)
If Rep = vbOK Then
    On Error GoTo ERR1

'  test si le lecteur H:\ est prêt
ChDir ("H:\")
     
On Error GoTo 0

'afficher message
    UserForm1.Show (0)
    
            MsgBox "ENREGISTREMENT CLASSEUR EN COURS"


            'MsgBox Format(Now() - vChrono, "h:mm:ss"), vbOK, "PATIENTEZ"
            Application.EnableEvents = False
            ActiveWorkbook.Save
            Application.EnableEvents = True

'sauve sur disque extérieur H


'Nom des fichiers origine et destination
Orig = "D:\DépMalAs\DépMimi.xls"
Dest = "H:\DépMimi.xls" & " " & Format(Date, "dd-mm-yyyy") & "_" & Format(Time, "hh\Hmm")

'ne pas mofifier ces 2 lignes
commandeDOS = "cmd /c copy " & Chr(34) & Orig & Chr(34) & " " & Chr(34) & Dest & Chr(34)
Shell (commandeDOS)

'cacher message
UserForm1.Hide

On Error GoTo 0

MatailleD = FileLen("D:\DépMalAs\DépMimi.xls")
ChDir ("H:\")
MatailleH = FileLen("\DépMimi.xls")

MsgBox "Sauvegarde effectuée avec succès" & " " & MatailleD & " " & "octets" _
                                              & " " & MatailleH
    
     
Else
    MsgBox " Sauvegarde annulée"
End If

Call Auto_Close
ActiveSheet.Protect
Application.Quit
Exit Sub

ERR1:
MsgBox "Erreur: le lecteur H:\ n'est pas prêt", vbCritical
Resume DEBUT


End Sub

MsgBox toujours affiché pour YOda

7 réponses

Discussions similaires

Newsletters