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
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
'Create Vector
For i = 0 To largeur - 1
For j = 0 To hauteur - 1
pixel = bmp.GetPixel(i, j).R
If pixel = 255 Then
tabloImage(i, j) = 0
Else
tabloImage(i, j) = 1
AddSquareVector(i, j)
Application.DoEvents()
End If
Next
Next
'Simplify vector
For m = 0 To Vnum - 2
For m2 = m + 1 To Vnum - 1
If EqualVectors(m, m2) Then
RemoveVectors(m, m2)
Application.DoEvents()
End If
Next
Next
'Avec les définitions les fonctions ci-dessus définies comme suit
Public Sub AddSquareVector(ByVal i As Integer, ByVal j As Integer)
ReDim Preserve V(Vnum + 3)
V(Vnum).prec = Vnum + 3
V(Vnum).Sx = i : V(Vnum).Sy = j
V(Vnum).Ex = i + 1 : V(Vnum).Ey = j
V(Vnum).suiv = Vnum + 1
V(Vnum).status = 0
Vnum += 1
V(Vnum).prec = Vnum - 1
V(Vnum).Sx = i + 1 : V(Vnum).Sy = j
V(Vnum).Ex = i + 1 : V(Vnum).Ey = j + 1
V(Vnum).suiv = Vnum + 1
V(Vnum).status = 0
Vnum += 1
V(Vnum).prec = Vnum - 1
V(Vnum).Sx = i + 1 : V(Vnum).Sy = j + 1
V(Vnum).Ex = i : V(Vnum).Ey = j + 1
V(Vnum).suiv = Vnum + 1
V(Vnum).status = 0
Vnum += 1
V(Vnum).prec = Vnum - 1
V(Vnum).Sx = i : V(Vnum).Sy = j + 1
V(Vnum).Ex = i : V(Vnum).Ey = j
V(Vnum).suiv = Vnum - 3
V(Vnum).status = 0
Vnum += 1
End Sub
Public Function EqualVectors(ByVal m As Integer, ByVal m2 As Integer) As Boolean
Dim msx, msy, mex, mey, m2sx, m2sy, m2ex, m2ey As Integer
Dim r As Boolean
r = False
If (V(m).status = 0) Then
msx = V(m).Sx : msy = V(m).Sy : mex = V(m).Ex : mey = V(m).Ey
m2sx = V(m2).Sx : m2sy = V(m2).Sy : m2ex = V(m2).Ex : m2ey = V(m2).Ey
If EqualPoints(msx, msy, m2sx, m2sy) And EqualPoints(mex, mey, m2ex, m2ey) Then
r = True
End If
If EqualPoints(msx, msy, m2ex, m2ey) And EqualPoints(mex, mey, m2sx, m2sy) Then
r = True
End If
End If
Application.DoEvents()
Return r
End Function
Public Function EqualPoints(ByVal pt1x As Integer, ByVal pt1y As Integer, ByVal pt2x As Integer, ByVal pt2y As Integer) As Boolean
Dim r As Boolean
r = False
If (pt1x = pt2x) And (pt1y = pt2y) Then
r = True
End If
Return r
End Function
Public Sub RemoveVectors(ByVal m As Integer, ByVal m2 As Integer)
removeVector(m, m2)
removeVector(m2, m)
V(m).status = -1
V(m2).status = -1
End Sub
Public Sub removeVector(ByVal mm As Integer, ByVal mm2 As Integer)
Dim p, n As Integer
p = V(mm).prec : V(p).suiv = V(mm2).suiv
n = V(mm2).suiv : V(n).prec = p
End Sub |
