Skip to content

Commit c1a5476

Browse files
GruberMarkusGruberMarkus
authored
v2024.12.18 (#2)
* Delete modScaleForm-sample-database.mdb * Add files via upload * Add files via upload
1 parent f02492a commit c1a5476

File tree

4 files changed

+358
-12
lines changed

4 files changed

+358
-12
lines changed

‎clFormWindow.bas‎

Lines changed: 329 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,329 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "clFormWindow"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
Option Compare Database
11+
Option Explicit
12+
13+
14+
'*************************************************************
15+
' Class module: clFormWindow *
16+
'*************************************************************
17+
' Moves and resizes a window in the coordinate system *
18+
' of its parent window. *
19+
' N.B.: This class was developed for use on Access forms *
20+
' and has not been tested for use with other window *
21+
' types. *
22+
'*************************************************************
23+
24+
25+
26+
'*************************************************************
27+
' Type declarations
28+
'*************************************************************
29+
30+
Private Type RECT 'RECT structure used for API calls.
31+
Left As Long
32+
Top As Long
33+
Right As Long
34+
Bottom As Long
35+
End Type
36+
37+
38+
Private Type POINTAPI 'POINTAPI structure used for API calls.
39+
X As Long
40+
Y As Long
41+
End Type
42+
43+
44+
45+
'*************************************************************
46+
' Member variables
47+
'*************************************************************
48+
49+
Private m_hWnd As Long 'Handle of the window.
50+
Private m_rctWindow As RECT 'Rectangle describing the sides of the last polled location of the window.
51+
52+
53+
54+
'*************************************************************
55+
' Private error constants for use with RaiseError procedure
56+
'*************************************************************
57+
58+
Private Const m_ERR_INVALIDHWND = 1
59+
Private Const m_ERR_NOPARENTWINDOW = 2
60+
61+
62+
63+
'*************************************************************
64+
' API function declarations
65+
'*************************************************************
66+
67+
#If VBA7 Then
68+
Private Declare PtrSafe Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As LongPtr) As Long
69+
Private Declare PtrSafe Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As LongPtr, ByVal X As Long, ByVal Y As Long, _
70+
ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
71+
Private Declare PtrSafe Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As LongPtr, lpRect As RECT) As Long
72+
Private Declare PtrSafe Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As LongPtr, lpPoint As POINTAPI) As Long
73+
Private Declare PtrSafe Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As LongPtr) As Long
74+
#Else
75+
Private Declare Function apiIsWindow Lib "user32" Alias "IsWindow" (ByVal hWnd As Long) As Long
76+
Private Declare Function apiMoveWindow Lib "user32" Alias "MoveWindow" (ByVal hWnd As Long, ByVal X As Long, ByVal Y As Long, _
77+
ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
78+
Private Declare Function apiGetWindowRect Lib "user32" Alias "GetWindowRect" (ByVal hWnd As Long, lpRect As RECT) As Long
79+
Private Declare Function apiScreenToClient Lib "user32" Alias "ScreenToClient" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
80+
Private Declare Function apiGetParent Lib "user32" Alias "GetParent" (ByVal hWnd As Long) As Long
81+
#End If
82+
83+
84+
85+
86+
'*************************************************************
87+
' Private procedures
88+
'*************************************************************
89+
90+
Private Sub RaiseError(ByVal lngErrNumber As Long, ByVal strErrDesc As String)
91+
'Raises a user-defined error to the calling procedure.
92+
93+
Err.Raise vbObjectError + lngErrNumber, "clFormWindow", strErrDesc
94+
95+
End Sub
96+
97+
98+
Private Sub UpdateWindowRect()
99+
'Places the current window rectangle position (in pixels, in coordinate system of parent window) in m_rctWindow.
100+
101+
Dim ptCorner As POINTAPI
102+
103+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
104+
apiGetWindowRect m_hWnd, m_rctWindow 'm_rctWindow now holds window coordinates in screen coordinates.
105+
106+
If Not Me.Parent Is Nothing Then
107+
'If there is a parent window, convert top, left of window from screen coordinates to parent window coordinates.
108+
With ptCorner
109+
.X = m_rctWindow.Left
110+
.Y = m_rctWindow.Top
111+
End With
112+
113+
apiScreenToClient Me.Parent.hWnd, ptCorner
114+
115+
With m_rctWindow
116+
.Left = ptCorner.X
117+
.Top = ptCorner.Y
118+
End With
119+
120+
'If there is a parent window, convert bottom, right of window from screen coordinates to parent window coordinates.
121+
With ptCorner
122+
.X = m_rctWindow.Right
123+
.Y = m_rctWindow.Bottom
124+
End With
125+
126+
apiScreenToClient Me.Parent.hWnd, ptCorner
127+
128+
With m_rctWindow
129+
.Right = ptCorner.X
130+
.Bottom = ptCorner.Y
131+
End With
132+
End If
133+
Else
134+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
135+
End If
136+
137+
End Sub
138+
139+
140+
141+
142+
'*************************************************************
143+
' Public read-write properties
144+
'*************************************************************
145+
146+
Public Property Get hWnd() As Long
147+
'Returns the value the user has specified for the window's handle.
148+
149+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
150+
hWnd = m_hWnd
151+
Else
152+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
153+
End If
154+
155+
End Property
156+
157+
158+
Public Property Let hWnd(ByVal lngNewValue As Long)
159+
'Sets the window to use by specifying its handle.
160+
'Only accepts valid window handles.
161+
162+
If lngNewValue = 0 Or apiIsWindow(lngNewValue) Then
163+
m_hWnd = lngNewValue
164+
Else
165+
RaiseError m_ERR_INVALIDHWND, "The value passed to the hWnd property is not a valid window handle."
166+
End If
167+
168+
End Property
169+
170+
'----------------------------------------------------
171+
172+
Public Property Get Left() As Long
173+
'Returns the current position (in pixels) of the left edge of the window in the coordinate system of its parent window.
174+
175+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
176+
UpdateWindowRect
177+
Left = m_rctWindow.Left
178+
Else
179+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
180+
End If
181+
182+
End Property
183+
184+
185+
Public Property Let Left(ByVal lngNewValue As Long)
186+
'Moves the window such that its left edge falls at the position indicated
187+
'(measured in pixels, in the coordinate system of its parent window).
188+
189+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
190+
UpdateWindowRect
191+
With m_rctWindow
192+
apiMoveWindow m_hWnd, lngNewValue, .Top, .Right - .Left, .Bottom - .Top, True
193+
End With
194+
Else
195+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
196+
End If
197+
198+
End Property
199+
200+
'----------------------------------------------------
201+
202+
Public Property Get Top() As Long
203+
'Returns the current position (in pixels) of the top edge of the window in the coordinate system of its parent window.
204+
205+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
206+
UpdateWindowRect
207+
Top = m_rctWindow.Top
208+
Else
209+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
210+
End If
211+
212+
End Property
213+
214+
215+
Public Property Let Top(ByVal lngNewValue As Long)
216+
'Moves the window such that its top edge falls at the position indicated
217+
'(measured in pixels, in the coordinate system of its parent window).
218+
219+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
220+
UpdateWindowRect
221+
With m_rctWindow
222+
apiMoveWindow m_hWnd, .Left, lngNewValue, .Right - .Left, .Bottom - .Top, True
223+
End With
224+
Else
225+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
226+
End If
227+
228+
End Property
229+
230+
'----------------------------------------------------
231+
232+
Public Property Get Width() As Long
233+
'Returns the current width (in pixels) of the window.
234+
235+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
236+
UpdateWindowRect
237+
With m_rctWindow
238+
Width = .Right - .Left
239+
End With
240+
Else
241+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
242+
End If
243+
244+
End Property
245+
246+
247+
Public Property Let Width(ByVal lngNewValue As Long)
248+
'Changes the width of the window to the value provided (in pixels).
249+
250+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
251+
UpdateWindowRect
252+
With m_rctWindow
253+
apiMoveWindow m_hWnd, .Left, .Top, lngNewValue, .Bottom - .Top, True
254+
End With
255+
Else
256+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
257+
End If
258+
259+
End Property
260+
261+
'----------------------------------------------------
262+
263+
Public Property Get Height() As Long
264+
'Returns the current height (in pixels) of the window.
265+
266+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
267+
UpdateWindowRect
268+
With m_rctWindow
269+
Height = .Bottom - .Top
270+
End With
271+
Else
272+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
273+
End If
274+
275+
End Property
276+
277+
278+
Public Property Let Height(ByVal lngNewValue As Long)
279+
'Changes the height of the window to the value provided (in pixels).
280+
281+
If m_hWnd = 0 Or apiIsWindow(m_hWnd) Then
282+
UpdateWindowRect
283+
With m_rctWindow
284+
apiMoveWindow m_hWnd, .Left, .Top, .Right - .Left, lngNewValue, True
285+
End With
286+
Else
287+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
288+
End If
289+
290+
End Property
291+
292+
293+
294+
'*************************************************************
295+
' Public read-only properties
296+
'*************************************************************
297+
298+
Public Property Get Parent() As clFormWindow
299+
'Returns the parent window as a clFormWindow object.
300+
'For forms, this should be the Access MDI window.
301+
302+
Dim fwParent As New clFormWindow
303+
Dim lngHWnd As Long
304+
305+
If m_hWnd = 0 Then
306+
Set Parent = Nothing
307+
ElseIf apiIsWindow(m_hWnd) Then
308+
lngHWnd = apiGetParent(m_hWnd)
309+
fwParent.hWnd = lngHWnd
310+
Set Parent = fwParent
311+
Else
312+
RaiseError m_ERR_INVALIDHWND, "The window handle " & m_hWnd & " is no longer valid."
313+
End If
314+
315+
Set fwParent = Nothing
316+
317+
End Property
318+
319+
320+
321+
322+
323+
324+
325+
326+
327+
328+
329+

‎modScaleForm-sample-database.accdb‎

232 KB
Binary file not shown.

‎modScaleForm-sample-database.mdb‎

-1.05 MB
Binary file not shown.

0 commit comments

Comments
 (0)