Procédure simultanée VBA Excel

Version imprimable

05/07/2013, 16h50
daveb123

Procédure simultanée VBA Excel

Bonjour à vous tous,

Ma question est simple, est-il possible de lancer deux procédure qui doivent s'éxecutée simultanéement en VBA excel?

Exemple, je clique sur un bouton: D'une part j'ai mon horloge (que je codé) qui s'incrémente à chaque seconde dans une cellule quelconque et d'autre part un code qui éxecute un programme plus complexe ex. boucles et opération mathématiques etc.

Merci pour vos réponses, j'ai fouillé sur le forum mais je n'ai pas trouvé!

Bonjour,

Il est possible de lancer une tâche asynchrone en utilisant l'API Windows CreateThread.
Par exemple:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Option Explicit
 
Private Declare Function CreateThread Lib "kernel32" (lpThreadAttributes As Any, ByVal dwStackSize As Long, ByVal lpStartAddress As Long, lpParameter As Any, ByVal dwCreationFlags As Long, lpThreadID As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
Private Sub TacheAsynchrone()
    MsgBox "Ca marche !!!"
End Sub
 
Public Sub Lanceur()
    Dim hThread As Long, hThreadID As Long
    hThread = CreateThread(ByVal 0&, ByVal 0&, AddressOf TacheAsynchrone, ByVal 0&, ByVal 0&, hThreadID)
    MsgBox "Le processus asynchrone a été créé."
    CloseHandle hThread
End Sub

Le code situé après l'instruction CreateThread sera exécuté "parallèlement" au code de la Sub TacheAsynchrone.

Cdt

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
 
Private Sub CommandButton3_Click()
 
Call Demarre_Horloge
 
 Worksheets("feuil1").Protect Password:="", UserInterfaceOnly:=True
 
 Cells(1, 4).Value = Cells(1, 1).Value
 
For i = 1 To 10000
 Cells(1, 2).Value = i
 Cells(1, 3).Value = Cells(1, 1).Value
 DoEvents
Next
Cells(1, 5).Value = Cells(1, 1).Value
 
Call Arreter_Horloge
 
Worksheets("feuil1").Unprotect Password:=""
 
 
End Sub

Dans un module :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Global ProchainAppel
 
Sub Demarre_Horloge()
Worksheets("Feuil1").Cells(1, 1).Value = Now
ProchainAppel = Now + TimeValue("00:00:01")
 Application.OnTime ProchainAppel, "Demarre_Horloge", , True
 
End Sub
 
Sub Arreter_Horloge()
On Error Resume Next
Application.OnTime ProchainAppel, "Demarre_Horloge", , False
End Sub

Dans ThisWorkBook :

Code:

1
2
3
4
5
Private Sub Workbook_BeforeClose(Cancel As Boolean)
 
 Call Arreter_Horloge
 
End Sub

06/07/2013, 08h07
Invité

Bonjour,

Encore une superbe réponse de Ben_L. J'allais justement commencer à m'intéresser au Multitreading sous Excel. Ça tombe très bien :ccool:

Ça requière plusieurs modif en 64 bit par contre.
06/07/2013, 11h41
Ben_L

Bonjour Nouveau2,

Merci pour tes encouragements. Ça fait plaisir de voir que mes contributions sont appréciées :D

Concernant l'utilisation en environnement 64 bits, je serais très intéressé par tes éventuels retours. Quelles sont les modifs à appliquer ?
Ma version d'Office n'est pas en 64 bits. Je ne peux donc pas réaliser de tests par moi-même pour l'instant.

A+

De rien, tu les mérite.

En 64 bits, c'est jamais aussi simple pour un débutant comme moi, puisqu'il n'y a pas beaucoup de code dispo sur le net qui soit fonctionnel en 64 bit.

Je sais que ton code peut marcher. Il y a des codes similaire ou identique, mais en x64, je n'ai pas encore trouvé.

Pour l'instant, j'ai ceci (mais marche pas):

Code:

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
Option Explicit
 
#If VBA7 Then
' à voir
Declare PtrSafe Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
 
' ------------ Théoriquement OK, en pratique ... : Début ---------------
Private Declare PtrSafe Function CreateThread Lib "kernel32" ( _
        lpThreadAttributes As SECURITY_ATTRIBUTES, _
        ByVal dwStackSize As LongPtr, _
        lpStartAddress As LongPtr, _
        lpParameter As Any, _
        ByVal dwCreationFlags As Long, _
        lpThreadId As Long) As LongPtr
 
Private Type SECURITY_ATTRIBUTES
    nLength As Long
    lpSecurityDescriptor As LongPtr
    bInheritHandle As Long
End Type
 
Declare PtrSafe Function CreateRemoteThread Lib "kernel32" ( _
        ByVal hProcess As LongPtr, _
        lpThreadAttributes As Any, _
        ByVal dwStackSize As LongPtr, _
        lpStartAddress As LongPtr, _
        lpParameter As Any, _
        ByVal dwCreationFlags As Long, _
        lpThreadId As Long) As LongPtr
 
Declare PtrSafe Function GetCurrentThread Lib "kernel32" () As LongPtr
Declare PtrSafe Function GetCurrentThreadId Lib "kernel32" () As Long
Declare PtrSafe Function SetThreadPriority Lib "kernel32" (ByVal hThread As LongPtr, ByVal nPriority As Long) As Long
Declare PtrSafe Function GetThreadPriority Lib "kernel32" (ByVal hThread As LongPtr) As Long
' ------------ Théoriquement OK, en pratique ... : Fin ---------------
 
'Non OK
'Declare PtrSafe Function GetThreadTimes Lib "kernel32" (ByVal hThread As LongPtr, lpCreationTime As FILETIME, lpExitTime As FILETIME, lpKernelTime As FILETIME, lpUserTime As FILETIME) As Long
 
Declare PtrSafe Sub ExitThread Lib "kernel32" (ByVal dwExitCode As Long)
Declare PtrSafe Function TerminateThread Lib "kernel32" (ByVal hThread As LongPtr, ByVal dwExitCode As Long) As Long
Declare PtrSafe Function GetExitCodeThread Lib "kernel32" (ByVal hThread As LongPtr, lpExitCode As Long) As Long
 
'Non OK
'Declare PtrSafe Function GetThreadSelectorEntry Lib "kernel32" (ByVal hThread As LongPtr, ByVal dwSelector As Long, lpSelectorEntry As LDT_ENTRY) As Long
 
Declare PtrSafe Function GetWindowThreadProcessId Lib "user32" (ByVal hwnd As LongPtr, lpdwProcessId As Long) As Long
 
Declare PtrSafe Function Beep Lib "kernel32" (ByVal dwFreqHz As Long, ByVal dwDurationMs As Long) As Long
 
Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwDurationMs As LongPtr)
 
