Калькулятор

Option Explicit
'
'Калькулятор (by the fever.brain 2017)
'
Const r = 90
 
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function GetWindowLong Lib "user32.dll" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Dim WithEvents cmb As ComboBox, WithEvents txt As TextBox, WithEvents but As CommandButton
Dim i&, j&, ii&, l&, t&, w&, h&, x&, y&, s$, u$, v, Script As Object
 
Sub EnCode()
    Dim b() As Byte, i&, j#, ii&, n&, f$, h$(): ReDim h$(0): On Error Resume Next: ChDir App.Path: If Len(Dir("41.ico")) > 0 Then Exit Sub
    h(0) = "`````fЫ‰°№pmc`зИ№``f```````С†єpАs`ma``ыd``aЕАeжs„Е}nzc`pp``zxwґ±·dnК€dЮpk}цЪzzВпзѕhklµіґУj®ДяiviпдtИИ„dИВПЌбыЮ°ЮsЕ®jІЃlиТkъЮ·fѕr¶ЂfКdЉh€»y№ШОч»‚Су№jоеЉ…лрЮ|зщЯѕМЬизЯзщЊічgг‡ЗoЗпЯз№ЬйЬ»xyеЯbrpmisrjмЙЭfcbюСЧvdЉѕБЗ~pжЌФepЮpatuе°стД®‚ШхцМъ»Къы°·рЭЬrЦyвСзЩКep¶ґ`Шbвnk‚vШЇЙуФgѕ…Ыc®кuрaоп‹нОЇ·јНКѕюъuєє‹cббa}Мї±МЬасЙ}эШgУММРwАзЯЦ‹`sСМЅБрбЩcЗёЦжнhsЗ‡~ЫЇmЊЛВ‡чщЇъшоnЮqцПХЧмцЩxаocъо°ъЖрлА~jШ·аiУИrд`x‰eѕМмvЧпхn€xщК`ЂЯЌеh„u|щѓѕѕІяэjgµ±lwХxЩ·mґФkй~„в°ГЙНс„ЯІтТьЩ±ЕЙk№Икк|гмgЬП»u…|tѓэёtеµЅКнОн‡езПт±fцІЬц‹Ь¶РЛЩiщщщщiййьрФОэїЕї±єяє|c»июпЩhoйпЗЮоГeЧв„„·fг·ґ}cЧОcфж·‰uІТg‹іВТ‰„иИшГв|УАvИфЭмюЌ`яpуµжЊdik‰уъГёТиХТлЩАЂМиЉЙЕїЇ‚ЃґпЊaдСъnфeb`щхФжeкѓ‚†uЭє±эйЉэ`ЂРo®Гv°лЯоЬtЧ}Ю‚aШЕ®‚жзtг·eжјjО·Пдиs®єpЩїшебеєэ}ж€miШgwлЪokцяДјв†цpЩТі°·Еv№ае}}ж€mЌііѓмЩБwБЩzЧЮbиЧы†djaеЭbkФу…Ъхь}яч†mµ»іkВСфщxеvxЫРaнКжЃyeф±{nіlСнЖЮАlЬФБэКїdЊ…tСсхйС¶aуФэ®ЉБСкГеЕйzЊ€baґпЯxп‚€wтбшМЭуhiьѓШqoЮМ·яЉ°¶їhв~Ѕ`Ђc`Љ…``qtlР»бЊГЌкіФгѕюмУъµЯуzвчС`ЌЪ‹МuЙmШи№аЅП±зэјx†гwЖВjСЫёЫkХнaјhт°эєИчТяхxЗf…‚ОbТwp»м`Л‚†qgуpg»ГклЉ·ґРbГwv†Е|Зптhp`мµбµиХВi"
    For i = 1 To Len(h(0)): Do While Asc(Mid$(h(0), i, 1)) < 174: Mid$(h(0), i, 1) = Chr$(Asc(Mid$(h(0), i, 1)) + 32): Exit Do: Loop: Next: For i = 1 To 7: j = j * 128 + (Asc(Mid$(h(0), i, 1)) - 128): Next: ReDim b(j - 1): ii = j + i - 1: For i = i To ii: Do While i Mod 7 = 1: ii = ii + 1: n = (Asc(Mid$(h(0), ii, 1)) - 128): Exit Do: Loop: b(i - 8) = (Asc(Mid$(h(0), i, 1)) - 128) * 2 + n Mod 2: n = n \ 2: Next: Erase h: f = "tmpEnCoderArc.rar": i = FreeFile: Open f$ For Binary As #i: Put #i, 1, b: Close #i: Call CreateObject("WScript.Shell").Run("WinRAR x -y """ & f & "", 1, True):  Kill f
