problème d'instabillité de code

Godzestla · 09/10/2008, 13h04

Bonjour, le code suivant tourne à partir d'un userform.
Son but est de scanner les fichiers d'un répertoire et de les envoyer via email.
Lorsqu'il n'y a plus de fichier, le programme attend puis recontrole s'il y a
quelquechose à traiter.

Il y a dans le userform un controle Adobe Pdf qui affiche le fichier attaché au dernier email. Ce controle affiche en alternance un PDF d'attente.
je suspecte que c'est un problème de mémoire saturée qui pourrait être du à ce contrôle adobepdf.

Les symptomes sont : le userform devient vide et l'application ne réponds plus.

Merci de me donner vos suggestion pour debugger car je ne sais pas ou chercher.

Code du userform
La procédure qui fait le polling s'appelle Start_Polling_Click()

Code :

 
Dim BStop As Boolean
 
Private Sub UserForm_Initialize()
Me.StartUpPosition = 3
 'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
'text
Me.Status_text = "*Stopped"
'last File
Me.Last_File_Name = ""
'Scanning_name
Me.Scanning_Name = ""
 
'Fax Sent
Worksheets("Parms").Range("C20") = 0
Me.Fax_Sent = Worksheets("Parms").Range("C20")
'Fax Sent Cumulated
Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
 
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
 
Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
DoEvents
Me.Repaint
 
'Retrieve Debug_mode
Me.Debug_Sw = Worksheets("Parms").Range("C22")
 
End Sub
 
Private Sub Open_Parm_Userform_Click()
If Me.Password <> "Secret1" Then
 MsgBox "Please Specify a valid password at the right of this button and retry", vbCritical
 Else
  UserForm1.Show
  'Retrieve Debug_mode
  Me.Debug_Sw = Worksheets("Parms").Range("C22")
End If
End Sub
 
Private Sub Start_Polling_Click()
Dim Folder  As String               'Folder To browse
Dim Search_file As String           'Pattern File to search for in Folder
Dim Found_entry As String           'Found File name
Dim Fullname    As String           'FullName of Found File
Dim Rech        As String
Dim Found_keys  As Boolean
Dim Pos_REF     As Integer          'Position of first **REF in record
Dim elem        As Integer
Dim ref         As String
Dim refx        As String
Dim Mail        As String
Dim Mailcc      As String
Dim Mailbcc     As String
Dim Subject     As String
Dim Body()      As String
Dim BSize       As Integer
Dim Attachement_Folder As String    'Folder where to store attachement
Dim Attachement() As String
Dim Attachement_ext As String
Dim Attachement_brut As String
Dim Attachement_file As String
Dim P_Attachement_file As String
Dim Mxattach_name    As String
Dim Operation   As String
Dim Pdf_file    As String
Dim Ps_file     As String
Dim res         As Boolean
Dim shell_res   As Variant
Dim lng         As Integer
Dim Laligne As String, tablKeys As Variant, tablVar As Variant
Dim Where_pos As Long
Dim End_Where As Long
Dim beg_ligne As String
Dim End_ligne As String
 
Dim PhWnd     As Long
Dim P_PhWnd   As Long
 
 
 
 
'Mapping X pour attachemnt
map_mxattach
 
 
'Disable
Me.Start_Polling.Visible = False
Me.Open_Parm_Userform.Visible = False
Me.Password.Visible = False
'Enable
Me.Stop_Polling.Visible = True
'text
Me.Status_text = "Polling"
 
Me.Started_Box = "Started at " & CStr(Now())
 
BStop = False
PhWnd = 0
 
'*****************************************************************
'* Send PDF Labels Using FAX*STAR                                *
'*****************************************************************
 
'1. Retrieve Folder to browse
 
Folder = Worksheets("Parms").Range("C2")
If Right(Folder, 1) <> "\" Then
    Folder = Trim(Folder) & "\"
End If
 
'2. Retrieve Pattern File to browse
 
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
Me.Scanning_Name = Search_file
Me.Repaint
 
 
'3. Retrieve Folder where to store attachement for FAXSTAR (MXATTACH)
 
Attachement_Folder = Trim(Worksheets("Parms").Range("C4"))
If Right(Attachement_Folder, 1) <> "\" Then
    Attachement_Folder = Trim(Attachement_Folder) & "\"
End If
 
'4. Loop until button Stop used
 
