Skip to content

Commit c613b06

Browse files
vbatoolsvbatools
committed
Update M_MoveControl.bas
1 parent 6e0550d commit c613b06

File tree

1 file changed

+147
-124
lines changed

1 file changed

+147
-124
lines changed

‎scripts/Modules/M_MoveControl.bas‎

Lines changed: 147 additions & 124 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ Attribute VB_Name = "M_MoveControl"
99

1010
Option Explicit
1111
Option Private Module
12-
Public sTagNameConrol As String
12+
Public sTagNameConrol As String
1313
Public tpStyle As ProperControlStyle
1414
Type ProperControlStyle
1515
sError As String
@@ -35,6 +35,10 @@ Type ProperControlStyle
3535
sFontName As String
3636
cuFontSize As Currency
3737
End Type
38+
39+
Public Sub HelpMoveControl()
40+
Call URLLinks(C_Const.URL_MOVE_CNTR)
41+
End Sub
3842
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3943
'* Sub : MoveControl - Ìèêðîïîäñòðîéêà ýëåìåíòîâ ôîðìû
4044
'* Created : 08-10-2020 14:10
@@ -43,11 +47,12 @@ End Type
4347
'* Copyright : VBATools.ru
4448
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
4549
Private Sub MoveControl()
50+
If Application.VBE.ActiveWindow.Type <> vbext_wt_Designer Then Exit Sub
4651
Dim myCommandBar As CommandBar
47-
Dim cntrl As CommandBarControl
48-
Dim combox As CommandBarComboBox
52+
Dim cntrl As CommandBarControl
53+
Dim combox As CommandBarComboBox
4954
Dim sComBoxText As String
50-
Dim cnt As control
55+
Dim cnt As control
5156

5257
Set myCommandBar = Application.VBE.CommandBars(C_Const.MENUMOVECONTRL)
5358
For Each cntrl In myCommandBar.Controls
@@ -58,18 +63,22 @@ Private Sub MoveControl()
5863
End If
5964
Next cntrl
6065

