add file

vbatools · Apr 25, 2021 · 3145d28 · 3145d28
1 parent 7255415
commit 3145d28
Show file tree

Hide file tree

Showing 7 changed files with 261 additions and 0 deletions.
diff --git a/MsgBoxEx.xlsm b/MsgBoxEx.xlsm
diff --git a/scripts/clsTglAndOpt.cls b/scripts/clsTglAndOpt.cls
@@ -0,0 +1,40 @@
+VERSION 1.0 CLASS
+BEGIN
+  MultiUse = -1  'True
+END
+Attribute VB_Name = "clsTglAndOpt"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = False
+Attribute VB_Exposed = False
+Option Explicit
+
+Public WithEvents tg As MSForms.ToggleButton
+Attribute tg.VB_VarHelpID = -1
+Public WithEvents ob As MSForms.OptionButton
+Attribute ob.VB_VarHelpID = -1
+
+Private Sub ob_Click()
+    If bTglBusy Then Exit Sub
+    i = Mid$(ob.Name, 3)
+    'if another optionButton is selected, select first toggleButton in row
+    If i <> lRow Then
+        lRow = i
+        frm.Controls("tg" & i & "1") = True
+    End If
+End Sub
+
+Private Sub tg_Change()
+    If bTglBusy Then Exit Sub
+    bTglBusy = True
+    'if user clicks already selected toggleButton
+    If tg Is oSelTgl Then tg = True: bTglBusy = False: Exit Sub
+    oSelTgl = False
+    Set oSelTgl = tg
+    lRow = Mid$(tg.Name, 3, 1)
+    lCol = Right$(tg.Name, 1)
+    'switch on related optionButton
+    frm.Controls("ob" & lRow) = True
+    bTglBusy = False
+End Sub
+
diff --git a/scripts/frmForm.frm b/scripts/frmForm.frm
@@ -0,0 +1,48 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmForm 
+   Caption         =   "VBATools.ru"
+   ClientHeight    =   2025
+   ClientLeft      =   45
+   ClientTop       =   390
+   ClientWidth     =   4710
+   OleObjectBlob   =   "frmForm.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "frmForm"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+'* Module     : frmForm
+'* Created    : 13-01-2021 14:17
+'* Author     : VBATools
+'* Contacts   : http://vbatools.ru/ https://vk.com/vbatools
+'* Copyright  : VBATools.ru
+'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+
+Option Explicit
+
+Dim Time_when_me_close As Single
+'
+
+Private Sub CommandButton1_Click()
+    Time_when_me_close = 0    '÷òîáû âûéòè èç öèêëà äîñðî÷íî
+End Sub
+
+Private Sub TextBox1_Change()
+    Time_when_me_close = Time_when_me_close + VBA.CInt(TextBox1.Value)
+End Sub
+
+Private Sub UserForm_Activate()
+    Time_when_me_close = Timer + 5    'ñïðÿ÷åì ÷åðåç 5 ñåê
+    Do
+        DoEvents
+        Label3.Caption = VBA.Round(Time_when_me_close - Timer, 1)
+    Loop Until Timer > Time_when_me_close
+    Unload Me
+End Sub
+
+Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
+    Time_when_me_close = 0    '÷òîáû âûéòè èç öèêëà äîñðî÷íî
+End Sub
diff --git a/scripts/frmMsgBox.frm b/scripts/frmMsgBox.frm
@@ -0,0 +1,84 @@
+VERSION 5.00
+Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} frmMsgBox 
+   Caption         =   "MsgBoxExt Demonstration VBATools.ru"
+   ClientHeight    =   6150
+   ClientLeft      =   45
+   ClientTop       =   330
+   ClientWidth     =   8490
+   OleObjectBlob   =   "frmMsgBox.frx":0000
+   StartUpPosition =   1  'CenterOwner
+End
+Attribute VB_Name = "frmMsgBox"
+Attribute VB_GlobalNameSpace = False
+Attribute VB_Creatable = False
+Attribute VB_PredeclaredId = True
+Attribute VB_Exposed = False
+'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+'* Module     : frmMain
+'* Created    : 13-01-2021 11:32
+'* Author     : VBATools
+'* Contacts   : http://vbatools.ru/ https://vk.com/vbatools
+'* Copyright  : VBATools.ru
+'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+Option Explicit
+
+Private Sub btQuit_Click()
+    Unload Me
+End Sub
+
+Private Sub btRun_Click()
+    Dim result
+
+    i = Choose(lRow, vbOKOnly, vbOKCancel, vbYesNo, vbYesNoCancel, vbAbortRetryIgnore, vbRetryCancel)
+    i = i + cbIcon
+    i = i + Choose(lCol, vbDefaultButton1, vbDefaultButton2, vbDefaultButton3)
+
+    result = MsgBoxEx(tbText, i, tbTitle, tbSec)
+    Select Case result
+        Case vbAbort: result = "Abort"
+        Case vbCancel: result = "Cancel"
+        Case vbIgnore: result = "Ignore"
+        Case vbNo: result = "No"
+        Case vbOK: result = "OK"
+        Case vbRetry: result = "Retry"
+        Case vbYes: result = "Yes"
+        Case -1: result = "Timeout"
+        Case Else: result = "Unknown: " & result
+    End Select
+    tbResult = result
+End Sub
+
+
+Private Sub UserForm_Initialize()
+
+    Static clControls As New Collection
+    Dim ctrl
+    With clControls
+        For Each ctrl In frButtons.Controls
+            .Add New clsTglAndOpt
+            If TypeOf ctrl Is MSForms.OptionButton Then
+                Set .Item(.Count).ob = ctrl
+            ElseIf TypeOf ctrl Is MSForms.ToggleButton Then
+                Set .Item(.Count).tg = ctrl
+            Else: .Remove (.Count)
+            End If
+        Next
+    End With
+
+    ReDim arr(0 To 4, 0 To 1)
+    arr(0, 0) = "(none)"
+    arr(1, 0) = "Exclamation": arr(1, 1) = vbExclamation
+    arr(2, 0) = "Information": arr(2, 1) = vbInformation
+    arr(3, 0) = "Question": arr(3, 1) = vbQuestion
+    arr(4, 0) = "Critical": arr(4, 1) = vbCritical
+    With cbIcon
+        .List = arr
+        .ListIndex = 2
+    End With
+
+    Set frm = Me
+    Set oSelTgl = tg11
+    lRow = 1
+    lCol = 1
+
+End Sub
diff --git a/scripts/modMsgBoxEx.bas b/scripts/modMsgBoxEx.bas
@@ -0,0 +1,71 @@
+Attribute VB_Name = "modMsgBoxEx"
+'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+'* Module     : modMsgBoxEx
+'* Created    : 13-01-2021 11:32
+'* Author     : VBATools
+'* Contacts   : http://vbatools.ru/ https://vk.com/vbatools
+'* Copyright  : VBATools.ru
+'* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
+Option Explicit
+
+Public Function MsgBoxEx(Prompt, Optional Buttons As VbMsgBoxStyle = 0, Optional Title, Optional SecondsToWait = 0) As VbMsgBoxResult
+    '---------------------------------------------------------------------------------------
+    ' Procedure : MsgBoxEx
+    ' Purpose   : MsgBox with timeout based on WScript.Shell Popup method. Creates .VBS file
+    '             in temporary folder, runs it, returns result code, deletes the file.
+    ' Arguments : First three are the same as for MsgBox, 4-th is timeout in seconds.
+    '           : If 4-th arg. is omitted or <=0 then waits for user action infinitely.
+    ' Ret.Value : The same as of Msgbox, -1 if timeout occured.
+    ' Errors    : Raises error 735 if temporary folder can't be found.
+
+    'Íàçíà÷åíèå  : MsgBox ñ òàéìàóòîì íà îñíîâå WScript.Shell âñïëûâàþùåãî îêíà îáîëî÷êè. Ñîçäàåò Ôàéë .VBS
+    '              - âî âðåìåííîé ïàïêå, çàïóñêàåò åãî, âîçâðàùàåò êîä ðåçóëüòàòà, óäàëÿåò ôàéë.
+    'Àðãóìåíòû   : ïåðâûå òðè òàêèå æå, êàê è äëÿ MsgBox, 4-é-ýòî òàéì-àóò â ñåêóíäàõ.
+    '            : Åñëè 4-é àðã. îïóùåí èëè <=0, à çàòåì áåñêîíå÷íî æäåò äåéñòâèé ïîëüçîâàòåëÿ.
+    'Ret. Value  : òî æå ñàìîå, ÷òî è â Msgbox, -1, åñëè ïðîèçîøåë òàéì-àóò.
+    'Îøèáêè      : âûçûâàåò îøèáêó 735, åñëè âðåìåííàÿ ïàïêà íå ìîæåò áûòü íàéäåíà.
+    '---------------------------------------------------------------------------------------
+
+    Dim sTmp$, ff%, WshShell As Object
+    Set WshShell = CreateObject("WScript.Shell")
+    sTmp = Environ("temp")
+    If sTmp = "" Then
+        sTmp = Environ("tmp")
+        If sTmp = "" Then
+            sTmp = WshShell.SpecialFolders("MyDocuments")
+            If sTmp = "" Then Err.Raise 735    'Can't save file to TEMP directory
+        End If
+    End If
+    sTmp = sTmp & Format$(Now, """\~MsgBoxEx""YYMMDDHHMMSS"".vbs""")
+    ff = FreeFile
+    Open sTmp For Output As ff
+
+    If IsMissing(Title) Then Title = ""
+
+    'Popup(<Text>,<SecondsToWait>,<Title>,<Type>)
+
+    Print #ff, "WScript.Quit CreateObject(""WScript.Shell"").Popup (""" & Str2Code(Prompt) & _
+            """, " & Int(SecondsToWait) & ", """ & Str2Code(Title) & """, " & Int(Buttons) & ")"
+    Close ff
+    MsgBoxEx = WshShell.Run(sTmp, 0, True)
+    On Error Resume Next
+    Kill sTmp
+End Function
+
+Private Function Str2Code$(s)
+    '---------------------------------------------------------------------------------------
+    ' Procedure : Str2Code
+    ' Purpose   : Replaces combinations CR+LF, LF+CR, single chars CR, LF with " & vblf & "
+    '             to be used in VBS code
+    '---------------------------------------------------------------------------------------
+
+    Str2Code = Replace$( _
+            Replace$( _
+            Replace$( _
+            Replace$( _
+            Replace$(s, """", """"""), _
+            vbCrLf, vbLf), _
+            vbLf & vbCr, vbLf), _
+            vbCr, vbLf), _
+            vbLf, """ & vblf & """)
+End Function
diff --git a/scripts/modPublicVars.bas b/scripts/modPublicVars.bas
@@ -0,0 +1,9 @@
+Attribute VB_Name = "modPublicVars"
+Option Explicit
+
+Public lRow&    'row of active toggleButton & optionButton
+Public lCol&    'column of active toggleButton
+Public i&    'temp
+Public bTglBusy     As Boolean         'flag to skip event handling
+Public oSelTgl      As MSForms.ToggleButton    'selected toggleButton
+Public frm          As MSForms.UserForm
diff --git a/scripts/modRunForm.bas b/scripts/modRunForm.bas
@@ -0,0 +1,9 @@
+Attribute VB_Name = "modRunForm"
+Option Explicit
+
+Sub RunFormMsgBox()
+    frmMsgBox.Show
+End Sub
+Sub RunForm()
+    frmForm.Show
+End Sub