End Sub
 
Private Sub but_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
    With but
        Select Case Len(.Caption)
        Case 1
            Select Case Asc(.Caption)
            Case 67: txt.Text = ""
            Case 40 To 57, 61, 94: SendKeys "{" & .Caption & "}", 1
            End Select
        Case Else: If .Caption = "und" Then txtUpdate IIf(u = "", 0, u) Else SendKeys .Caption, 1: SendKeys "{(}", 1
        End Select
    End With
End Sub
 
Private Sub txt_Change()
    If txt.Text = "" Then txt.Text = "0": txt.SelLength = 2
End Sub
 
Private Sub txt_KeyPress(KeyAscii As Integer)
    Select Case KeyAscii
    Case 1: txt.SelStart = 0: txt.SelLength = 2 ^ 15: KeyAscii = 0
    Case 13, 61
        On Error Resume Next
        u = txt.Text: s = Replace(Replace(u, " ", ""), ",", "."): s = Script.eval(s)
        If Err Then MsgBox Err.Description & vbLf & Err.Number Else If Len(s) Then cmb.AddItem s, 0: txtUpdate IIf(s = "", 0, s)
        KeyAscii = 0
    End Select
End Sub
 
Private Sub Form_Load()
    Def l, r, t, r, w, r * 31, h, r * 3, x, Screen.TwipsPerPixelX, y, Screen.TwipsPerPixelY
    Set cmb = SetProp(vbCtrAdd(Me, "ComboBox"), "move" & ToStr(l, t, w))
    Set txt = SetProp(vbCtrAdd(Me, "textbox"), "text=0;SelLength=2;ZOrder 0;move" & ToStr(l + x, t + y, w - r * 3 - x * 2, h))
    Def t, t + txt.Height + r, l, r, w, r * 6, h, r * 4, ii, 0, s, "123=C456+-789*/,0^()", v, Split("sin cos tan sqr abs atn exp log rnd und")
    For i = 1 To 6: If i = 5 Then t = t + r
        For j = 1 To 5
            With Controls.Add("vb.CommandButton", "but" & ii)
                 If j = 4 Then l = l + r
                 SetProp Controls("but" & ii), "fontbold=1;fontsize=9;move" & ToStr(l, t, w, h): Def l, l + w, ii, ii + 1
                If i < 5 Then .Caption = Mid$(s, ii, 1) Else .Caption = v(ii - 21)
            End With
    Next: Def l, r, t, t + h: Next
    Set Script = CreateObject("MSScriptControl.ScriptControl"): Script.Language = "VBScript"
    Call EnCode
    SetProp FinSize(Me), "Caption=Калькулятор;StartUpPosition=2;icon=41.ico;MaxButton=0"
    txt.SetFocus
    End Sub
 
Private Sub txtUpdate(ByVal NewText$): With txt: .Text = "": SendKeys Replace(Replace(NewText, "+", "{+}"), "^", "{^}"), 1: End With: End Sub
Private Sub cmb_Click(): With txt: .Text = cmb.Text: .SelStart = Len(.Text): End With: End Sub
Private Sub but_Click(): txt.SetFocus: End Sub
 