61-
Set cnt = TakeSelectControl
62-
If cnt Is Nothing Then Exit Sub
63-
Select Case sTagNameConrol
64-
Case C_Const.MTAG1:
65-
Call MoveCnt(cnt, 1, sComBoxText)
66-
Case C_Const.MTAG2:
67-
Call MoveCnt(cnt, 2, sComBoxText)
68-
Case C_Const.MTAG3:
69-
Call MoveCnt(cnt, 3, sComBoxText)
70-
Case C_Const.MTAG4:
71-
Call MoveCnt(cnt, 4, sComBoxText)
72-
End Select
66+
Dim objActiveModule As VBComponent
67+
Set objActiveModule = getActiveModule()
68+
For Each cnt In objActiveModule.Designer.Selected
69+
If Not cnt Is Nothing Then
70+
Select Case sTagNameConrol
71+
Case C_Const.MTAG1:
72+
Call MoveCnt(cnt, 1, sComBoxText)
73+
Case C_Const.MTAG2:
74+
Call MoveCnt(cnt, 2, sComBoxText)
75+
Case C_Const.MTAG3:
76+
Call MoveCnt(cnt, 3, sComBoxText)
77+
Case C_Const.MTAG4:
78+
Call MoveCnt(cnt, 4, sComBoxText)
79+
End Select
80+
End If
81+
Next cnt
7382
End Sub
7483
Private Sub MoveCnt(ByRef cnt As control, ByVal iVal As Integer, ByVal sComBoxText As String)
7584
Const Shag = 0.4
@@ -116,44 +125,6 @@ Private Sub MoveCnt(ByRef cnt As control, ByVal iVal As Integer, ByVal sComBoxTe
116125
End With
117126
End Sub
118127

119-
Private Function TakeSelectControl(Optional bUserForm As Boolean = False) As Object
120-
Dim W As VBIDE.Window
121-
Dim strVar() As String
122-
Dim cntName As String
123-
124-
On Error GoTo ErrorHandler
125-
126-
If Application.VBE.ActiveWindow.Type = vbext_wt_Designer Then
127-
For Each W In Application.VBE.Windows
128-
If W.Type = vbext_wt_PropertyWindow Then
129-
strVar = Split(W.Caption, "-")
130-
cntName = Trim(strVar(1))
131-
Exit For
132-
End If
133-
Next
134-
135-
Dim Form As UserForm
136-
Set Form = Application.VBE.SelectedVBComponent.Designer
137-
Set TakeSelectControl = Form.Controls(cntName)
138-
End If
139-
Exit Function
140-
ErrorHandler:
141-
If bUserForm And Not Form Is Nothing Then
142-
Err.Clear
143-
Set TakeSelectControl = Form
144-
Exit Function
145-
End If
146-
Select Case Err.Number
147-
Case -2147024809:
148-
Debug.Print "Mistake! Select one object"
149-
Case 9:
150-
Debug.Print "To use the tool, open the View -> Properties Window"
151-
Case Else:
152-
Debug.Print "Mistake! in TakeSelectControl" & vbLf & Err.Number & vbLf & Err.Description & vbCrLf & "in the line" & Erl
153-
Call WriteErrorLog("TakeSelectControl")
154-
End Select
155-
Err.Clear
156-
End Function
157128
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
158129
'* Sub : RenameControl - ïåðåèìåíîâàíèå êîíòîðîë íà ôîðìå âìåñòå ñêîäîì
159130
'* Created : 08-10-2020 14:11
@@ -162,18 +133,18 @@ End Function
162133
'* Copyright : VBATools.ru
163134
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
164135
Private Sub RenameControl()
165-
Dim cnt As control
166-
Dim sNewName As String
167-
Dim sOldName As String
136+
Dim cnt As control
137+
Dim sNewName As String
138+
Dim sOldName As String
168139
Dim NameModeCode As String
169-
Dim strVar As String
170-
Dim CodeMod As CodeModule
140+
Dim strVar As String
141+
Dim CodeMod As CodeModule
171142

172143
On Error GoTo ErrorHandler
173144

174145
Set cnt = TakeSelectControl
175146
If cnt Is Nothing Then Exit Sub
176-
tryagin:
147+
177148
sOldName = cnt.Name
178149
sNewName = InputBox("Enter a new name Control", "Renaming Control:", sOldName)
179150
If sNewName = vbNullString Or sNewName = sOldName Then Exit Sub
@@ -182,7 +153,6 @@ tryagin:
182153
Set CodeMod = Application.VBE.SelectedVBComponent.CodeModule
183154
With CodeMod
184155
strVar = .Lines(1, .CountOfLines)
185-
'strVar = Replace(strVar, sOldName, sNewName)
186156
strVar = ReplceCode(strVar, sOldName, sNewName)
187157
.DeleteLines StartLine:=1, Count:=.CountOfLines
188158
.InsertLines Line:=1, String:=strVar
@@ -238,39 +208,44 @@ Public Sub CopyStyleControl()
238208
End With
239209
End Sub
240210
Public Sub PasteStyleControl()
241-
Dim cnt As Object
242-
Set cnt = TakeSelectControl(True)
243-
If cnt Is Nothing Then Exit Sub
244-
On Error Resume Next
245-
With cnt
246-
.Enabled = tpStyle.bEnabled
247-
.Font.Bold = tpStyle.bFontBold
248-
.Font.Italic = tpStyle.bFontItalic
249-
.Font.Strikethrough = tpStyle.bFontStrikethru
250-
.Font.Underline = tpStyle.bFontUnderline
251-
.Locked = tpStyle.bLocked
252-
.visible = tpStyle.bVisible
253-
.Font.Size = tpStyle.cuFontSize
254-
.BackColor = tpStyle.lBackColor
255-
.ForeColor = tpStyle.lForeColor
256-
.Font.Name = tpStyle.sFontName
257-
If tpStyle.snHeight > 0 Then .Height = tpStyle.snHeight
258-
If tpStyle.snWidth > 0 Then .Width = tpStyle.snWidth
259-
260-
.BackStyle = tpStyle.lBackStyle
261-
.BorderColor = tpStyle.lBorderColor
262-
.BorderStyle = tpStyle.lBorderStyle
263-
End With
211+
If Application.VBE.ActiveWindow.Type <> vbext_wt_Designer Then Exit Sub
212+
Dim objActiveModule As VBComponent
213+
Dim cnt As control
214+
Set objActiveModule = getActiveModule()
215+
For Each cnt In objActiveModule.Designer.Selected
216+
On Error Resume Next
217+
With cnt
218+
.Enabled = tpStyle.bEnabled
219+
.Font.Bold = tpStyle.bFontBold
220+
.Font.Italic = tpStyle.bFontItalic
221+
.Font.Strikethrough = tpStyle.bFontStrikethru
222+
.Font.Underline = tpStyle.bFontUnderline
223+
.Locked = tpStyle.bLocked
224+
.visible = tpStyle.bVisible
225+
.Font.Size = tpStyle.cuFontSize
226+
.BackColor = tpStyle.lBackColor
227+
.ForeColor = tpStyle.lForeColor
228+
.Font.Name = tpStyle.sFontName
229+
If tpStyle.snHeight > 0 Then .Height = tpStyle.snHeight
230+
If tpStyle.snWidth > 0 Then .Width = tpStyle.snWidth
231+
232+
.BackStyle = tpStyle.lBackStyle
233+
.BorderColor = tpStyle.lBorderColor
234+
.BorderStyle = tpStyle.lBorderStyle
235+
End With
236+
On Error GoTo 0
237+
Next cnt
238+
264239
End Sub
265240
Public Sub AddIcon()
266-
Dim cnt As control
267-
Dim objForm As InsertIconUserForm
241+
Dim cnt As control
242+
Dim objForm As InsertIconUserForm
268243

269244
On Error GoTo ErrorHandler
270245

271246
Set cnt = TakeSelectControl
272247
If cnt Is Nothing Then Exit Sub
273-
248+
274249
Set objForm = New InsertIconUserForm
275250
With objForm
276251
.Show
@@ -292,59 +267,107 @@ ErrorHandler:
292267
End Select
293268
Err.Clear
294269
End Sub
295-
Public Sub HelpMoveControl()
296-
Call URLLinks(C_Const.URL_MOVE_CNTR)
297-
End Sub
298-
299270
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
300-
'* Sub : UperTextInControl - èçìåíåíèå ðåãèñòðîâ ó êîíòðîëëîâ íà ôîðìå
301-
'* Created : 13-04-2021 09:46
271+
'* Sub : UperTextInControl
272+
'* Created : 01-07-2022 11:12
302273
'* Author : VBATools
303274
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
304275
'* Copyright : VBATools.ru
305276
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
306277
Public Sub UperTextInControl()
307-
Dim oCont As Object
308-
Set oCont = TakeSelectControl
309-
If oCont Is Nothing Then Exit Sub
310-
311-
If PropertyIsCapiton(oCont, True) Then
312-
oCont.Caption = VBA.UCase$(oCont.Caption)
313-
End If
314-
If PropertyIsCapiton(oCont, False) Then
315-
oCont.Text = VBA.UCase$(oCont.Text)
316-
End If
317-
278+
Call LowerAndUperTextInControl(True)
318279
End Sub
319280
Public Sub LowerTextInControl()
320-
Dim oCont As Object
321-
Set oCont = TakeSelectControl
322-
If oCont Is Nothing Then Exit Sub
323-
324-
If PropertyIsCapiton(oCont, True) Then
325-
oCont.Caption = VBA.LCase$(oCont.Caption)
326-
End If
327-
If PropertyIsCapiton(oCont, False) Then
328-
oCont.Text = VBA.LCase$(oCont.Text)
281+
Call LowerAndUperTextInControl(False)
282+
End Sub
283+
Private Sub LowerAndUperTextInControl(ByVal bUCase As Boolean)
284+
If Application.VBE.ActiveWindow.Type = vbext_wt_Designer Then
285+
Dim objActiveModule As VBComponent
286+
Set objActiveModule = getActiveModule()
287+
If Not objActiveModule Is Nothing Then
288+
If getSelectedControlsCollection.Count > 0 Then
289+
Dim ctl As control
290+
On Error Resume Next
291+
For Each ctl In objActiveModule.Designer.Selected
292+
If bUCase Then
293+
Call CallByName(ctl, "Caption", VbLet, VBA.UCase$(CallByName(ctl, "Caption", VbGet)))
294+
Else
295+
Call CallByName(ctl, "Caption", VbLet, VBA.LCase$(CallByName(ctl, "Caption", VbGet)))
296+
End If
297+
Next ctl
298+
On Error GoTo 0
299+
End If
300+
End If
329301
End If
330-
331302
End Sub
332-
333303
Public Sub UperTextInForm()
334-
Dim oVBComp As VBIDE.VBComponent
335-
Set oVBComp = Application.VBE.SelectedVBComponent
336-
With oVBComp
337-
If .Type = vbext_ct_MSForm Then
338-
.Properties("Caption") = VBA.UCase$(.Properties("Caption"))
339-
End If
340-
End With
304+
Call LowerAndUperTextInForm(True)
341305
End Sub
342306
Public Sub LowerTextInForm()
343-
Dim oVBComp As VBIDE.VBComponent
307+
Call LowerAndUperTextInForm(False)
308+
End Sub
309+
Private Sub LowerAndUperTextInForm(ByVal bUCase As Boolean)
310+
Dim oVBComp As VBIDE.VBComponent
344311
Set oVBComp = Application.VBE.SelectedVBComponent
345312
With oVBComp
346313
If .Type = vbext_ct_MSForm Then
347-
.Properties("Caption") = VBA.LCase$(.Properties("Caption"))
314+
If bUCase Then
315+
.Properties("Caption") = VBA.UCase$(.Properties("Caption"))
316+
Else
317+
.Properties("Caption") = VBA.LCase$(.Properties("Caption"))
318+
End If
348319
End If
349320
End With
350321
End Sub
322+
'* îáùèå ôóíêöèè**********************************************************
323+
Private Function TakeSelectControl(Optional bUserForm As Boolean = False) As Object
324+
On Error GoTo ErrorHandler
325+
If Application.VBE.ActiveWindow.Type = vbext_wt_Designer Then
326+
Dim objActiveModule As VBComponent
327+
Set objActiveModule = getActiveModule()
328+
If Not objActiveModule Is Nothing Then
329+
If getSelectedControlsCollection.Count = 1 Then
330+
Dim ctl As control
331+
For Each ctl In objActiveModule.Designer.Selected
332+
Set TakeSelectControl = ctl
333+
Exit Function
334+
Next ctl
335+
End If
336+
End If
337+
End If
338+
339+
Dim Form As UserForm
340+
Set Form = Application.VBE.SelectedVBComponent.Designer
341+
If bUserForm And Not Form Is Nothing Then
342+
Set TakeSelectControl = Form
343+
Exit Function
344+
End If
345+
346+
Exit Function
347+
ErrorHandler:
348+
Select Case Err.Number
349+
Case 9:
350+
Debug.Print "To use the tool, open the View -> Properties Window"
351+
Case Else:
352+
Debug.Print "Mistake! in TakeSelectControl" & vbLf & Err.Number & vbLf & Err.Description & vbCrLf & "in the line" & Erl
353+
Call WriteErrorLog("TakeSelectControl")
354+
End Select
355+
Err.Clear
356+
End Function
357+
Public Function getSelectedControlsCollection() As Collection
358+
Dim ctl As control
359+
Dim out As New Collection
360+
Dim Module As VBComponent
361+
Set Module = getActiveModule
362+
For Each ctl In Module.Designer.Selected
363+
out.Add ctl
364+
Next ctl
365+
Set getSelectedControlsCollection = out
366+
Set out = Nothing
367+
End Function
368+
Public Function getActiveModule() As VBComponent
369+
Set getActiveModule = Application.VBE.SelectedVBComponent
370+
End Function
371+
372+
373+

0 commit comments

Comments
 (0)