#Else
'---
#End If

Code:

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
Private Sub TacheAsynchrone()
    MsgBox "Ca marche !!!"
End Sub
 
Private Sub Son() ' Audio
' Audio
Dim Son(1 To 16) As Double, L As Byte
For L = LBound(Son) To UBound(Son)
Son(1) = Beep(800 * 2 ^ (1 / L), 200) 'c'est pas une symphonie enfaite
Sleep 75
DoEvents
Next L
End Sub 
 
Public Sub Lanceur()
   #If VBA7 Then
       Dim hThread As LongPtr
   #Else
       Dim hThread As Long
   #End If
    Dim hThreadID As Long
 
    hThread = CreateThread(0&, ByVal 0&, AddressOf Son, ByVal 0&, 0&, hThreadID)
    MsgBox "Le processus asynchrone a été créé."
 
    Stop
    CloseHandle hThread
 
End Sub

Je ne sais pas quoi mettre à SECURITY_ATTRIBUTES, et si je met Any à la place, ça plante.

07/07/2013, 02h55
Ben_L

C'est la première fois que je vois du code VBA 64 bits. Intéressant !
Je n'ai rien trouvé qui puisse t'aider directement pour CreateThread.

Toutefois, cette source semble indiquer que le type de données 'SIZE_T' (pour 'dwStackSize') doit être défini comme un IntPtr.

