Skip to content

Commit c3e54e6

Browse files
vbatoolsvbatools
committed
add file
1 parent b862b58 commit c3e54e6

File tree

5 files changed

+307
-0
lines changed

5 files changed

+307
-0
lines changed

‎ResizeUserForm.xlsm

28.5 KB
Binary file not shown.

‎scripts/CAnchor.cls

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "CAnchor"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
11+
'* Module : CAnchor
12+
'* Created : 15-09-2019 15:53
13+
'* Author : VBATools
14+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
15+
'* Copyright : VBATools.ru
16+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
17+
18+
Option Explicit
19+
Public cnt As MSForms.control
20+
Public AnchorStyle As enumAnchorStyles
21+
Public MinimumLeft As Single
22+
Public MinimumTop As Single
23+
Public MinimumWidth As Single
24+
Public MinimumHeight As Single
25+
Public OrigLeft As Single
26+
Public OrigTop As Single
27+
Public OrigWidth As Single
28+
Public OrigHeight As Single

‎scripts/CAnchors.cls

+214
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,214 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "CAnchors"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
11+
'* Module : CAnchors - ìîäóëü èçìåíåíèÿ ðàçìåðîâ ôîðì
12+
'* Created : 15-09-2019 15:53
13+
'* Author : VBATools
14+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
15+
'* Copyright : VBATools.ru
16+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
17+
18+
Option Explicit
19+
Private m_colAnchors As Collection
20+
Private m_frmParent As Object
21+
Public MinimumWidth As Single
22+
Public MinimumHeight As Single
23+
Public OrigLeft As Single
24+
Public OrigTop As Single
25+
Public OrigWidth As Single
26+
Public OrigHeight As Single
27+
Public UpdateWhilstDragging As Boolean
28+
Private Const MRESIZEHANDLE = "ResizeGrabHandle"
29+
Private m_sngLeftResizePos As Single
30+
Private m_sngTopResizePos As Single
31+
Private m_blnResizing As Boolean
32+
Public WithEvents ResizeHandle As MSForms.Label
33+
Attribute ResizeHandle.VB_VarHelpID = -1
34+
Public Property Set AddCntrl(ByRef RHS As MSForms.control)
35+
23: Dim clsTemp As CAnchor
36+
24: Set clsTemp = New CAnchor
37+
25: Set clsTemp.cnt = RHS
38+
26: With clsTemp
39+
27: .AnchorStyle = enumAnchorStyleLeft Or enumAnchorStyleTop
40+
28: .MinimumWidth = .cnt.Width
41+
29: .MinimumHeight = .cnt.Height
42+
30: .OrigLeft = .cnt.Left
43+
31: .OrigTop = .cnt.top
44+
32: .OrigWidth = .cnt.Width
45+
33: .OrigHeight = .cnt.Height
46+
34: End With
47+
35: m_colAnchors.Add clsTemp, clsTemp.cnt.Name
48+
36: End Property
49+
Public Sub RemoveCntrl(ByRef varIndex As Variant)
50+
38: On Error Resume Next
51+
39: m_colAnchors.Remove varIndex
52+
40: End Sub
53+
Private Sub m_AddResizer(ByRef objParent As Object)
54+
42: '
55+
43: ' add resizing control to bottom righthand corner of userform
56+
44: '
57+
45: Set ResizeHandle = objParent.Controls.Add("Forms.label.1", MRESIZEHANDLE, True)
58+
46: With ResizeHandle
59+
47: With .Font
60+
48: .Name = "Marlett"
61+
49: .Charset = 2
62+
50: .Size = 14
63+
51: .Bold = True
64+
52: End With
65+
53: .BackStyle = fmBackStyleTransparent
66+
54: .AutoSize = True
67+
55: .BorderStyle = fmBorderStyleNone
68+
56: .Caption = "o"
69+
57: .MousePointer = fmMousePointerSizeNWSE
70+
58: .ForeColor = &H8000000D
71+
59: .ZOrder
72+
60: .top = objParent.InsideHeight - .Height
73+
61: .Left = objParent.InsideWidth - .Width
74+
62: End With
75+
63: End Sub
76+
Private Sub ResizeHandle_MouseDown(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
77+
65: If Button = 1 Then
78+
66: m_sngLeftResizePos = X
79+
67: m_sngTopResizePos = Y
80+
68: m_blnResizing = True
81+
69: End If
82+
70: End Sub
83+
Private Sub ResizeHandle_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
84+
72: Dim sngSize As Single
85+
73: If Button = 1 Then
86+
74: With ResizeHandle
87+
75: .MOVE .Left + X - m_sngLeftResizePos, .top + Y - m_sngTopResizePos
88+
76: sngSize = m_frmParent.Width + X - m_sngLeftResizePos
89+
77: If sngSize < Me.MinimumWidth Then sngSize = MinimumWidth
90+
78: m_frmParent.Width = sngSize
91+
79: sngSize = m_frmParent.Height + Y - m_sngTopResizePos
92+
80: If sngSize < MinimumHeight Then sngSize = MinimumHeight
93+
81: m_frmParent.Height = sngSize
94+
82: .Left = m_frmParent.InsideWidth - .Width
95+
83: .top = m_frmParent.InsideHeight - .Height
96+
84: If UpdateWhilstDragging Then
97+
85: m_UpdateControls
98+
86: End If
99+
87: End With
100+
88: End If
101+
89: End Sub
102+
Private Sub ResizeHandle_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
103+
91: If Button = 1 Then
104+
92: If Not UpdateWhilstDragging Then
105+
93: m_UpdateControls
106+
94: End If
107+
95: m_blnResizing = False
108+
96: End If
109+
97: End Sub
110+
Public Function funAnchor(ByRef varIndex As Variant) As CAnchor
111+
99: ' access to specific anchored control
112+
100: On Error Resume Next
113+
101: Set funAnchor = m_colAnchors(varIndex)
114+
102: End Function
115+
Public Function Anchors() As Collection
116+
104: ' access to the collection of anchored controls
117+
105: Set Anchors = m_colAnchors
118+
106: End Function
119+
Public Property Set objParent(ByRef RHS As Object)
120+
108: '
121+
109: ' Use this to assign all default properties
122+
110: '
123+
111: Dim clsTemp As CAnchor
124+
112: Dim cntTemp As MSForms.control
125+
113: Set m_frmParent = RHS
126+
114: UpdateWhilstDragging = True '!!
127+
115: With RHS
128+
116: MinimumWidth = .Width
129+
117: MinimumHeight = .Height
130+
118: OrigLeft = 1
131+
119: OrigTop = 1
132+
120: OrigWidth = .InsideWidth
133+
121: OrigHeight = .InsideHeight
134+
122: End With
135+
123: For Each cntTemp In m_frmParent.Controls
136+
124: Set clsTemp = New CAnchor
137+
125: Set clsTemp.cnt = cntTemp
138+
126: With clsTemp
139+
127: .AnchorStyle = enumAnchorStyleLeft Or enumAnchorStyleTop
140+
128: .MinimumWidth = cntTemp.Width
141+
129: .MinimumHeight = cntTemp.Height
142+
130: .OrigLeft = cntTemp.Left
143+
131: .OrigTop = cntTemp.top
144+
132: .OrigWidth = cntTemp.Width
145+
133: .OrigHeight = cntTemp.Height
146+
134: End With
147+
135: m_colAnchors.Add clsTemp, clsTemp.cnt.Name
148+
136: Next
149+
137: m_AddResizer RHS
150+
138: End Property
151+
Private Sub Class_Initialize()
152+
140: Set m_colAnchors = New Collection
153+
141: End Sub
154+
Private Sub Class_Terminate()
155+
143: Do While m_colAnchors.Count > 0
156+
144: m_colAnchors.Remove m_colAnchors.Count
157+
145: Loop
158+
146: Set m_colAnchors = Nothing
159+
147: m_frmParent.Controls.Remove MRESIZEHANDLE
160+
148: Set ResizeHandle = Nothing
161+
149: End Sub
162+
Private Sub m_UpdateControls()
163+
151: '
164+
152: ' Calculate New position of all controls
165+
153: '
166+
154: Dim clsAnchor As CAnchor
167+
155: Dim cntTemp As MSForms.control
168+
156: Dim sngLeft As Single
169+
157: Dim sngTop As Single
170+
158: Dim sngHeight As Single
171+
159: Dim sngWidth As Single
172+
160: For Each clsAnchor In m_colAnchors
173+
161: Set cntTemp = clsAnchor.cnt
174+
162: If clsAnchor.AnchorStyle = enumAnchorStyleNone Then
175+
163: ' do nothing with this control
176+
164: Else
177+
165: If ((clsAnchor.AnchorStyle And enumAnchorStyleTop) = enumAnchorStyleTop) And _
178+
((clsAnchor.AnchorStyle And enumAnchorStyleBottom) = enumAnchorStyleBottom) Then
179+
167: ' maintain gap between top and bottom edges by adjusting height
180+
168: sngHeight = m_frmParent.InsideHeight - (OrigHeight - clsAnchor.OrigTop - clsAnchor.OrigHeight) - clsAnchor.OrigTop
181+
169: If sngHeight < clsAnchor.MinimumHeight Then sngHeight = clsAnchor.MinimumHeight
182+
170: If sngHeight < 0 Then sngHeight = 0
183+
171: cntTemp.Height = sngHeight
184+
172: ElseIf (clsAnchor.AnchorStyle And enumAnchorStyleTop) = enumAnchorStyleTop Then
185+
173: ' maintain gap between top leave height alone
186+
174: ' does not require code
187+
175: ElseIf (clsAnchor.AnchorStyle And enumAnchorStyleBottom) = enumAnchorStyleBottom Then
188+
176: ' maintain gap between bottom leave height alone
189+
177: sngTop = m_frmParent.InsideHeight - (OrigHeight - clsAnchor.OrigTop - clsAnchor.OrigHeight) - clsAnchor.OrigHeight
190+
178: If sngTop < clsAnchor.MinimumTop Then sngTop = clsAnchor.MinimumTop
191+
179: If sngTop < 0 Then sngTop = 0
192+
180: cntTemp.top = sngTop
193+
181: End If
194+
182: If ((clsAnchor.AnchorStyle And enumAnchorStyleLeft) = enumAnchorStyleLeft) And _
195+
((clsAnchor.AnchorStyle And enumAnchorStyleRight) = enumAnchorStyleRight) Then
196+
184: ' maintain gap between left and right edges by adjusting Width
197+
185: sngWidth = m_frmParent.InsideWidth - (OrigWidth - clsAnchor.OrigLeft - clsAnchor.OrigWidth) - clsAnchor.OrigLeft
198+
186: If sngWidth < clsAnchor.MinimumWidth Then sngWidth = clsAnchor.MinimumWidth
199+
187: If sngWidth < 0 Then sngWidth = 0
200+
188: cntTemp.Width = sngWidth
201+
189: ElseIf (clsAnchor.AnchorStyle And enumAnchorStyleLeft) = enumAnchorStyleLeft Then
202+
190: ' maintain gap between left leave Width alone
203+
191: ' does not require code
204+
192: ElseIf (clsAnchor.AnchorStyle And enumAnchorStyleRight) = enumAnchorStyleRight Then
205+
193: ' maintain gap between Right leave Width alone
206+
194: sngLeft = m_frmParent.InsideWidth - (OrigWidth - clsAnchor.OrigLeft - clsAnchor.OrigWidth) - clsAnchor.OrigWidth
207+
195: If sngLeft < clsAnchor.MinimumLeft Then sngLeft = clsAnchor.MinimumLeft
208+
196: If sngLeft < 0 Then sngLeft = 0
209+
197: cntTemp.Left = sngLeft
210+
198: End If
211+
199: End If
212+
200: Next
213+
201: DoEvents
214+
202: End Sub

‎scripts/ModShow.bas

+14
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
Attribute VB_Name = "ModShow"
2+
Option Explicit
3+
4+
Public Enum enumAnchorStyles
5+
enumAnchorStyleNone = 0
6+
enumAnchorStyleTop = 1
7+
enumAnchorStyleBottom = 2
8+
enumAnchorStyleLeft = 4
9+
enumAnchorStyleRight = 8
10+
End Enum
11+
12+
Sub MainShow()
13+
frmMain.Show
14+
End Sub

‎scripts/frmMain.frm

+51
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,51 @@
1+
VERSION 5.00
2+
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmMain
3+
Caption = "VBATools.ru"
4+
ClientHeight = 5250
5+
ClientLeft = 45
6+
ClientTop = 390
7+
ClientWidth = 3960
8+
OleObjectBlob = "frmMain.frx":0000
9+
StartUpPosition = 1 'CenterOwner
10+
End
11+
Attribute VB_Name = "frmMain"
12+
Attribute VB_GlobalNameSpace = False
13+
Attribute VB_Creatable = False
14+
Attribute VB_PredeclaredId = True
15+
Attribute VB_Exposed = False
16+
Option Explicit
17+
Private m_clsAnchorsEditAdd As CAnchors
18+
19+
Private Sub CommandButton1_Click()
20+
Unload Me
21+
End Sub
22+
23+
Private Sub UserForm_Initialize()
24+
'íàñòðîéêè ôîðìû
25+
Call AddCAnchors
26+
End Sub
27+
28+
Private Sub AddCAnchors()
29+
Set m_clsAnchorsEditAdd = New CAnchors
30+
Set m_clsAnchorsEditAdd.objParent = Me
31+
' çàäàíèå ìèíèìàëüíûõ ðàçìåðîâ ôîðìû
32+
m_clsAnchorsEditAdd.MinimumWidth = Me.Width
33+
m_clsAnchorsEditAdd.MinimumHeight = Me.Height
34+
'íàñòðîéêà ýëåìåíòîâ ôîðì
35+
With m_clsAnchorsEditAdd
36+
.funAnchor("TextBox1").AnchorStyle = enumAnchorStyleTop Or enumAnchorStyleRight Or enumAnchorStyleLeft
37+
.funAnchor("TextBox2").AnchorStyle = enumAnchorStyleTop Or enumAnchorStyleRight Or enumAnchorStyleLeft Or enumAnchorStyleBottom
38+
.funAnchor("CommandButton1").AnchorStyle = enumAnchorStyleRight Or enumAnchorStyleBottom
39+
End With
40+
End Sub
41+
42+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
43+
'* Sub : UserForm_Terminate - óíè÷òîæåíèå êëàññà
44+
'* Created : 09-11-2020 10:35
45+
'* Author : VBATools
46+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
47+
'* Copyright : VBATools.ru
48+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
49+
Private Sub UserForm_Terminate()
50+
Set m_clsAnchorsEditAdd = Nothing
51+
End Sub

0 commit comments

Comments
 (0)