forked from WindowStations/VB6NameSpaces
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Rectangle.cls
266 lines (262 loc) · 9.46 KB
/
Rectangle.cls
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
VERSION 1.0 CLASS
BEGIN
MultiUse = -1
Persistable = 0
DataBindingBehavior = 0
DataSourceBehavior = 0
MTSTransactionMode = 0
END
Attribute VB_Name = "Rectangle"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit
'VERSION 1.0 CLASS
'BEGIN
' MultiUse = -1 'True
' Persistable = 0 'NotPersistable
' DataBindingBehavior = 0 'vbNone
' DataSourceBehavior = 0 'vbNone
' MTSTransactionMode = 0 'NotAnMTSObject
'END
'Attribute VB_Name = "Rectangle"
'Attribute VB_GlobalNameSpace = False
'Attribute VB_Creatable = True
'Attribute VB_PredeclaredId = False
'Attribute VB_Exposed = False
'Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
'Attribute VB_Ext_KEY = "Member0" ,"Size"
'Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'Option Explicit
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Declare Function apiCopyRect Lib "user32" Alias "CopyRect" (ByRef lpDestRect As RECT, ByRef lpSourceRect As RECT) As Long
Private Declare Function apiEqualRect Lib "user32" Alias "EqualRect" (ByRef lpRect1 As RECT, ByRef lpRect2 As RECT) As Long
Private Declare Function apiGetClientRect Lib "user32" Alias "GetClientRect" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function apiInflateRect Lib "user32" Alias "InflateRect" (ByRef lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function apiIntersectRect Lib "user32" Alias "IntersectRect" (ByRef lpDestRect As RECT, ByRef lpSrc1Rect As RECT, ByRef lpSrc2Rect As RECT) As Long
Private Declare Function apiIsRectEmpty Lib "user32" Alias "IsRectEmpty" (ByRef lpRect As RECT) As Long
Private Declare Function apiOffsetRect Lib "user32" Alias "OffsetRect" (ByRef lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function apiPtInRect Lib "user32" Alias "PtInRect" (ByRef lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function apiSetRect Lib "user32" Alias "SetRect" (ByRef lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function apiSetRectEmpty Lib "user32" Alias "SetRectEmpty" (ByRef lpRect As RECT) As Long
Private Declare Function apiSubtractRect Lib "user32" Alias "SubtractRect" (ByRef lprcDst As RECT, ByRef lprcSrc1 As RECT, ByRef lprcSrc2 As RECT) As Long
Private Declare Function apiUnionRect Lib "user32" Alias "UnionRect" (ByRef lprcDst As RECT, ByRef lprcSrc1 As RECT, ByRef lprcSrc2 As RECT) As Long
Private mvarLocation As New Point
Private mvarSize As New Size
Private mvarTop As Long
Private mvarLeft As Long
Private mvarBottom As Long
Private mvarRight As Long
Private mvarHeight As Long
Private mvarWidth_ As Long
Private mvarX As Long
Private mvarY As Long
Friend Property Let y(ByVal vData As Long)
mvarY = vData
End Property
Friend Property Get y() As Long
y = mvarY
End Property
Friend Property Let x(ByVal vData As Long)
mvarX = vData
End Property
Friend Property Get x() As Long
x = mvarX
End Property
Friend Property Let Width_(ByVal vData As Long)
mvarWidth_ = vData
End Property
Friend Property Get Width_() As Long
Width_ = mvarWidth_
End Property
Friend Property Let Height(ByVal vData As Long)
mvarHeight = vData
End Property
Friend Property Get Height() As Long
Height = mvarHeight
End Property
Friend Property Set Location(ByVal vData As Point)
Set mvarLocation = vData
End Property
Friend Property Get Location() As Point
Set Location = mvarLocation
End Property
Friend Property Set Size(ByVal vData As Size)
Set mvarSize = vData
End Property
Friend Property Get Size() As Size
Set Size = mvarSize
End Property
Friend Property Let Top(ByVal vData As Long)
mvarTop = vData
End Property
Friend Property Get Top() As Long
Top = mvarTop
End Property
Friend Property Let Left(ByVal vData As Long)
mvarLeft = vData
End Property
Friend Property Get Left() As Long
Left = mvarLeft
End Property
Friend Property Let Bottom(ByVal vData As Long)
mvarBottom = vData
End Property
Friend Property Get Bottom() As Long
Bottom = mvarBottom
End Property
Friend Property Let Right(ByVal vData As Long)
mvarRight = vData
End Property
Friend Property Get Right() As Long
Right = mvarRight
End Property
Private Sub FromRectangle(ByRef rDestination As RECT, ByRef rSource As Rectangle)
Call apiSetRect(rDestination, rSource.x, rSource.y, rSource.Right, rSource.Bottom)
End Sub
Friend Sub FromRECT(ByRef r1 As RECT, ByRef r2 As Rectangle)
On Error Resume Next
Call FromLTRB(r1.Left, r1.Top, r1.Right, r1.Bottom, r2)
With r2
.x = r1.Left
.y = r1.Top
.Width_ = (r1.Right - r1.Left)
.Height = (r1.Bottom - r1.Top)
.Location.x = r1.Left
.Location.y = r1.Top
.Size.Width_ = (r1.Right - r1.Left)
.Size.Height_ = (r1.Bottom - r1.Top)
End With
End Sub
Friend Sub FromLTRB(ByVal Left As Long, ByVal Top As Long, ByVal Right As Long, ByVal Bottom As Long, ByRef r2 As Rectangle)
On Error Resume Next
Dim r As New Rectangle
With r
.x = Left
.y = Top
.Left = Left
.Top = Top
.Location.x = Left
.Location.y = Top
.Bottom = Bottom
.Right = Right
.Width_ = (Right - Left)
.Height = (Bottom - Top)
.Size.Width_ = (Right - Left)
.Size.Height_ = (Bottom - Top)
End With
Set r2 = r
End Sub
Friend Sub Copy(ByRef rDestination As Rectangle, ByRef rSource As Rectangle)
On Error Resume Next
Dim rctdest As RECT
Dim rctsour As RECT
Call FromRectangle(rctdest, rDestination)
Call FromRectangle(rctsour, rSource)
Call apiCopyRect(rctdest, rctsour)
Call FromRECT(rctdest, rDestination)
End Sub
Friend Sub offset(ByRef pt As Point, ByRef lpRect As Rectangle)
On Error Resume Next
Dim r As RECT
Call FromRectangle(r, lpRect)
Call apiOffsetRect(r, pt.x, pt.y)
Call FromRECT(r, lpRect)
End Sub
Friend Sub EmptyRectangle(ByRef lpRect As Rectangle)
On Error Resume Next
Dim r As New Rectangle
Dim rct As RECT
Call FromRectangle(rct, lpRect)
Call apiSetRectEmpty(rct)
Call FromRECT(rct, r)
Set lpRect = r
End Sub
Friend Function PoinInRectangle(ByRef p As Point, ByRef r As Rectangle) As Boolean
Dim r2 As RECT
Call FromRectangle(r2, r)
PoinInRectangle = CBool(apiPtInRect(r2, p.x, p.y))
End Function
Friend Sub Inflate(ByRef lpRect As Rectangle, ByVal x As Long, ByVal y As Long)
On Error Resume Next
Dim r As New Rectangle
Dim rct As RECT
Call FromRectangle(rct, lpRect)
Call apiInflateRect(rct, x, y)
Call FromRECT(rct, r)
Set lpRect = r
End Sub
Friend Sub Subtract(ByRef dest As Rectangle, ByRef source As Rectangle, ByRef source2 As Rectangle)
On Error Resume Next
Dim r As New Rectangle
Dim rdest As RECT
Dim rsource1 As RECT
Dim rsource2 As RECT
Call FromRectangle(rdest, dest)
Call FromRectangle(rsource1, source)
Call FromRectangle(rsource2, source2)
Call apiSubtractRect(rdest, rsource1, rsource2)
Call FromRECT(rdest, r)
Set dest = r
End Sub
Friend Sub Union(ByRef dest As Rectangle, ByRef source As Rectangle, ByRef source2 As Rectangle)
On Error Resume Next
Dim r As New Rectangle
Dim rdest As RECT
Dim rsource1 As RECT
Dim rsource2 As RECT
Call FromRectangle(rdest, dest)
Call FromRectangle(rsource1, source)
Call FromRectangle(rsource2, source2)
Call apiUnionRect(rdest, rsource1, rsource2)
Call FromRECT(rdest, r)
Set dest = r
End Sub
Friend Sub Intersect(ByRef dest As Rectangle, ByRef source As Rectangle, ByRef source2 As Rectangle)
On Error Resume Next
Dim r As New Rectangle
Dim rdest As RECT
Dim rsource1 As RECT
Dim rsource2 As RECT
Call FromRectangle(rdest, dest)
Call FromRectangle(rsource1, source)
Call FromRectangle(rsource2, source2)
Call apiIntersectRect(rdest, rsource1, rsource2)
Call FromRECT(rdest, r)
Set dest = r
End Sub
Friend Function IntersectsWith(ByRef dest As Rectangle, ByRef source As Rectangle, ByRef source2 As Rectangle) As Boolean
On Error Resume Next
Dim r As New Rectangle
Dim rdest As RECT
Dim rsource1 As RECT
Dim rsource2 As RECT
Call FromRectangle(rdest, dest)
Call FromRectangle(rsource1, source)
Call FromRectangle(rsource2, source2)
Call apiIntersectRect(rdest, rsource1, rsource2)
Call FromRECT(rdest, r)
IntersectsWith = Not IsEmpty(r)
End Function
Friend Function Equals(ByRef r1 As Rectangle, ByRef r2 As Rectangle) As Boolean
On Error Resume Next
Dim rect1 As RECT
Dim rect2 As RECT
Call apiSetRect(rect1, r1.x, r1.y, r1.Right, r1.Bottom)
Call FromRectangle(rect1, r1)
Call FromRectangle(rect2, r2)
Equals = CBool(apiEqualRect(rect1, rect2))
End Function
Friend Function IsEmpty(ByRef lpRect As Rectangle) As Boolean
On Error Resume Next
Dim rct As RECT
Call FromRectangle(rct, lpRect)
IsEmpty = CBool(apiSetRectEmpty(rct))
End Function