'==========================================
 Function SetProp(ByVal Obj As Object, ByVal Prop$, Optional ByVal Visible& = 1): Dim a&, b&, c&, q&, i$(), j$(), k$(), v, s$, frm As Form: On Error Resume Next: For Each v In Array(".", ";", "=", ",", "(", ")"): For a = 1 To 2: s = Choose(a, v & " ", " " & v): While InStr(Prop, s): Prop = Replace(Prop, s, v): Wend: Next: Next: i = Split(Trim$(Prop), ";"): Set SetProp = Obj: For a = 0 To UBound(i): j = Split(i(a), "=", 2): q = UBound(j): Select Case q: Case 1: GoSub Get_to: Select Case LCase(j(0))
    'Зависимости: GetWindowLong , SendMessage, SetWindowLong
    Case "maxbutton": SetWindowLong Obj.hwnd, -16, IIf(CBool(j(1)), GetWindowLong(Obj.hwnd, -16) Or &H10000 Or &H40000, GetWindowLong(Obj.hwnd, -16) And Not &H10000 And Not &H40000): Obj.Hide: Case "container": q = InStr(1, j(1), "("): Select Case q: Case 0: Set Obj.Container = CallByName(Obj.Parent, j(1), 2): Case Else: Set Obj.Container = CallByName(Obj.Parent, Left$(j(1), q - 1), 2, Val(Mid$(j(1), q + 1))): End Select: Case "icon": Set frm = Obj: frm.Icon = LoadPicture(j(1)): For q = 0 To 1: Call SendMessage(frm.hwnd, &H80, q, ByVal frm.Icon.Handle): Next: Case "picture": CallByName Obj, j(0), 4, LoadPicture(j(1)): Case "list": k = Split(j(1), ","): For c = 0 To UBound(k): Obj.AddItem k(c): Next: Case "startupposition": Select Case j(1): Case 0: Obj.Move 0, 0: Case 1, 2: Obj.Move (Screen.Width - Obj.Width) / 2, (Screen.Height - Obj.Height) / 2: End Select
    Case Else: CallByName Obj, j(0), 4, j(1): End Select: Case Else: While InStr(i(a), "  "): i(a) = Replace(i(a), "  ", " "): Wend: j = Split(i(a), , 2): q = UBound(j): Select Case q: Case 0: GoSub Get_to: CallByName Obj, j(0), 1: Case Else: GoSub Get_to: k = Split(j(1), ","): q = UBound(k): Select Case q: Case 0: CallByName Obj, j(0), 1, k(0): Case 1: CallByName Obj, j(0), 1, k(0), k(1): Case 2: CallByName Obj, j(0), 1, k(0), k(1), k(2): Case 3: CallByName Obj, j(0), 1, k(0), k(1), k(2), k(3): End Select: End Select: End Select: Next:  DoEvents: SetProp.Visible = Visible: Exit Function
Get_to: Set Obj = SetProp: k = Split(j(0), "."): For c = 0 To UBound(k) - 1: Set Obj = CallByName(Obj, k(c), 2): Next: j(0) = k(c): Return
End Function
Function vbCtrAdd(ByVal Parent As Object, ByVal vbCtrType) As Object: Dim i&, j&, s$, t$: On Error Resume Next: vbCtrType = LCase(vbCtrType): t = Mid(vbCtrType, 1, 1): i = 2: Do: s = Mid(vbCtrType, i, 1): Do While Not s Like "[aeiouwy]": t = t & s: j = j + 1: Exit Do: Loop: i = i + 1: Loop Until j = 2 Or i > Len(vbCtrType): Do While j < 2: t = t & String(2 - j, "_"): Exit Do: Loop: i = 1: Do: s = t & i: i = i + 1: Loop While Not IsError(Parent.Controls(s).Name): Set vbCtrAdd = Controls.Add("vb." & vbCtrType, s, Parent): End Function
Function FinSize(Parent As Object, Optional ByVal gaps = 90): Dim v, sz&(1): Set FinSize = Parent: With Parent: For Each v In Parent.Controls: Do While v.Left + v.Width > sz(0): sz(0) = v.Left + v.Width: Exit Do: Loop: Do While v.Top + v.Height > sz(1): sz(1) = v.Top + v.Height: Exit Do: Loop: Next: .Move .Left, .Top, sz(0) + (.Width - .ScaleWidth) + r, sz(1) + (.Height - .ScaleHeight) + gaps: End With: End Function
Function ToStr$(ParamArray Args()): Dim v, i&: For Each v In Args: Select Case i: Case 0: i = 1: ToStr = " " & v: Case 1: ToStr = ToStr$ & "," & v: End Select: Next: End Function
Sub Def(ParamArray w()): Dim i&: For i = 0 To UBound(w) Step 2: w(i) = w(i + 1): Next: End Sub
'==========================================
Private Sub but_LostFocus(): On Error Resume Next: Set but = ActiveControl: End Sub
Private Sub cmb_LostFocus(): but_LostFocus: End Sub
Private Sub txt_LostFocus(): but_LostFocus: End Sub