Skip to content

Commit 3145d28

Browse files
vbatoolsvbatools
committed
add file
1 parent 7255415 commit 3145d28

File tree

7 files changed

+261
-0
lines changed

7 files changed

+261
-0
lines changed

‎MsgBoxEx.xlsm‎

38.1 KB
Binary file not shown.

‎scripts/clsTglAndOpt.cls‎

Lines changed: 40 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,40 @@
1+
VERSION 1.0 CLASS
2+
BEGIN
3+
MultiUse = -1 'True
4+
END
5+
Attribute VB_Name = "clsTglAndOpt"
6+
Attribute VB_GlobalNameSpace = False
7+
Attribute VB_Creatable = False
8+
Attribute VB_PredeclaredId = False
9+
Attribute VB_Exposed = False
10+
Option Explicit
11+
12+
Public WithEvents tg As MSForms.ToggleButton
13+
Attribute tg.VB_VarHelpID = -1
14+
Public WithEvents ob As MSForms.OptionButton
15+
Attribute ob.VB_VarHelpID = -1
16+
17+
Private Sub ob_Click()
18+
If bTglBusy Then Exit Sub
19+
i = Mid$(ob.Name, 3)
20+
'if another optionButton is selected, select first toggleButton in row
21+
If i <> lRow Then
22+
lRow = i
23+
frm.Controls("tg" & i & "1") = True
24+
End If
25+
End Sub
26+
27+
Private Sub tg_Change()
28+
If bTglBusy Then Exit Sub
29+
bTglBusy = True
30+
'if user clicks already selected toggleButton
31+
If tg Is oSelTgl Then tg = True: bTglBusy = False: Exit Sub
32+
oSelTgl = False
33+
Set oSelTgl = tg
34+
lRow = Mid$(tg.Name, 3, 1)
35+
lCol = Right$(tg.Name, 1)
36+
'switch on related optionButton
37+
frm.Controls("ob" & lRow) = True
38+
bTglBusy = False
39+
End Sub
40+

‎scripts/frmForm.frm‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
VERSION 5.00
2+
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmForm
3+
Caption = "VBATools.ru"
4+
ClientHeight = 2025
5+
ClientLeft = 45
6+
ClientTop = 390
7+
ClientWidth = 4710
8+
OleObjectBlob = "frmForm.frx":0000
9+
StartUpPosition = 1 'CenterOwner
10+
End
11+
Attribute VB_Name = "frmForm"
12+
Attribute VB_GlobalNameSpace = False
13+
Attribute VB_Creatable = False
14+
Attribute VB_PredeclaredId = True
15+
Attribute VB_Exposed = False
16+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
17+
'* Module : frmForm
18+
'* Created : 13-01-2021 14:17
19+
'* Author : VBATools
20+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
21+
'* Copyright : VBATools.ru
22+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
23+
24+
Option Explicit
25+
26+
Dim Time_when_me_close As Single
27+
'
28+
29+
Private Sub CommandButton1_Click()
30+
Time_when_me_close = 0 '÷òîáû âûéòè èç öèêëà äîñðî÷íî
31+
End Sub
32+
33+
Private Sub TextBox1_Change()
34+
Time_when_me_close = Time_when_me_close + VBA.CInt(TextBox1.Value)
35+
End Sub
36+
37+
Private Sub UserForm_Activate()
38+
Time_when_me_close = Timer + 5 'ñïðÿ÷åì ÷åðåç 5 ñåê
39+
Do
40+
DoEvents
41+
Label3.Caption = VBA.Round(Time_when_me_close - Timer, 1)
42+
Loop Until Timer > Time_when_me_close
43+
Unload Me
44+
End Sub
45+
46+
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
47+
Time_when_me_close = 0 '÷òîáû âûéòè èç öèêëà äîñðî÷íî
48+
End Sub

‎scripts/frmMsgBox.frm‎

