Авторские программы, библиотеки, надстройки и шаблоны - VBA - Ответ 6421522

Option Explicit
'
'Калькулятор на VBA ... © Антихакер32™ ...2014
'
Const nX = 6, nY = 4, p = " ", Promt1 = "<Деление на 0>", Promt2 = "<Переполнение>"
Private Declare Function GetSystemMetrics32& Lib "User32" Alias "GetSystemMetrics" (ByVal nIndex&)
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Dim Matrix32(nX - 1, nY - 1) As CommandButton
Dim WithEvents cmm As CommandButton
Dim WithEvents cmb As ComboBox
Dim pos&, col As Collection, X&, Y&, Script As Object
 
Private Sub UserForm_Initialize()
    Dim sL&, sz&, st&, SM2&, o As Object
    SM2 = GetSystemMetrics32(2)
    sL = 100 / SM2: sz = 500 / SM2: st = sz + sL * 2
    Dim j$(), s$, i&, h&
    s = s & "7 8 9 = CE Sqr "
    s = s & "4 5 6 ( ) x^y "
    s = s & "1 2 3 + - Fix "
    s = s & "0 , % * / Mod "
    Set Script = CreateObject("MSScriptControl.ScriptControl"): Script.Language = "VBScript"
    Set col = New Collection: j = Split(s)
    For Y = 0 To nY - 1: For X = 0 To nX - 1
            Set Matrix32(X, Y) = Controls.Add("forms.CommandButton.1", "cmm_" & X & Y)
            With Matrix32(X, Y)
                Select Case X
                Case 3, 4: .Move sL * 2 + X * sz, st + Y * sz, sz, sz: .Visible = 1
                Case 5: .Move sL * 3 + X * sz, st + Y * sz, sz * 1.5, sz: .Visible = 1
                Case Else: .Move sL + X * sz, st + Y * sz, sz, sz
                End Select:  .FontSize = 10: .FontBold = 1: .Caption = j(i): i = i + 1: .Visible = 1
            End With
    Next: Next
    Set cmb = Controls.Add("forms.ComboBox.1", "cmb")
    With cmb
        .FontSize = 10: h = .Height
        .Move sL, Matrix32(0, 0).Top - h - sL, (Matrix32(nX - 1, 0).Left + Matrix32(nX - 1, 0).Width) - sL: .Visible = 1: .Text = 0
        Me.Width = .Width + sL * 3
    End With
    Set o = Controls("cmm_" & X - 1 & Y - 1)
    Me.Height = o.Top + o.Height + sz + sL
    Me.Caption = "Калькулятор VBA ... © Антихакер32™"
End Sub
 
Private Function Calc(ByVal Expression$)
    Dim s$, j$(), f&
    On Error GoTo EndFunction
    f = InStr(1, Expression, "<") 'Если в выражениях есть тег ошибки то выход
    If f Then Calc = Mid$(Expression, f): Calc = Left$(Calc, InStr(1, Calc, ">")): Exit Function
    Expression = Trim$(Split(Expression, "=")(0)) 'Отсееваем до знака равенства
    Expression = Replace(Expression, "%", "*0.01") 'Переименовать процент
    s = p & p: While InStr(1, Expression, s): Expression = Replace(Expression, s, p): Wend
    Expression = Replace(Expression, ",", ".") 'Переименовать разделитель для Eval
    Calc = Script.Eval(Expression) 'Вычисление !
    Exit Function
EndFunction:
    Calc = "<" & Err.Description & ">"
End Function
Private Sub cmm_Click()
    Dim s$: Static Result$, f&, b(2) As Boolean
    cmb.SetFocus: b(0) = 0 'Сброс оператора
    If Len(Result) Then 'Сброс если после прежнего результата, пойдет ввод цифр
        If IsNumeric(cmm.Caption) Then cmb.Text = ""
        Select Case cmm.Caption
        Case "Sqr", "Fix": cmb.Text = ""
        End Select
    End If: b(2) = b(1) Or cmb.Text = "0" Or cmb.Text = ""
    Select Case cmm.Caption 'Действия по вводу зависимо от активного названия кнопки
    Case "="
        f = InStr(1, cmb, "="): If f Then cmb.Text = Left$(cmb, f - 1)
        Result = Calc(cmb): cmb.Text = Trim$(Replace(cmb, p & p, p))
        s = cmb & " = " & Result: cmb.Text = Result
        On Error Resume Next: col.Add 0, s 'Попытаться добавить в коллекцию
        If Err.Number = 0 Then cmb.AddItem s Else Err.Clear
        cmb.Text = Result: pos = Len(cmb): cmb.SelStart = pos: Erase b: GoTo EndSub
    Case "CE": cmb.Text = 0: pos = 1: cmb.SelStart = pos: Erase b: GoTo EndSub
    Case "x^y": s = p & "^" & p: b(0) = 1
    Case "-" 'Проверка на второй минус
        For f = Len(cmb) To 1 Step -1
            s = Mid$(cmb, f, 1): If IsNumeric(s) Then Exit For
            If s = "-" Then GoTo EndSub
        Next: s = p & cmm.Caption & p: b(1) = 0: b(0) = 1
    Case "+", "*", "/", "Mod": s = p & cmm.Caption & p: b(0) = 1
    Case "," 'Проверка на повтор разделителя
        For f = Len(cmb) To 1 Step -1: s = Mid$(cmb, f, 1)
            If s = "," Then
                GoTo EndSub
            ElseIf Not IsNumeric(s) Then Exit For
            End If
        Next: s = cmm.Caption
    Case "Fix", "Sqr":  If b(2) Then s = cmm.Caption & "(": b(1) = 0: b(0) = 1
    Case "(": If b(2) Then s = cmm.Caption: b(1) = 0: b(0) = 1
    Case ")": If Not b(1) Then s = cmm.Caption Else GoTo EndSub
    Case "%": If Right$(cmb, 1) <> "%" Then s = cmm.Caption
    Case Else: s = cmm.Caption
    End Select
    If b(1) And b(0) Then GoTo EndSub Else b(1) = b(0)
    If Left$(cmb, 1) = "0" Then cmb.Text = Mid$(cmb, 2)
    cmb.SelStart = pos: cmb.SelText = s: pos = pos + Len(s): Result = ""
    Exit Sub
EndSub: cmb.SelStart = pos
End Sub
Private Sub UserForm_Activate()
    Do: DoEvents: Sleep 50: tmr_Timer: Loop
End Sub
Private Sub tmr_Timer()
    Static OldName$
    If OldName <> ActiveControl.Name And ActiveControl.Name Like "cmm_##" Then
        Set cmm = ActiveControl
    End If: OldName = ActiveControl.Name
End Sub
Private Sub cmb_Validate(Cancel As Boolean): pos = cmb.SelStart: End Sub
Private Sub UserForm_Terminate(): End: End Sub