Do While BStop = False
 
 DoEvents
 'text
 Me.Status_text = "Polling"
 Me.Repaint
 '5. Browse Folder until end of sources files or Button Stop used.
 
 Found_entry = Dir(Search_file, vbNormal)
 
Do While Found_entry <> "" And BStop = False   ' Start the loop.
    'Excel premier Plan
    'AppActivate "Microsoft Excel"
 
    Fullname = Folder & Found_entry
    Me.Last_File_Name = Fullname
    Me.Status_text = "Looking for **(REF)"
    Me.Repaint
    Open Fullname For Input As #1
    Found_keys = False
    Line Input #1, Laligne
    Do While Not EOF(1) And Found_keys = False
      Pos_REF = InStr(1, Laligne, "**(REF)", vbTextCompare)
      If Pos_REF > 0 Then
        Found_keys = True
       Else
       Line Input #1, Laligne
      End If
    Loop
    
    
    ref = ""
    refx = ""
    Mail = ""
    Mailcc = ""
    Mailbcc = ""
    Subject = ""
    Attachement_brut = ""
    ReDim Body(1)
    BSize = 0
    Attachement_file = ""
    Ps_file = ""
    Fax_file = ""
    PhWnd = 0
    If Found_keys Then
        Me.Status_text = "Extracting Data"
        Me.Repaint
        tablKeys = Split(Laligne, ",")
        Line Input #1, Laligne
        tablVar = Split(Laligne, ",")
 
        For elem = 0 To UBound(tablKeys)
            'Debug.Print Trim(tablKeys(elem)) & " - "; Trim(tablVar(elem))
            Select Case Trim(tablKeys(elem))
                Case "**(REF)"
                    ref = Trim(tablVar(elem))
                Case "**(REFX)"
                    refx = Trim(tablVar(elem))
                Case "**(MAIL)"
                    If Me.Debug_Sw Then
                     Mail = "Thierry.Schmitz@hydro.com"
                    Else
                     Mail = Unquote(Trim(tablVar(elem)))
                    End If
                Case "**(MAILCC)"
                    If Not Me.Debug_Sw Then
                     Mailcc = Unquote(Trim(tablVar(elem)))
                    End If
                Case "**(MAILBCC)"
                    If Not Me.Debug_Sw Then
                     Mailbcc = Unquote(Trim(tablVar(elem)))
                    End If
                Case "**(SUBJECT)"
                    Subject = Trim(tablVar(elem))
                Case "**(BODY)", "**(BODY1)", "**(BODY2)", "**(BODY3)", "**(BODY4)", "**(BODY5)", "**(BODY6)", "**(BODY7)", "**(BODY8)", "**(BODY9)", "**(BODY10)"
                    BSize = BSize + 1
                    ReDim Preserve Body(BSize)
                    Body(BSize - 1) = Unquote(Trim(tablVar(elem)))
                Case "**MXATTACHD"
                    Attachement_brut = Unquote(Trim(tablVar(elem)))
                    Attachement = Split(Attachement_brut, ".")
                    Attachement_ext = Attachement(1)
                    Fax_file = Attachement(0) & "." & "INI"
                    If Attachement_ext = "PS" Then
                      Me.Status_text = "Converting Postscript to PDF"
                      Me.Repaint
                      Ps_file = Attachement_brut
                      Pdf_file = Attachement(0) & "." & "Pdf"
                      res = Application.Run("GSAPI_VBA.XLS!Convertfile", Attachement_brut, Pdf_file)
                      Attachement_brut = Pdf_file
                    End If
                    Attachement_file = Attachement_brut
                    'Move Attachement to Attachement_Folder
                    Me.Status_text = "Moving Attachement for FAX*STAR"
                    Me.Repaint
                    Attachement = Split(Attachement_brut, "\")
                    Destination = Attachement_Folder & Attachement(UBound(Attachement))
                    Mxattach_name = Attachement(UBound(Attachement))
                    On Error Resume Next
                    FileCopy Attachement_brut, Destination
                    If Err.Number = 76 Then
                      MsgBox (Destination & " Path/drive not available. Process Halted")
                      Close #1
                      Exit Sub
                    End If
                    'Close View Previous Attachment and remove it
                    If P_Attachement_file <> "" Then
                       Me.Status_text = "Removing " & P_Attachement_file & " File"
                       Me.Repaint
                       If P_PhWnd <> 0 Then
                         'Close default Viewer if openedt
                         'Call CloseProgram(P_PhWnd)
                         'DoEvents
                       End If
                       Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
                       DoEvents
                       Me.Repaint
                       On Error Resume Next
                       If Not Me.Debug_Sw Then
                         Kill P_Attachement_file
                       End If
                       DoEvents
                    End If
                    P_Attachement_file = ""
                    P_PhWnd = 0
                    
                    Application.Wait (Now + TimeValue("0:00:02"))
                    '*************************************
                    'Show Attachement With Default Viewer
                    'PhWnd = OpenProgram(Attachement_file, 0)
                    'Excel premier Plan
                    'AppActivate "Microsoft Excel"
                    Me.AcroPDF1.LoadFile (Attachement_file)
                    DoEvents
                    Me.Repaint
                    
            End Select
        Next
                    
        'Formattage Fichier sortie
        If Mail <> "" And Attachement_brut <> "" Then
           Me.Status_text = "Formatting Fax File"
           Me.Repaint
           Open Fax_file For Output As #2
           Laligne = "**(REF) " & ref
           Print #2, Laligne
           If refx <> "" Then
              Laligne = "**(REFX) " & refx
              Print #2, Laligne
           End If
           Laligne = "**(MAIL) " & Mail
           Print #2, Laligne
           If Mailcc <> "" Then
              Laligne = "**(MAILCC) " & Mailcc
              Print #2, Laligne
           End If
           If Mailbcc <> "" Then
              Laligne = "**(MAILBCC) " & Mailbcc
              Print #2, Laligne
           End If
           If Subject <> "" Then
              Laligne = "**(SUBJECT) " & Subject
              Print #2, Laligne
           End If
           For elem = 1 To BSize
              Laligne = Trim(Body(elem - 1))
              Print #2, Laligne
           Next
           Print #2, " "
           Laligne = "**MXATTACHD " & Mxattach_name
           Print #2, Laligne
           Print #2, " "
           Close #2
           Me.Status_text = "Printing to Fax*Star"
           Me.Repaint
           Operation = "lpr -S 149.209.142.14 -P faxstar " & Fax_file
           shell_res = Shell(Operation, vbNormalFocus)
           DoEvents
           Worksheets("Parms").Range("C20") = Worksheets("Parms").Range("C20") + 1
           Me.Fax_Sent = Worksheets("Parms").Range("C20")
           Worksheets("Parms").Range("C21") = Worksheets("Parms").Range("C21") + 1
           Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
          Else
            Close #2
        End If
    End If
    Close #1
    Me.Status_text = "Removing " & Found_entry & " File"
    Me.Repaint
    'If Not Me.Debug_Sw Then
       On Error Resume Next
       Kill Fullname
    'End If
 
    If Ps_file <> "" Then
        Me.Status_text = "Removing " & Ps_file & " File"
        Me.Repaint
        If Not Me.Debug_Sw Then
          On Error Resume Next
          Kill Ps_file
        End If
    End If
 
   
    Me.Status_text = "Pause 2 sec"
    Application.Wait (Now + TimeValue("0:00:02"))
    Me.Repaint
    
    If Fax_file <> "" Then
        Me.Status_text = "Removing " & Fax_file & " File"
        Me.Repaint
        On Error Resume Next
        Kill Fax_file
    End If
    
    'Backup ID Task View Attachement & Attachement name
    P_PhWnd = PhWnd
    P_Attachement_file = Attachement_file
    Found_entry = Dir    ' Get next entry.
   Loop
 
   If BStop = False Then
     Me.Status_text = "Waiting 5 sec before Polling"
     Application.Wait (Now + TimeValue("0:00:05"))
     Me.Repaint
   End If
   DoEvents
 Loop
 
'Close View Last Attachment and remove it
If Attachement_file <> "" Then
   Me.Status_text = "Removing " & Attachement_file & " File"
   Me.Repaint
   If PhWnd <> 0 Then
     'Close default Viewer if openedt
     'Call CloseProgram(PhWnd)
     'DoEvents
   End If
   Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
   DoEvents
   Me.Repaint
   If Not Me.Debug_Sw Then
      On Error Resume Next
      Kill Attachement_file
         DoEvents
   End If
 
End If
Attachement_file = ""
PhWnd = 0
 
End Sub
 
Private Sub Stop_Polling_Click()
'Xl_plein_ecran
 
'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
Me.Password.Visible = True
'text
Me.Status_text = "*Stopped"
 
BStop = True
 
Me.Started_Box = "Stopped at " & CStr(Now())
End Sub

zazaraignée · 09/10/2008, 16h25

T'as essayé de mettre un (ou quelques) points d'arrêt dans ton code (tu cliques dans la marge) et de démarrer en mode Debug (F8 à partir du point d'arrêt)?

Godzestla · 09/10/2008, 16h34

Citation:

Envoyé par zazaraignée

T'as essayé de mettre un (ou quelques) points d'arrêt dans ton code (tu cliques dans la marge) et de démarrer en mode Debug (F8 à partir du point d'arrêt)?

Salut Zazaraignée,

c'est très difficile à réaliser car ce code fonctionne tout seul , vu qu'il sert de serveur d'envoi d'email.

Il fonctionne jusqu'à un moment n et puis crac.

Si je suis en debug, aucun soucis apparent.
Je crois même avoir détecté qu'il se plante à un moment ou il n'a plus rien à traiter, comme si la boucle d'attente seule avec me.repaint lui posait des problèmes.

zazaraignée · 10/10/2008, 15h47

Je n'ai pas d'idée précise pour t'aider en ce moment. Mais après un survol rapide de ton code, je constate que ta procédure Start_Polling_Click est plutôt longue et contient plusieurs structures conditionnelles et itératives. Je crois qu'il vaudrait mieux séparer tout ça en plusieurs procédures, et si nécessaire, passer des valeurs en arguments, quitte à devoir les mettre explicitement ByRef ou ByVal selon que tu veuilles ou non que la valeur passée soit modifiée par la procédure ou utilisée telle quelle sans qu'elle soit modifiée à la fin de la procédure en question.

Fais toi d'abord une copie du code original, des fois que les modifications s'avèreraient catastrophiques. Une fois les modifications faites, il te sera plus facile de voir ce qui cloche.

Pour les Me.Repaint, j'ai vu qu'il y en avait à plusieurs endroits. Serait-il possible de ne rafraichir que le contrôle concerné sur le moment plutôt que tout le UserForm? Enfin... c'est comme je dis, je n'ai regardé ton code que sommairement... n'ayant pas toutes les procédures ni de pdf exemple sous la main pour pouvoir tester.

Godzestla · 13/10/2008, 11h55

Merci Zazaraignée,

j'ai fait comme tu suggérais, enfin je pense.

J'ai maintenant le code du userform plus court avec la boucle qui appelle une fonction de traitement située dans un module en passant tous les paramètres nécessaire.
J'ai réduit au maximum les Me.Repaint.

J'ai également éliminé le contrôle AdobePdf en qui je n'avais qu'une confiance limitée (car très peu de documentation disponible sur le net) et je l'ai remplacé par un appel via ShellExecuteEx à Adobe Viewer pour afficher mon PDF ce qui me permet de fermer cette fenêtre automatiquement à la prochaine itération.

Le nouveau code est en test depuis peu et je ne sais pas encore dire s'il est plus stable, mais si l'appli tourne encore demain matin, cela sera bon signe.

Si c'est le cas, demain ce sera

Pour info voici le nouveau code.

Userform

Code :

 
Dim BStop As Boolean
 
 
 
Private Sub UserForm_Initialize()
Me.StartUpPosition = 3
 'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
'text
Me.Status_text = "*Stopped"
'last File
Me.Last_File_Name = ""
'Scanning_name
Me.Scanning_Name = ""
 
'Fax Sent
Worksheets("Parms").Range("C20") = 0
Me.Fax_Sent = Worksheets("Parms").Range("C20")
'Fax Sent Cumulated
Me.Fax_Sent_Cumulated = Worksheets("Parms").Range("C21")
 
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
 
'09/10 Me.AcroPDF1.LoadFile ("G:\Emballage\Format\Hydro.pdf")
DoEvents
Me.Repaint
 
'Retrieve Debug_mode
Me.Debug_Sw = Worksheets("Parms").Range("C22")
 
End Sub
 
Private Sub Open_Parm_Userform_Click()
If Me.Password <> "Secret1" Then
 MsgBox "Please Specify a valid password at the right of this button and retry", vbCritical
 Else
  UserForm1.Show
  'Retrieve Debug_mode
  Me.Debug_Sw = Worksheets("Parms").Range("C22")
End If
End Sub
 
Private Sub Start_Polling_Click()
Dim Folder  As String               'Folder To browse
Dim Search_file As String           'Pattern File to search for in Folder
Dim Found_Entry As String           'Found File name
Dim Fullname    As String           'FullName of Found File
Dim Rech        As String
Dim Found_keys  As Boolean
Dim Pos_REF     As Integer          'Position of first **REF in record
Dim elem        As Integer
Dim ref         As String
Dim refx        As String
Dim Mail        As String
Dim Mailcc      As String
Dim Mailbcc     As String
Dim Subject     As String
Dim Body()      As String
Dim BSize       As Integer
Dim Attachement_folder As String    'Folder where to store attachement
Dim Attachement() As String
Dim Attachement_ext As String
Dim Attachement_brut As String
Dim O_Attachement_file As String
Dim Mxattach_name    As String
Dim Operation   As String
Dim Pdf_file    As String
Dim Ps_file     As String
Dim res         As Boolean
Dim shell_res   As Variant
Dim lng         As Integer
Dim Laligne As String, tablKeys As Variant, tablVar As Variant
Dim Where_pos As Long
Dim End_Where As Long
Dim beg_ligne As String
Dim End_ligne As String
 
 
Dim Sent_Status As Boolean
 
Dim P_Phwnd   As Long
 
 
 
 
 
'Mapping X pour attachement
map_mxattach
 
 
'Disable
Me.Start_Polling.Visible = False
Me.Open_Parm_Userform.Visible = False
Me.Password.Visible = False
'Enable
Me.Stop_Polling.Visible = True
'text
Me.Status_text = "Polling"
 
Me.Started_Box = "Started at " & CStr(Now())
 
BStop = False
 
'*****************************************************************
'* Send PDF Labels Using FAX*STAR                                *
'*****************************************************************
 
'1. Retrieve Folder to browse
 
Folder = Worksheets("Parms").Range("C2")
If Right(Folder, 1) <> "\" Then
    Folder = Trim(Folder) & "\"
End If
 
'2. Retrieve Pattern File to browse
 
Search_file = Folder & Trim(Worksheets("Parms").Range("C3"))
Me.Scanning_Name = Search_file
Me.Repaint
 
 
'3. Retrieve Folder where to store attachement for FAXSTAR (MXATTACH)
 
Attachement_folder = Trim(Worksheets("Parms").Range("C4"))
If Right(Attachement_folder, 1) <> "\" Then
    Attachement_folder = Trim(Attachement_folder) & "\"
End If
 
'4. Loop until button Stop used
 
Do While BStop = False
 
 DoEvents
 'text
 Me.Status_text = "Polling"
 Me.Repaint
 '5. Browse Folder until end of sources files or Button Stop used.
 
 Found_Entry = Dir(Search_file, vbNormal)
 
 
  Do While Found_Entry <> "" And BStop = False   ' Start the loop.
 
     
    Sent_Status = Send_1_File(Folder, Found_Entry, Attachement_folder, Me.Debug_Sw, P_Phwnd, O_Attachement_file)
    If Not Sent_Status Then Exit Sub
    
    Me.Last_File_Name = Folder & Trim(Found_Entry)
    
    Worksheets("Parms").Range("C20") = Worksheets("Parms").Range("C20") + 1
    Me.Fax_Sent = Worksheets("Parms").Range("C20")
    Worksheets("Parms").Range("C21") = Worksheets("Parms").Range("C21") + 1
 
 
 
    Found_Entry = Dir    ' Get next entry.
   Loop
 
   If BStop = False Then
     Me.Status_text = "Waiting 10 sec before Polling"
     Application.Wait (Now + TimeValue("0:00:10"))
     Me.Repaint
   End If
   DoEvents
 Loop
 
'Close View Last Attachment and remove it
If O_Attachement_file <> "" Then
   Me.Status_text = "Removing " & O_Attachement_file & " File"
   Me.Repaint
   If P_Phwnd <> 0 Then
     'Close default Viewer if openedt
     Call CloseProgram(P_Phwnd)
     DoEvents
   End If
   DoEvents
   Me.Repaint
   If Not Me.Debug_Sw Then
      On Error Resume Next
      Kill O_Attachement_file
      DoEvents
   End If
 
End If
O_Attachement_file = ""
PhWnd = 0
 
End Sub
 
Private Sub Stop_Polling_Click()
'Xl_plein_ecran
 
'Disable
Me.Stop_Polling.Visible = False
'Enable
Me.Start_Polling.Visible = True
Me.Open_Parm_Userform.Visible = True
Me.Password.Visible = True
'text
Me.Status_text = "*Stopped"
 
BStop = True
 
Me.Started_Box = "Stopped at " & CStr(Now())
End Sub

Module

Code :

 
Option Explicit
 
'Flags ShellExecuteEx
Private Const SEE_MASK_NOCLOSEPROCESS = &H40
Private Const SEE_MASK_FLAG_NO_UI = &H400
 
'Constantes ERREUR ShellExecuteEx
Private Const SE_ERR_FNF As Byte = 2
Private Const SE_ERR_PNF As Byte = 3
Private Const SE_ERR_ACCESSDENIED As Byte = 5
Private Const SE_ERR_OOM As Byte = 8
Private Const SE_ERR_SHARE As Byte = 26
Private Const SE_ERR_ASSOCINCOMPLETE As Byte = 27
Private Const SE_ERR_DDETIMEOUT As Byte = 28
Private Const SE_ERR_DDEFAIL As Byte = 29
Private Const SE_ERR_DDEBUSY As Byte = 30
Private Const SE_ERR_NOASSOC As Byte = 31
Private Const SE_ERR_DLLNOTFOUND As Byte = 32
 
'Constantes AFFICHAGE ShellExecuteEx
Private Const SW_SHOWNORMAL = 1
Private Const SW_SHOW = 5
Private Const SW_SHOWDEFAULT = 10
 
Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hWnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
 
'OpenProgram
Private Declare Function ShellExecuteEx Lib "shell32.dll" _
(SEI As SHELLEXECUTEINFO) As Long
 
 
'CloseProgram
Private Declare Function CloseHandle Lib "kernel32" _
(ByVal hObject As Long) As Long
 
Private Declare Function TerminateProcess Lib "kernel32" _
(ByVal hProcess As Long, ByVal uExitCode As Long) As Long
 
Private Declare Sub Sleep Lib "kernel32" _
(ByVal dwMilliseconds As Long)
 
Public Const WM_CLOSE = &H10
Const GW_HWNDNEXT = 2
Dim mWnd                    As Long
Dim PhWnd                   As Long
Dim P_Attachement_file      As String
Private AppCible            As String
 
 
' ***********************************************************
' *
' * Lance le programme par défaut associé à un fichier (en fonction de son
' * extension ) et retourne le hWnd de la fênetre du programme lançé.
' *
' ***********************************************************
 
Public Function OpenProgram(ByRef Filename As String, ByRef OwnerhWnd As Long) As Long
    Dim SEI As SHELLEXECUTEINFO
    
    On Error GoTo ErrorHandler
    
    'Vérifie si le fichier à lancer est un exécutable (.exe)
    If GetExtension(Filename) = "exe" Then
        If vbNo = MsgBox("ATTENTION, êtes-vous sûr de vouloir lancer ce programme exécutable ?", vbExclamation + vbYesNo) _
        Then
            OpenProgram = 0
            Exit Function
        End If
    End If
 
    With SEI
        .cbSize = Len(SEI)
        .fMask = SEE_MASK_NOCLOSEPROCESS Or SEE_MASK_FLAG_NO_UI
        .hWnd = OwnerhWnd
        .lpVerb = "open"
        .lpFile = Filename
        .lpParameters = vbNullChar
        .lpDirectory = vbNullChar
        .nShow = SW_SHOW
        .hInstApp = OwnerhWnd
    End With
    
    OpenProgram = ShellExecuteEx(SEI)
    
    If SEI.hInstApp <= 32 Then
    'Erreurs
        OpenProgram = 0
        
        Select Case SEI.hInstApp
            Case SE_ERR_FNF
                OpenProgram = SEI.hProcess
            Case SE_ERR_PNF
                MsgBox "Le chemin du fichier à ouvrir est incorrect.", vbExclamation
            Case SE_ERR_ACCESSDENIED
                MsgBox "Accès au fichier refusé.", vbExclamation
            Case SE_ERR_OOM
                MsgBox "Mémoire insuffisante.", vbExclamation
            Case SE_ERR_DLLNOTFOUND
                MsgBox "Dynamic-link library non trouvé.", vbExclamation
            Case SE_ERR_SHARE
                MsgBox "Le fichier est déjà ouvert.", vbExclamation
            Case SE_ERR_ASSOCINCOMPLETE
                MsgBox "Information d'association du fichier incomplète.", vbExclamation
            Case SE_ERR_DDETIMEOUT
                MsgBox "Opération DDE dépassée.", vbExclamation
            Case SE_ERR_DDEFAIL
                MsgBox "Opération DDE echouée.", vbExclamation
            Case SE_ERR_DDEBUSY
                MsgBox "Opération DDE occupée.", vbExclamation
            Case SE_ERR_NOASSOC
                'Ouvrir avec...
                Call Shell("rundll32.exe shell32.dll,OpenAs_RunDLL " + Filename, vbNormalFocus)
        End Select
    Else
        'Retourne le hWnd du programme lançé par ShellExecuteEx
        OpenProgram = SEI.hProcess
    End If
    
    Exit Function
ErrorHandler:
    OpenProgram = 0
End Function
 
' ***********************************************************
' *
' * Ferme un programme à partir du hWnd de sa fenêtre.
' *
' ***********************************************************
 
Public Function CloseProgram(hWnd As Long) As Boolean
    Dim lExitCode As Long
    
    If hWnd = 0 Then
        Exit Function
    End If
    
    On Error Resume Next
    CloseProgram = CBool(TerminateProcess(hWnd, lExitCode))
    'On Error Resume Next
    CloseHandle hWnd
    DoEvents
    Sleep (100)
    
End Function
 
Public Function GetExtension(Filename As String) As String
Dim tablo() As String
tablo = Split(Filename, ".")
GetExtension = tablo(UBound(tablo))
End Function
 
Function Unquote(MyString As Variant) As Variant
Dim lng As Integer
lng = Len(Trim(MyString))
If lng > 2 Then
    Unquote = Mid(Trim(MyString), 2, lng - 2)
  Else
    Unquote = " "
End If
 
End Function
Sub Z_hide_Show_Parm()
Dim status As Boolean
If Wor

09/10/2008, 16h25	#2 (permalink)
zazaraignée Modératrice Date d'inscription: février 2004 Localisation: Rimouski Messages: 3 067	T'as essayé de mettre un (ou quelques) points d'arrêt dans ton code (tu cliques dans la marge) et de démarrer en mode Debug (F8 à partir du point d'arrêt)? __________________ Pour les nouveaux : Mode d'emploi et aide aux nouveaux et impérativement les règles du forum. Histoire de garder une ambiance amicale. Noubliez pas les balises de Code pour vos listings : bouton # de l'éditeur. Et n'oubliez pas non plus de bouton Je ne réponds pas aux questions posées par MP.

10/10/2008, 15h47	#4 (permalink)
zazaraignée Modératrice Date d'inscription: février 2004 Localisation: Rimouski Messages: 3 067	Je n'ai pas d'idée précise pour t'aider en ce moment. Mais après un survol rapide de ton code, je constate que ta procédure Start_Polling_Click est plutôt longue et contient plusieurs structures conditionnelles et itératives. Je crois qu'il vaudrait mieux séparer tout ça en plusieurs procédures, et si nécessaire, passer des valeurs en arguments, quitte à devoir les mettre explicitement ByRef ou ByVal selon que tu veuilles ou non que la valeur passée soit modifiée par la procédure ou utilisée telle quelle sans qu'elle soit modifiée à la fin de la procédure en question. Fais toi d'abord une copie du code original, des fois que les modifications s'avèreraient catastrophiques. Une fois les modifications faites, il te sera plus facile de voir ce qui cloche. Pour les Me.Repaint, j'ai vu qu'il y en avait à plusieurs endroits. Serait-il possible de ne rafraichir que le contrôle concerné sur le moment plutôt que tout le UserForm? Enfin... c'est comme je dis, je n'ai regardé ton code que sommairement... n'ayant pas toutes les procédures ni de pdf exemple sous la main pour pouvoir tester. __________________ Pour les nouveaux : Mode d'emploi et aide aux nouveaux et impérativement les règles du forum. Histoire de garder une ambiance amicale. Noubliez pas les balises de Code pour vos listings : bouton # de l'éditeur. Et n'oubliez pas non plus de bouton Je ne réponds pas aux questions posées par MP.