Lines changed: 84 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,84 @@
1+
VERSION 5.00
2+
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmMsgBox
3+
Caption = "MsgBoxExt Demonstration VBATools.ru"
4+
ClientHeight = 6150
5+
ClientLeft = 45
6+
ClientTop = 330
7+
ClientWidth = 8490
8+
OleObjectBlob = "frmMsgBox.frx":0000
9+
StartUpPosition = 1 'CenterOwner
10+
End
11+
Attribute VB_Name = "frmMsgBox"
12+
Attribute VB_GlobalNameSpace = False
13+
Attribute VB_Creatable = False
14+
Attribute VB_PredeclaredId = True
15+
Attribute VB_Exposed = False
16+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
17+
'* Module : frmMain
18+
'* Created : 13-01-2021 11:32
19+
'* Author : VBATools
20+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
21+
'* Copyright : VBATools.ru
22+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
23+
Option Explicit
24+
25+
Private Sub btQuit_Click()
26+
Unload Me
27+
End Sub
28+
29+
Private Sub btRun_Click()
30+
Dim result
31+
32+
i = Choose(lRow, vbOKOnly, vbOKCancel, vbYesNo, vbYesNoCancel, vbAbortRetryIgnore, vbRetryCancel)
33+
i = i + cbIcon
34+
i = i + Choose(lCol, vbDefaultButton1, vbDefaultButton2, vbDefaultButton3)
35+
36+
result = MsgBoxEx(tbText, i, tbTitle, tbSec)
37+
Select Case result
38+
Case vbAbort: result = "Abort"
39+
Case vbCancel: result = "Cancel"
40+
Case vbIgnore: result = "Ignore"
41+
Case vbNo: result = "No"
42+
Case vbOK: result = "OK"
43+
Case vbRetry: result = "Retry"
44+
Case vbYes: result = "Yes"
45+
Case -1: result = "Timeout"
46+
Case Else: result = "Unknown: " & result
47+
End Select
48+
tbResult = result
49+
End Sub
50+
51+
52+
Private Sub UserForm_Initialize()
53+
54+
Static clControls As New Collection
55+
Dim ctrl
56+
With clControls
57+
For Each ctrl In frButtons.Controls
58+
.Add New clsTglAndOpt
59+
If TypeOf ctrl Is MSForms.OptionButton Then
60+
Set .Item(.Count).ob = ctrl
61+
ElseIf TypeOf ctrl Is MSForms.ToggleButton Then
62+
Set .Item(.Count).tg = ctrl
63+
Else: .Remove (.Count)
64+
End If
65+
Next
66+
End With
67+
68+
ReDim arr(0 To 4, 0 To 1)
69+
arr(0, 0) = "(none)"
70+
arr(1, 0) = "Exclamation": arr(1, 1) = vbExclamation
71+
arr(2, 0) = "Information": arr(2, 1) = vbInformation
72+
arr(3, 0) = "Question": arr(3, 1) = vbQuestion
73+
arr(4, 0) = "Critical": arr(4, 1) = vbCritical
74+
With cbIcon
75+
.List = arr
76+
.ListIndex = 2
77+
End With
78+
79+
Set frm = Me
80+
Set oSelTgl = tg11
81+
lRow = 1
82+
lCol = 1
83+
84+
End Sub

‎scripts/modMsgBoxEx.bas‎

