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
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
| Option Explicit
' Пример многопоточности VB6
' © Кривоус Анатолий Анатольевич (The trick), 2013
' Работает только в скомпилированном виде
Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Long, ByVal dwMilliseconds As Long) As Long
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 SetThreadPriority Lib "kernel32" (ByVal hThread As Long, ByVal nPriority As Long) As Long
Private Declare Function GetThreadPriority Lib "kernel32" (ByVal hThread As Long) As Long
Private Const DC_PEN As Long = 19
Private Const INFINITE = &HFFFFFFFF
Private Const MAX = 255
Dim Threads As Collection
Dim Thread(MAX - 1) As Point
Private Sub cboPriority_Click()
Dim i As Long
i = cboThread.ListIndex
If i >= 0 Then
SetThreadPriority Threads(i + 1), cboPriority.ItemData(cboPriority.ListIndex)
End If
End Sub
Private Sub cboThread_Click()
Dim i As Long, p As Long
i = cboThread.ListIndex
If i >= 0 Then
p = GetThreadPriority(Threads(i + 1))
cboPriority.ListIndex = 0
Do Until cboPriority.ItemData(cboPriority.ListIndex) = p
cboPriority.ListIndex = cboPriority.ListIndex + 1
Loop
End If
End Sub
Private Sub cmdNewThread_Click()
Dim hThread As Long, IDThread As Long, Pt As Point
Randomize
Pt.Pos.X = 100: Pt.Pos.Y = 100
Pt.Spd1 = 0.000001: Pt.Spd2 = 0.00000001
Pt.Color = RGB(Rnd * 255, Rnd * 255, Rnd * 255)
Pt.Status = True
Thread(Threads.Count) = Pt
hThread = CreateThread(ByVal 0, 0, AddressOf MoveProc, Thread(Threads.Count), 0, IDThread)
If hThread Then Threads.Add hThread Else MsgBox ("Неудалось создать поток"): Exit Sub
SetThreadPriority hThread, 0
cboThread.AddItem hThread
cboThread.ListIndex = cboThread.ListCount - 1
End Sub
Private Sub Form_Load()
Set Threads = New Collection
End Sub
Private Sub UnloadAll()
Dim i As Variant, l As Long
For Each i In Threads
Thread(l).Status = False
WaitForSingleObject CLng(i), INFINITE
l = l + 1
Next
End Sub
Private Sub Form_Unload(Cancel As Integer)
UnloadAll
End Sub
Private Sub tmrTimer_Timer()
Dim i As Long, Pt As Point
picCanvas.Cls
For i = 0 To Threads.Count - 1
Pt = Thread(i)
picCanvas.Line (Pt.Pos.X - 3, Pt.Pos.Y - 3)-Step(6, 6), Pt.Color, BF
picCanvas.Print Threads(i + 1)
Next
End Sub |