A part ça, si l'API CreateProcess t'intéresse aussi, cette page présente un exemple d'utilisation en x64.
Elle laisse d'ailleurs penser qu'utiliser SECURITY_ATTRIBUTES dans une déclaration d'API ne pose pas de problème.

Bonjour,

Code:

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
Private Declare PtrSafe Function CreateThread _
    Lib "kernel32" _
    (ByVal lpThreadAttributes As LongPtr, _
    ByVal dwStackSize As LongPtr, _
    ByVal lpStartAddress As LongPtr, _
    lpParameter As LongPtr, _
    ByVal dwCreationFlags As Long, _
    lpThreadId As Long) As LongPtr
 
Declare PtrSafe Function CloseHandle _
    Lib "kernel32" _
    (ByVal hObject As LongPtr) As Long
 
Declare PtrSafe Function Beep _
    Lib "kernel32" _
    (ByVal dwFreq As Long, _
    ByVal dwDuration As Long) As Long
 
Declare PtrSafe Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)
 
Public Sub Lanceur()
    Dim hThread As LongPtr
    hThread = CreateThread(0, 0, AddressOf Symphonie, 0, 0, 0)
    MsgBox "Le processus asynchrone a été créé."
    CloseHandle hThread
End Sub
 
Sub Symphonie()
    Dim Son(1 To 16) As Double, L As Byte
    For L = LBound(Son) To UBound(Son)
        Son(1) = Beep(800 * 2 ^ (1 / L), 200) 'c'est pas une symphonie enfaite
        Sleep 75
        DoEvents
    Next L
End Sub

Cordialement

ctac

07/07/2013, 16h58
Invité

Bonjour,

Nickel ctac_, ça marche ! Merci :ccool:

@Ben_L,
Je me demande si CloseHandle ferme le thread ou fait justement autrechose. Il y a des options comme TerminateThread ou ExitThread.

Que fait exactement CloseHandle ?

Sinon, en l'état, le code marche 1 fois mais pas deux. Il doit y avoir des précautions à prendre. Egalement, en lançant 2 thread, ça ne marche pas aussi simplement on dirait.

Citation:

Envoyé par Ben_L

Toutefois, cette source semble indiquer que le type de données 'SIZE_T' (pour 'dwStackSize') doit être défini comme un IntPtr.

Oui, mais en VBA, le Byte vaut 8 bit, le Integer vaut 16 bit, le long 32 bit, et le LongLong 64 bit.
Ici, il s'agit d'un autre Langage, surement que le Integer vaut 32 bit, et le IntegerPtr vaut 32 ou 64 bit suivant le système.

C'était le Any qui posait problème. Et le hObject.
ctac_ les a passé en LongPtr, et ça marche. Il faut croire que le Any ne marche qu'en 32 bit. Que signifie-t-il d'ailleurs ? Est-ce que ça marche en le remplaçant par un Long par exemple ?
07/07/2013, 19h43
Ben_L

Il me semble que CloseHandle se contente de libérer le handle associé au thread (ou à autre chose d'ailleurs). Le thread n'est pas fermé, il n'est simplement plus accessible.
Je n'avais pas inclus ExitThread ou TerminateThread car la macro lancée ne peut pas boucler indéfiniment (dans mon exemple initial en tout cas).

Concernant le type de données Any, plus d'infos ici.

Pour SIZE_T, me suis planté :oops:
Je pensais que les 2 langages étaient plus proches.

Enfin, pour réussir à lancer plusieurs threads, ne faudrait-il pas jouer sur lpThreadId ?

Et merci à ctac pour sa contribution :ccool:

Bonne soirée.
08/07/2013, 15h12
daveb123

Merci beacoup a tous pour vos réponses. J'avais finalement utilisé le code d'une progress bar que quelqu'un a réalisé ici sur le forum .

Cependant, je crois que je vais me servir de la version énoncé ici.

merci encore
08/07/2013, 22h03
Invité

Bonsoir,

@Ben_L,
OK, merci, je verrai ça très bientôt plus en détail.