Lines changed: 71 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,71 @@
1+
Attribute VB_Name = "modMsgBoxEx"
2+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
3+
'* Module : modMsgBoxEx
4+
'* Created : 13-01-2021 11:32
5+
'* Author : VBATools
6+
'* Contacts : http://vbatools.ru/ https://vk.com/vbatools
7+
'* Copyright : VBATools.ru
8+
'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
9+
Option Explicit
10+
11+
Public Function MsgBoxEx(Prompt, Optional Buttons As VbMsgBoxStyle = 0, Optional Title, Optional SecondsToWait = 0) As VbMsgBoxResult
12+
'---------------------------------------------------------------------------------------
13+
' Procedure : MsgBoxEx
14+
' Purpose : MsgBox with timeout based on WScript.Shell Popup method. Creates .VBS file
15+
' in temporary folder, runs it, returns result code, deletes the file.
16+
' Arguments : First three are the same as for MsgBox, 4-th is timeout in seconds.
17+
' : If 4-th arg. is omitted or <=0 then waits for user action infinitely.
18+
' Ret.Value : The same as of Msgbox, -1 if timeout occured.
19+
' Errors : Raises error 735 if temporary folder can't be found.
20+
21+
'Íàçíà÷åíèå : MsgBox ñ òàéìàóòîì íà îñíîâå WScript.Shell âñïëûâàþùåãî îêíà îáîëî÷êè. Ñîçäàåò Ôàéë .VBS
22+
' - âî âðåìåííîé ïàïêå, çàïóñêàåò åãî, âîçâðàùàåò êîä ðåçóëüòàòà, óäàëÿåò ôàéë.
23+
'Àðãóìåíòû : ïåðâûå òðè òàêèå æå, êàê è äëÿ MsgBox, 4-é-ýòî òàéì-àóò â ñåêóíäàõ.
24+
' : Åñëè 4-é àðã. îïóùåí èëè <=0, à çàòåì áåñêîíå÷íî æäåò äåéñòâèé ïîëüçîâàòåëÿ.
25+
'Ret. Value : òî æå ñàìîå, ÷òî è â Msgbox, -1, åñëè ïðîèçîøåë òàéì-àóò.
26+
'Îøèáêè : âûçûâàåò îøèáêó 735, åñëè âðåìåííàÿ ïàïêà íå ìîæåò áûòü íàéäåíà.
27+
'---------------------------------------------------------------------------------------
28+
29+
Dim sTmp$, ff%, WshShell As Object
30+
Set WshShell = CreateObject("WScript.Shell")
31+
sTmp = Environ("temp")
32+
If sTmp = "" Then
33+
sTmp = Environ("tmp")
34+
If sTmp = "" Then
35+
sTmp = WshShell.SpecialFolders("MyDocuments")
36+
If sTmp = "" Then Err.Raise 735 'Can't save file to TEMP directory
37+
End If
38+
End If
39+
sTmp = sTmp & Format$(Now, """\~MsgBoxEx""YYMMDDHHMMSS"".vbs""")
40+
ff = FreeFile
41+
Open sTmp For Output As ff
42+
43+
If IsMissing(Title) Then Title = ""
44+
45+
'Popup(<Text>,<SecondsToWait>,<Title>,<Type>)
46+
47+
Print #ff, "WScript.Quit CreateObject(""WScript.Shell"").Popup (""" & Str2Code(Prompt) & _
48+
""", " & Int(SecondsToWait) & ", """ & Str2Code(Title) & """, " & Int(Buttons) & ")"
49+
Close ff
50+
MsgBoxEx = WshShell.Run(sTmp, 0, True)
51+
On Error Resume Next
52+
Kill sTmp
53+
End Function
54+
55+
Private Function Str2Code$(s)
56+
'---------------------------------------------------------------------------------------
57+
' Procedure : Str2Code
58+
' Purpose : Replaces combinations CR+LF, LF+CR, single chars CR, LF with " & vblf & "
59+
' to be used in VBS code
60+
'---------------------------------------------------------------------------------------
61+
62+
Str2Code = Replace$( _
63+
Replace$( _
64+
Replace$( _
65+
Replace$( _
66+
Replace$(s, """", """"""), _
67+
vbCrLf, vbLf), _
68+
vbLf & vbCr, vbLf), _
69+
vbCr, vbLf), _
70+
vbLf, """ & vblf & """)
71+
End Function

‎scripts/modPublicVars.bas‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
Attribute VB_Name = "modPublicVars"
2+
Option Explicit
3+
4+
Public lRow& 'row of active toggleButton & optionButton
5+
Public lCol& 'column of active toggleButton
6+
Public i& 'temp
7+
Public bTglBusy As Boolean 'flag to skip event handling
8+
Public oSelTgl As MSForms.ToggleButton 'selected toggleButton
9+
Public frm As MSForms.UserForm

‎scripts/modRunForm.bas‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,9 @@
1+
Attribute VB_Name = "modRunForm"
2+
Option Explicit
3+
4+
Sub RunFormMsgBox()
5+
frmMsgBox.Show
6+
End Sub
7+
Sub RunForm()
8+
frmForm.Show
9+
End Sub

0 commit comments

Comments
 (0)