Attribute VB_Name = "Module1" ' Author: George Karras, Kallithea Attikis, Greece ' Some code are work of others, and included using info when possible. ' Licensed under the GNU GENERAL PUBLIC LICENSE, Version 3, 29 June 2007 ' Before loading the code in VB6 IDE, change editor's text to a Greek font.4 ' Also to run greek commands from IDE you have to turn suFunction Mypport for Non Unicode Programs to Greek Language ' Local References: File idispatch.tlb ' First run this, and then you have to execute M2000.exe to call it, using a second IDE with the mexe.vbp, or just run M2000.exe ' In 9.3 rev >2 Asc() and Chr$() in M2000 use Locale. In previous versions these functions works for greek ascii. ' In version 10 additional symbols for remarks: // Option Explicit Private timestamp As Long, musicstamp As Long Global Const neoReadEng = "® " 'Global Const neoReadGr = "® " Global skiperror As Boolean Global maxlonglong, limitlonglong, plan As Long, lastpanel As Long Global OsInfo As New clsOSInfo, Zero64, One64, stoponerror As Boolean Global HaltLevel As Long, errbag As ErrorBag Global startaddress As Long, stacksize As Long, findstack As Long Private Const mProp = "PropReference" Private Const mHdlr = "mHandler" Private Const mGroup = "Group" Const a123 = "={-" Const b123 = vbCr + "'\/" Const b1234 = vbCr + "'\/:" Const b12345 = vbCr + "'\/:}" Const RemChar = "'\/" Private Const myArray = "mArray" Const thislabel$ = "[!" + vbCr + "'\//]" Public rndbase As rndvars, GDILines As Boolean Public LastUse As Long Private funcno As Long, ua As Double, UB As Double Private simplestack1 As rndvars Private Declare Function ShowCursor Lib "user32" (ByVal bShow As Long) As Long Private Declare Function timeGetTime Lib "winmm.dll" () As Long Private Declare Function timeGetTime1 Lib "kernel32.dll" Alias "GetTickCount" () As Long Public Declare Function IsValidCodePage Lib "kernel32" (ByVal CodePage As Long) As Long Private Declare Sub GetMem1 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Byte) Public Declare Sub GetMem2 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Integer) Private Declare Sub GetMem4 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Long) Private Declare Sub GetMemS Lib "msvbvm60" Alias "GetMem4" (ByVal Addr As Long, RetVal As Single) Private Declare Sub GetMem8 Lib "msvbvm60" (ByVal Addr As Long, RetVal As Double) Private Declare Sub PutMem1 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Byte) Public Declare Sub PutMem2 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Integer) Private Declare Sub PutMem4 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Long) Private Declare Sub PutMemS Lib "msvbvm60" Alias "PutMem4" (ByVal Addr As Long, ByVal NewVal As Single) Private Declare Sub PutMem8 Lib "msvbvm60" (ByVal Addr As Long, ByVal NewVal As Double) Private Declare Function CopyBytes Lib "msvbvm60.dll" Alias "__vbaCopyBytes" (ByVal ByteLen As Long, ByVal Destination As Long, ByVal Source As Long) As Long Private Declare Function ObjSetAddRef Lib "msvbvm60.dll" Alias "__vbaObjSetAddref" (ByRef objDest As Object, ByVal pObject As Long) As Long Public Declare Function IsBadCodePtr Lib "kernel32" (ByVal lpfn As Long) As Long Private Declare Function GetStringTypeExW Lib "kernel32.dll" (ByVal Locale As Long, ByVal dwInfoType As Long, ByVal lpSrcStr As Long, ByVal cchSrc As Long, ByRef lpCharType As Integer) As Long Private Declare Function CompareString Lib "kernel32" Alias "CompareStringW" (ByVal Locale As Long, ByVal dwCmpFlags As Long, ByVal lpString1 As Long, ByVal cchCount1 As Long, ByVal lpString2 As Long, ByVal cchCount2 As Long) As Long Private Declare Function CallWindowProc _ Lib "user32.dll" Alias "CallWindowProcW" ( _ ByVal lpPrevWndFunc As Long, _ ByVal hWnd As Long, _ ByVal Msg As Long, _ ByVal wParam As Long, _ ByVal lParam As Long) As Long Public NullGroup As New Group, NullPointer As Group Public Okk As Boolean Private Declare Sub DisableProcessWindowsGhosting Lib "user32" () Public Interrupted As Boolean Public NoOptimum As Boolean Dim Zero As basket Public Type GenItem Key As String nDx As String firsthash As Long lastpos As Long Pleft As Long ' a list End Type ' 1 to 32 for layers ' 0 for DIS Public NowDec$, NowThou$, DefaultDec$ Public ShowBooleanAsString As Boolean, DefBooleanString As String Public ForLikeBasic As Boolean, DimLikeBasic As Boolean, SecureNames As Boolean Public UseTabInForm1Text1 As Boolean Public priorityOr As Boolean, NoUseDec As Boolean, mNoUseDec As Boolean, UseIntDiv As Boolean Public mTextCompare As Boolean Public csvsep$, csvDec$, csvuseescape As Boolean, cleanstrings As Boolean Public inpcsvsep$, inpcsvDec$, inpcsvuseescape As Boolean, inpcleanstrings As Boolean Public Const DisForm = 0 Public Const BackForm = -1 Public Const PrinterPage = -2 Public players(-2 To 1032) As basket ' tag number not actual number of dsprite() Public Prefresh(-2 To 1032) As Counters Private Declare Function GdiFlush Lib "gdi32" () As Long Public m_bInIDE As Boolean Public UKEY$ Public TestShowCode As Boolean, TestShowSub As String, TestShowStart As Long, WaitShow As Long Public TestShowBypass As Boolean, TestShowSubLast As String Public feedback$, FeedbackExec$, feednow$ ' for about$ Global Const VerMajor = 14 Global Const VerMinor = 0 Global Const Revision = 43 Private Const doc = "Document" Public UserCodePage As Long, DefCodePage As Long Public cLine As String ' it was public in form1 Public casesensitive As Boolean ' for filesf Public userfiles As String Public TweakLang As Long Public notweak As Boolean Public extreme As Boolean Public taskmainonly As Boolean Public TaskMain As Boolean ' Directory separator character Public HelpStack As New basetask ' from 6.5.1 Public REFRESHRATE As Currency Public RRCOUNTER As Currency Public BLOCKkey As Boolean Public Const novalidstr = "+-/*!?_()[]&$#@;" + """" Public tempList2delete As String Public nnn$, basickey$, homepage$ Public shortlang As Boolean Public LEVCOLMENU As Long Public Alphabet As String Public taskid As Long, kill2$, para$ Public PrinterQual As Long ' 0 - 600dpi, 1 - 450dpi, 2 - 300dpi, 3 - 150 dpi. Public sRec As Object Public defFontname As String Public pnum As Long Public my_system As Enum_OperatingPlatform Public Declare Function Beeper Lib "kernel32" Alias "Beep" _ (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long Public oprinter As New cDIBSection Public Const MAX_FILENAME_LEN As Long = 260 * 2 - 1 Public beeperBEAT As Long Public funcdeep As Variant Public deep As Variant Private mys As String Public needset As Boolean Public cnt As Boolean Public exWnd As Long Private Declare Function GetForegroundWindow Lib "user32" () As Long Public expl As Long Public l_complete As Boolean Public s_complete As Boolean Public ThereIsAPrinter As Boolean Public MOUT As Boolean Public DXP As Long Public DYP As Long Public SLOW As Boolean Public pname As String Public Port As String Global elevatestatus As Long Global elevatestatus2 As Long Public Fkey As Long Public FK$(1 To 24) Public strTemp As String Public STEXIT As Boolean Public STbyST As Boolean Public STq As Boolean, bypassST As Boolean Public pagio$, pagiohtml$ Public subHash As New sbHash Public varhash As New Hash Public comhash As New coHash, numid As New idHash, numidbackup As New idHash, funid As New idHash, funidbackup As New idHash Public zones As New FastCollection Public strid As New idHash, stridbackup As New idHash, strfunid As New idHash, strfunidbackup As New idHash Public Clid As Long 'current id for app id Public lastAboutHTitle As String, LastAboutText As String '' Public Basestack1 As New basetask ' this is the global stack Public EventStaticCollection As New FastCollection Public BookMarks As New FastCollection Public sb2used As Long Public Type modfun Extern As Long sb As String sbc As Long sbgroup As String tpointer As Long subs As FastCollection Pad As Document locked As Boolean goodname As String Changed As Boolean IamAClass As Boolean End Type Public sbf() As modfun Public var2used As Long Public var() As Variant Public globalstack As New mStiva Public IERUN As Boolean Public IEX As Long Public IEY As Long Public IESizeX As Long Public IESizeY As Long Public AVIRUN As Boolean Public AVIUP As Boolean Public aviX As Long Public aviY As Long Public UseAviXY As Boolean Public UseAviSize As Boolean Public AviSizeX As Long Public AviSizeY As Long Public mycoder As New coder ' play music Public voices$(0 To 15), BEATS(0 To 15) As Double, GatePerCent(0 To 15) As Double Const GFSR_SYSTEMRESOURCES = 0 Const GFSR_GDIRESOURCES = 1 Const GFSR_USERRESOURCES = 2 Declare Function SetLocaleInfo Lib "kernel32" Alias "SetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String) As Long Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, lpLCData As String, ByVal cchData As Long) As Long Public Declare Function GetWindowsDirectory Lib "kernel32" Alias "GetWindowsDirectoryA" (ByVal lpBuffer As String, ByVal nSize As Long) As Long Private Const LOCALE_USER_DEFAULT = 0& Public trace As Boolean, tracecounter As Long, bypasstrace As Boolean Public Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) Public Declare Function SetTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long, _ ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long Public Declare Sub KillTimer Lib "user32" _ (ByVal hWnd As Long, ByVal nIDEvent As Long) Public MasterTimer As Currency, tickTimer As Double Public TaskMaster As TaskMaster, MusicMaster As New TaskMaster Public hmidi As Long Public mute As Boolean Public beat As Long Public baseNote As Long Public Prof As New clsProfiler, ProfErr As New clsProfiler Public Declare Function GetACP Lib "kernel32" () As Long ' 1253 in my computer Public OverideDec As Boolean 'Valid dwCmpFlags Public Declare Function LCMapStringW Lib "kernel32.dll" (ByVal Locale As Long, ByVal dwMapFlags As Long, ByVal lpSrcStr As Long, ByVal cchSrc As Long, Optional ByVal lpDestStr As Long, Optional ByVal cchDest As Long) As Long Private Declare Function SysReAllocStringLen Lib "OleAut32.dll" (ByVal pBstr As Long, Optional ByVal pszStrPtr As Long, Optional ByVal Length As Long) As Long Public Modalid As Double Public Function aheadstatus(a$, Optional srink As Boolean = True, Optional Pos As Long = 1) As String 'ok Dim b$, part$, W$, pos2 As Long If a$ = vbNullString Then Exit Function Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If V1 = 2 Then If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" Pos = Pos + CLng("&H" + Mid$(a$, Pos + 1, 8)) + 8 W$ = """" ElseIf Abs(V1) > 8 Then If part$ = vbNullString And W$ = "0" Then If Pos + 2 <= Len(a$) Then If LCase(Mid$(a$, Pos, 2)) Like "0[xχ]" Then 'hexadecimal literal number.... jumphere1: Pos = Pos + 2 Do While Pos <= Len(a$) If Not Mid$(a$, Pos, 1) Like "[0-9a-fA-F]" Then Exit Do Pos = Pos + 1 Loop If Mid$(a$, Pos, 1) = "&" Then If Mid$(a$, Pos + 1, 1) = "&" Then Pos = Pos + 2 Else Pos = Pos + 1 End If b$ = b$ + "N" If Pos <= Len(a$) Then W$ = Mid$(a$, Pos, 1) Else Exit Do End If End If End If End If If W$ = """" Then If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do ElseIf W$ = "(" Then again: If part$ <> "" Then If part$ = "S" Then If Mid$(a$, Pos + 1, 1) = ")" Then Pos = Pos + 2: GoTo conthere End If ElseIf Right$(b$, 1) = "a" Then b$ = Left$(b$, Len(b$) - 1) part$ = vbNullString Else part$ = "N" End If again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 2) = "=>" Then part$ = "" Pos = Pos + 3 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "#" Then 'b$ = vbNullString part$ = "" Pos = Pos + 2 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If If Mid$(a$, Pos + 1, 1) <> "." And Mid$(a$, Pos + 1, 2) <> "=>" Then b$ = b$ + part$ End If part$ = vbNullString ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If ElseIf W$ = "{" Then Select Case Left$(Right$(b$, 2), 1) Case "l" Exit Do Case "o" If Right$(b$, 1) = "N" Then Exit Do Case "S" If Right$(b$, 1) = "a" Then Select Case Left$(Right$(b$, 3), 1) Case "l" Exit Do Case "o" Exit Do End Select If Left$(Right$(b$, 3), 1) = "l" Then Exit Do End If End Select If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" If Pos <= Len(a$) Then pos2 = Pos If Not blockStringAhead(a$, Pos) Then Exit Do If Right$(b$, 1) = "N" Then If Not MaybeIsSymbol3lot(a$, "+<>=~", (Pos + 1)) Then Pos = pos2 Exit Do End If End If End If Else Select Case W$ Case "," ' bye bye Exit Do Case "%" Case "$" If part$ = vbNullString Then If b$ = vbNullString Then part$ = "N" ElseIf Right$(b$, 1) = "o" Then part$ = "N" Else aheadstatus = b$ Exit Function End If ElseIf part$ = "N" Then b$ = b$ + "Sa" If Mid$(a$, Pos + 1, 1) = "." Then Pos = Pos + 1 part$ = vbNullString End If Case "+", "-" ',"|" b$ = b$ + part$ If Len(b$) > 0& Then part$ = "o" End If Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do If part$ <> "o" Then b$ = b$ + part$ part$ = "o" Case "*", "^" If part$ <> "o" Then b$ = b$ + part$ part$ = "o" Case " ", ChrW(160), vbTab If Len(part$) > 0 Then b$ = b$ + part$ part$ = vbNullString End If Case "0" To "9", "." If part$ = "N" Then If Len(a$) < Pos Then If Mid$(a$, Pos + 1, 1) Like "[@#%~]" Then Pos = Pos + 1 ElseIf Mid$(a$, Pos + 1, 1) = "&" Then If Mid$(a$, Pos + 2, 1) = "&" Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If Case "&" If LCase$(Mid$(a$, Pos + 1, 1)) = "h" Then If Mid$(a$, Pos + 2, 1) Like "[0-9a-fA-F]" Then GoTo jumphere1 End If End If If part$ = vbNullString Then part$ = "S" ElseIf part$ = "N" Then b$ = b$ + part$ part$ = vbNullString Else b$ = part$ part$ = "S" End If Case "e", "E", "ε", "Ε" If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If Case "~" GoTo there1 Case ">", "<" If Len(a$) > Pos Then If Mid$(a$, Pos + 1, 1) = "=" Then b$ = b$ + part$ If Len(b$) > 1 Then part$ = "o" If Mid$(a$, Pos, 3) = "<=>" Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If ElseIf Mid$(a$, Pos, 2) = "<>" Then b$ = b$ + part$ If Len(b$) > 1 Then part$ = "o" Pos = Pos + 1 End If ElseIf W$ = ">" And Pos > 1 Then If Mid$(a$, Pos - 1, 2) = "->" Then ' "->" If Right$(b$, 1) = "S" Then b$ = b$ + part$ part$ = "N" End If End If End If End If GoTo there1 Case "=" If Len(a$) > Pos Then If InStr(">=", Mid$(a$, Pos + 1, 1)) > 0 Then Pos = Pos + 2 GoTo conthere End If End If there1: If b$ + part$ <> "" Then W$ = Replace(b$ + part$, "a", "") part$ = vbNullString If srink Then Do b$ = W$ W$ = Replace(b$, "NN", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "SlS", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "NlN", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "NoN", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "SoS", "S") Loop While W$ <> b$ Else b$ = W$ End If If Left$(b$, Len(b$) - 1) <> "l" Then part$ = "l" Else Exit Do End If Case ")", "}", Is < " ", ":", ";", "'", "\" Exit Do Case Else If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If End Select End If End If Pos = Pos + 1 conthere: Loop W$ = Replace(b$ + part$, "a", "") b$ = W$ If srink Then Do b$ = W$ W$ = Replace(b$, "SlS", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "NlN", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "NoN", "N") Loop While W$ <> b$ Do b$ = W$ W$ = Replace(b$, "SoS", "S") Loop While W$ <> b$ End If aheadstatus = b$ End Function Public Function aheadstatusStr(a$) As Long 'ok Dim W$, pos2 As Long, Pos As Long If a$ = vbNullString Then Exit Function Dim V1 As Integer Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If V1 = 2 Then If pos2 = 0 Then aheadstatusStr = True Exit Function ElseIf Abs(V1) > 8 Then If V1 = 34 Then If pos2 = 0 Then aheadstatusStr = True Exit Function ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do ElseIf W$ = "(" Then again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If If Mid$(a$, Pos + 1, 1) <> "." And Mid$(a$, Pos + 1, 2) <> "=>" Then End If ElseIf W$ = "{" Then aheadstatusStr = True Exit Function Else Select Case W$ Case " ", ChrW(160), vbTab If pos2 > 0 Then Exit Function Case "%" If Not Mid$(a$, Pos + 1, 1) = "(" Then Exit Function Case "$" aheadstatusStr = True Exit Function Case "=" If Not Mid$(a$, Pos + 1, 1) = ">" Then Exit Function Pos = Pos + 1 Case "-" If Not Mid$(a$, Pos + 1, 1) = ">" Then Exit Function Pos = Pos + 1 Case "." pos2 = pos2 + 1 Case "0" To "9" If pos2 = 0 Then Exit Function Case "&" If pos2 = 0 Then aheadstatusStr = True: Exit Function Case Is < " ", ")", "}", ":", ";", "'", "\", "<", "~", ",", ">", "+", "*", "/", "'", "~", "|" Exit Function Exit Do Case Else pos2 = pos2 + 1 End Select End If End If Pos = Pos + 1 conthere: Loop End Function Public Function aheadstatusFast(a$) As String 'ok Dim b$, part$, W$, pos2 As Long, Pos As Long If a$ = vbNullString Then Exit Function Dim V1 As Integer Pos = 1 'If AscW(A$) = 8 Then Exit Function Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If V1 = 2 Then If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" Pos = Pos + CLng("&H" + Mid$(a$, Pos + 1, 8)) + 8 W$ = """" ElseIf Abs(V1) > 8 Then If part$ = vbNullString And W$ = "0" Then If Pos + 2 <= Len(a$) Then If LCase(Mid$(a$, Pos, 2)) Like "0[xχ]" Then 'hexadecimal literal number.... jumphere1: Pos = Pos + 2 Do While Pos <= Len(a$) If Not Mid$(a$, Pos, 1) Like "[0-9a-fA-F]" Then Exit Do Pos = Pos + 1 While Mid$(a$, Pos, 1) = "_": Pos = Pos + 1: Wend Loop Select Case Mid$(a$, Pos, 1) Case "&" If Mid$(a$, Pos + 1, 1) = "&" Then Pos = Pos + 2 Else Pos = Pos + 1 Case "%" Pos = Pos + 1 Case "u", "U" If Len(Mid$(a$, Pos + 1, 1)) > 0 Then If InStr("BbDd", Mid$(a$, Pos + 1, 1)) > 0 Then Pos = Pos + 2 End If End If End Select If CheckFree(Mid$(a$, Pos, 1)) Then b$ = b$ + "N" Else If part$ = vbNullString Then part$ = "S" ElseIf part$ = "N" Then b$ = b$ + part$ part$ = vbNullString Else b$ = part$ part$ = "S" End If End If If Pos <= Len(a$) Then W$ = Mid$(a$, Pos, 1) Else Exit Do End If End If End If End If If W$ = """" Then If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If part$ <> "" Then ' after If part$ = "S" Then If Mid$(a$, Pos + 1, 1) = ")" Then Pos = Pos + 2: GoTo conthere End If ElseIf Right$(b$, 1) = "a" Then b$ = Left$(b$, Len(b$) - 1) part$ = vbNullString If Pos > 1 Then If Mid$(a$, Pos - 1, 1) = " " Then Exit Do Else If Right$(b$, 1) <> "S" Then part$ = "N" Else part$ = "a" End If again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 2) = "=>" Then 'part$ = "" Pos = Pos + 3 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 2 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If If Mid$(a$, Pos + 1, 1) <> "." And Mid$(a$, Pos + 1, 2) <> "=>" Then b$ = b$ + part$ End If part$ = vbNullString ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If ElseIf W$ = "{" Then Select Case Left$(Right$(b$, 2), 1) Case "l" Exit Do Case "o" If Right$(b$, 1) = "N" Then Exit Do Case "S" If Right$(b$, 1) = "a" Then Select Case Left$(Right$(b$, 3), 1) Case "l" Exit Do Case "o" Exit Do End Select If Left$(Right$(b$, 3), 1) = "l" Then Exit Do End If End Select If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" If Pos <= Len(a$) Then pos2 = Pos If Not blockStringAhead(a$, Pos) Then Exit Do If Right$(b$, 1) = "N" Then If Not MaybeIsSymbol3lot(a$, "+<>=~", (Pos + 1)) Then Pos = pos2 Exit Do End If End If End If Else Select Case W$ Case "," ' bye bye Exit Do Case "%" If part$ = vbNullString Then End If Case "$" If part$ = vbNullString Then If b$ = vbNullString Then part$ = "N" ElseIf Right$(b$, 1) = "o" Then part$ = "N" Else aheadstatusFast = b$ Exit Function End If ElseIf part$ = "N" Then b$ = b$ + "Sa" If Mid$(a$, Pos + 1, 1) = "." Then Pos = Pos + 1 part$ = vbNullString End If Case "-" If Mid$(a$, Pos, 2) = "->" Then Pos = Pos + 2 Do While Pos <= Len(a$) Select Case AscW(Mid$(a$, Pos, 1)) Case 32, 9, 160 Pos = Pos + 1 Case Else Exit Do End Select Loop If Mid$(a$, Pos, 1) = "{" Then ' Pos = Pos + 1 If Pos <= Len(a$) Then If Not blockStringAhead(a$, Pos) Then Exit Do Else Exit Do End If Else Exit Do End If Else b$ = b$ + part$ If Len(b$) > 0 Then part$ = "o" End If Case "+" b$ = b$ + part$ If Len(b$) > 0 Then part$ = "o" Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do If part$ <> "o" Then b$ = b$ + part$ End If part$ = "o" Case "*", "^" If part$ <> "o" Then b$ = b$ + part$ End If part$ = "o" Case " ", ChrW(160), vbTab If part$ <> "" Then b$ = b$ + part$ part$ = vbNullString Else 'skip End If Case "0" To "9", "." If part$ = "N" Then If Len(a$) < Pos Then If Mid$(a$, Pos + 1, 1) Like "[@#%~]" Then Pos = Pos + 1 ElseIf Mid$(a$, Pos + 1, 1) = "&" Then If Mid$(a$, Pos + 2, 1) = "&" Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If Case "&" If LCase$(Mid$(a$, Pos + 1, 1)) = "h" Then If Mid$(a$, Pos + 2, 1) Like "[0-9a-fA-F]" Then GoTo jumphere1 End If End If If part$ = vbNullString Then part$ = "S" ElseIf part$ = "N" Then b$ = b$ + part$ part$ = vbNullString Else b$ = part$ part$ = "S" End If Case "e", "E", "ε", "Ε" If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If Case "~" GoTo there1 Case ">", "<" If Len(a$) > Pos Then If Mid$(a$, Pos + 1, 1) = "=" Then b$ = b$ + part$ If Len(b$) > 1 Then part$ = "o" If Mid$(a$, Pos, 3) = "<=>" Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If ElseIf Mid$(a$, Pos, 2) = "<>" Then b$ = b$ + part$ If Len(b$) > 1 Then part$ = "o" Pos = Pos + 1 End If ElseIf W$ = ">" And Pos > 1 Then If Mid$(a$, Pos - 1, 2) = "->" Then ' "->" If Right$(b$, 1) = "S" Then b$ = b$ + part$ part$ = "N" End If End If End If End If GoTo there1 Case "=" If Len(a$) > Pos Then If InStr(">=", Mid$(a$, Pos + 1, 1)) > 0 Then Pos = Pos + 2 GoTo conthere End If End If there1: If b$ + part$ <> "" Then b$ = Replace(b$ + part$, "a", "") part$ = vbNullString If Left$(b$, Len(b$) - 1) <> "l" Then part$ = "l": Exit Do Else Exit Do End If Case ")", "}", Is < " ", ":", ";", "'", "\" Exit Do Case Else CONT1212: If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If End Select End If End If Pos = Pos + 1 conthere: Loop aheadstatusFast = b$ + part$ End Function Public Function aheadstatusFastNameOnly(a$) As Boolean Dim what As Long, drop$, Pos As Long Pos = InStr(Left$(a$, 10), Chr$(3)) Pos = Pos + 1 what = FastPureLabel(a$, drop$, Pos, False, False, 0, False, False) aheadstatusFastNameOnly = what = 3 Or what = 6 End Function ' Public Sub aheadstatusNew(a$, Pos As Long, flag As Boolean) Dim b$, part$, W$, pos2 As Long flag = False If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If part$ = vbNullString And W$ = "0" Then If Pos + 2 <= Len(a$) Then If LCase(Mid$(a$, Pos, 2)) Like "0[xχ]" Then Pos = Pos + 2 jumphere1: Do While Pos <= Len(a$) If Not Mid$(a$, Pos, 1) Like "[0-9a-fA-F]" Then Exit Do Pos = Pos + 1 While Mid$(a$, Pos, 1) = "_": Pos = Pos + 1: Wend Loop If Mid$(a$, Pos, 1) = "&" Then If Mid$(a$, Pos + 1, 1) = "&" Then Pos = Pos + 2 Else Pos = Pos + 1 ElseIf Mid$(a$, Pos, 1) = "%" Then Pos = Pos + 1 End If If CheckFree(Mid$(a$, Pos, 1)) Then b$ = b$ + "N" Else If part$ = vbNullString Then part$ = "S" ElseIf part$ = "N" Then b$ = b$ + part$ part$ = vbNullString Else b$ = part$ part$ = "S" End If End If If Pos <= Len(a$) Then W$ = Mid$(a$, Pos, 1) Else Exit Do End If End If End If End If If W$ = """" Then If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then again: If part$ <> "" Then ' after If part$ = "S" Then ' If Mid$(a$, Pos + 1, 1) = ")" Then Pos = Pos + 2: GoTo conthere End If ElseIf Right$(b$, 1) = "a" Then b$ = Left$(b$, Len(b$) - 1) part$ = vbNullString Else part$ = "N" End If again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then b$ = vbNullString part$ = "N" Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If If Mid$(a$, Pos + 1, 1) <> "." And Mid$(a$, Pos + 1, 2) <> "=>" Then b$ = b$ + part$ End If part$ = vbNullString ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If ElseIf W$ = "{" Then Select Case Left$(Right$(b$, 2), 1) Case "l" Exit Do Case "o" If Right$(b$, 1) = "N" Then Exit Do Case "S" If Right$(b$, 1) = "a" Then Select Case Left$(Right$(b$, 3), 1) Case "l" Exit Do Case "o" Exit Do End Select If Left$(Right$(b$, 3), 1) = "l" Then Exit Do End If End Select If part$ <> "" Then b$ = b$ + part$ End If part$ = "S" If Pos <= Len(a$) Then pos2 = Pos If Not blockStringAhead(a$, Pos) Then Exit Do If Right$(b$, 1) = "N" Then If Not MaybeIsSymbol3lot(a$, "+<>=~", (Pos + 1)) Then Pos = pos2 Exit Do End If End If End If Else Select Case W$ Case "," ' bye bye Exit Do Case "%" If part$ = vbNullString Then End If Case "$" If part$ = vbNullString Then If b$ = vbNullString Then part$ = "N" ElseIf Right$(b$, 1) = "o" Then part$ = "N" Else flag = Len(b$) > 0 Exit Sub End If ElseIf part$ = "N" Then b$ = b$ + "Sa" If Mid$(a$, Pos + 1, 1) = "." Then Pos = Pos + 1 part$ = vbNullString End If Case "+", "-" ', "|" b$ = b$ + part$ If b$ = vbNullString Then Else part$ = "o" End If Case "*", "/", "^" If part$ <> "o" Then b$ = b$ + part$ End If part$ = "o" Case " ", ChrW(160), vbTab If part$ <> "" Then b$ = b$ + part$ part$ = vbNullString Else 'skip End If Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 Case "0" To "9", "." If part$ = "N" Then If Len(a$) < Pos Then If Mid$(a$, Pos + 1, 1) Like "[@#%~]" Then Pos = Pos + 1 ElseIf Mid$(a$, Pos + 1, 1) = "&" Then If Mid$(a$, Pos + 2, 1) = "&" Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If Case "&" If LCase$(Mid$(a$, Pos + 1, 1)) = "h" Then If Mid$(a$, Pos + 2, 1) Like "[0-9a-fA-F]" Then GoTo jumphere1 End If End If If part$ = vbNullString Then part$ = "S" ElseIf part$ = "N" Then b$ = b$ + part$ part$ = vbNullString Else b$ = part$ part$ = "S" End If Case "e", "E", "ε", "Ε" If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If Case "~" GoTo there1 Case ">", "<" If Len(a$) > Pos Then If Mid$(a$, Pos + 1, 1) = "=" Then b$ = b$ + part$ If Len(b$) > 1 Then part$ = "o" If Mid$(a$, Pos, 3) = "<=>" Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If ElseIf Mid$(a$, Pos, 2) = "<>" Then b$ = b$ + part$ If Len(b$) > 1 Then part$ = "o" Pos = Pos + 1 End If ElseIf W$ = ">" And Pos > 1 Then If Mid$(a$, Pos - 1, 2) = "->" Then ' "->" If Right$(b$, 1) = "S" Then b$ = b$ + part$ part$ = "N" End If End If End If End If GoTo there1 Case "=" If Len(a$) > Pos Then If InStr(">=", Mid$(a$, Pos + 1, 1)) > 0 Then Pos = Pos + 2 GoTo conthere End If End If there1: If b$ + part$ <> "" Then W$ = Replace(b$ + part$, "a", "") part$ = vbNullString If Len(b$) > 1 Then If Left$(b$, Len(b$) - 1) <> "l" Then part$ = "l" Else Exit Do End If Case ")", "}", Is < " ", ":", ";", "'", "\" Exit Do Case Else If part$ = "N" Then ElseIf part$ = "S" Then Else b$ = b$ + part$ part$ = "N" End If End Select End If End If Pos = Pos + 1 conthere: Loop flag = Len(b$) <> 0 End Sub Public Sub aheadstatusDO(a$, Pos As Long, Lang As Long, flag As Boolean) Dim pos2 As Long, what$, W$, lenA As Long, level2 As Integer Const second1$ = "ΕΠΑΝΕΛΑΒΕ", len1 = 9 Const second11$ = "ΕΠΑΝΑΛΑΒΕ", len11 = 9 Const second2$ = "DO", len2 = 2 Const second22$ = "REPEAT", len22 = 6 flag = False If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 lenA = Len(a$) Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= lenA Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do End If Else Select Case W$ Case "%", "$", "0" To "9", vbLf If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), vbCr, vbTab If Len(what$) > 1 Then If Lang = 0 Then V1 = Len(what$) If V1 = 5 Or V1 = 3 Or V1 = len1 Then what$ = myUcase(what$) If what$ = "ΜΕΧΡΙ" Or what$ = "ΠΑΝΤΑ" Or what$ = "ΟΣΟ" Then If level2 = 0 Then Pos = Pos - V1 flag = True Exit Sub Else If Left$(what$, 1) <> "Π" Then aheadstatusSkipParam a$, Pos level2 = level2 - 1 End If ElseIf what$ = second1$ Or what$ = second11$ Then If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos Else level2 = level2 + 1 End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If Else V1 = Len(what$) If V1 = 4 Or V1 = 5 Or V1 = len2 Or V1 = len22 Then what$ = UCase(what$) If what$ = "UNTIL" Or what$ = "ALWAYS" Or what$ = "WHEN" Then If level2 = 0 Then Pos = Pos - V1 flag = True Exit Sub Else If Left$(what$, 1) <> "A" Then aheadstatusSkipParam a$, Pos level2 = level2 - 1 End If ElseIf what$ = second2$ Or what$ = second22$ Then If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos Else level2 = level2 + 1 End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If End If Else If Len(what$) > 0 Then aheadstatusSkipParam a$, Pos End If Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbCr, vbLf, vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 what$ = vbNullString Case "/" If Mid$(a$, Pos, 2) = "//" Then GoTo skip1 End If Case "'", "\" skip1: If Len(what$) > 0 Then what$ = vbNullString Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf Case ")", "}", Is < " " ', "'", "\" Exit Do Case ".", "A" To "Z", "a" To "z", Is >= "Ά" what$ = what$ + W$ Case Else If Len(what$) > 0 Then what$ = vbNullString End Select End If End If Pos = Pos + 1 conthere: Loop If flag = False Then If Len(what$) > 0 Then If level2 = 0 Then If Lang = 0 Then what$ = myUcase(what$) If what$ = "ΠΑΝΤΑ" Then Pos = Pos - Len(what$) flag = True Exit Sub End If Else what$ = UCase(what$) If what$ = "ALWAYS" Then Pos = Pos - Len(what$) flag = True Exit Sub End If End If End If End If End If Pos = lenA + 2 End Sub Public Sub aheadstatusSTRUCT(a$, Pos As Long) Dim pos2 As Long, W$, lenA As Long If a$ = vbNullString Then Exit Sub Dim V1 As Long lenA = Len(a$) If Pos = 0 Then Pos = 1 Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do ElseIf W$ = "(" Then again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Pos <= lenA Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do If MaybeIsSymbol3(a$, ":", Pos) Then Pos = Pos + 1: Exit Do End If Else Select Case W$ Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do Case ")", "}", Is < " ", "'", "\" Exit Do End Select End If End If Pos = Pos + 1 conthere: Loop ' skip line Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf End Sub Public Sub aheadstatusIFthen(a$, Pos As Long, Lang As Long, W$) Dim pos2 As Long, what$ If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If Else Select Case W$ Case ",", ":" Exit Do Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), vbCr, "{", vbTab If Len(what$) > 3 Then If Len(what$) > 0 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Then If lookB123(a$, Pos) Then W$ = what$ Exit Sub Else aheadstatusSkipParam a$, Pos End If Exit Do End If Else If what$ = "THEN" Or what$ = "ELSE" Then If lookB123(a$, Pos) Then W$ = what$ Exit Sub Else aheadstatusSkipParam a$, Pos End If Exit Do End If End If End If End If If W$ = vbCr Then Exit Do what$ = vbNullString If W$ = "{" Then If Pos <= Len(a$) Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Do End If Else Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 End If Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do Case ")", "}", Is < " ", "'", "\" Exit Do Case Else what$ = what$ + W$ End Select End If End If Pos = Pos + 1 conthere: Loop W$ = vbNullString If Len(what$) > 0 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Then W$ = what$ ElseIf what$ = "THEN" Or what$ = "ELSE" Then W$ = what$ End If End If End If End Sub Public Sub aheadstatusIF(a$, Pos As Long, Lang As Long, W$) Dim pos2 As Long, what$ If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If Else Select Case W$ Case ",", ":" Exit Do Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), "{", vbTab If Len(what$) > 3 Then If Len(what$) > 0 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Then W$ = what$ Exit Sub End If Else If what$ = "THEN" Or what$ = "ELSE" Then W$ = what$ Exit Sub End If End If End If End If what$ = vbNullString If W$ = "{" Then If Pos <= Len(a$) Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Do End If Else Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 End If Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do Case ")", "}", Is < " ", "'", "\" Exit Do Case Else what$ = what$ + W$ End Select End If End If Pos = Pos + 1 conthere: Loop W$ = vbNullString If Len(what$) > 0 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Then W$ = what$ ElseIf what$ = "THEN" Or what$ = "ELSE" Then W$ = what$ End If End If End If End Sub Public Sub aheadstatusELSE(a$, Pos As Long, Lang As Long, W$) Dim pos2 As Long, what$ ' in a line like if true then ?"ok" else ?"else" If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If Else Select Case W$ Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case vbTab, " ", ChrW(160), "0" To "9", "{" If Len(what$) > 1 Then If Len(what$) > 0 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΑΝ" Or what$ = "ΑΛΛΙΩΣ" Or what$ = "ΑΛΛΙΩΣ.ΑΝ" Then 'Or what$ = "ΤΟΤΕ" W$ = what$ Exit Sub End If Else If what$ = "IF" Or what$ = "ELSE" Or what$ = "ELSE.IF" Then 'Or what$ = "THEN" W$ = what$ Exit Sub End If End If End If End If what$ = vbNullString If W$ = "{" Then If Pos <= Len(a$) Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Do End If Else Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 End If Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do Case ")", "}", Is < " ", "'", "\" Exit Do Case Else If W$ = ":" Then what$ = "" Else what$ = what$ + W$ End If End Select End If End If Pos = Pos + 1 conthere: Loop W$ = vbNullString If Len(what$) > 1 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΑΝ" Or what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Or what$ = "ΑΛΛΙΩΣ.ΑΝ" Then W$ = what$ Exit Sub End If Else If what$ = "IF" Or what$ = "THEN" Or what$ = "ELSE" Or what$ = "ELSE.IF" Then W$ = what$ Exit Sub End If End If End If End Sub Public Sub aheadstatusThen(a$, Pos As Long, Lang As Long, W$) Dim pos2 As Long, what$ If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= Len(a$) Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Do End If Else Select Case W$ Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), "0" To "9", vbTab If Len(what$) > 1 Then If Len(what$) > 0 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Then W$ = what$ Exit Sub End If Else If what$ = "THEN" Or what$ = "ELSE" Then W$ = what$ Exit Sub End If End If End If End If what$ = vbNullString Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then Exit Do Case ")", "}", Is < " ", "'", "\" Exit Do Case Else what$ = what$ + W$ End Select End If End If Pos = Pos + 1 conthere: Loop W$ = vbNullString If Len(what$) > 1 Then what$ = myUcase(what$) If Lang = 0 Then If what$ = "ΤΟΤΕ" Or what$ = "ΑΛΛΙΩΣ" Then W$ = what$ Exit Sub End If Else If what$ = "THEN" Or what$ = "ELSE" Then W$ = what$ Exit Sub End If End If End If End Sub Public Sub aheadstatusSkipParam2(a$, Pos As Long) ' no block ' for for next Dim pos2 As Long, W$ If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do ElseIf W$ = "(" Then again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If Else Select Case W$ Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then GoTo jump1 Case "'", "\" If Pos > 1 Then Pos = Pos - 1 Exit Do Case ":", ")", "{", "}", Is < " ", vbLf Exit Do End Select End If End If Pos = Pos + 1 conthere: Loop Exit Sub jump1: If Pos > 1 Then Pos = Pos - 1 End Sub Public Sub aheadstatusSkipParam(a$, Pos As Long) Dim pos2 As Long, W$ If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then Pos = Pos + 1 Do While Pos <= Len(a$) If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "[" Then Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do ElseIf W$ = "{" Then If Pos <= Len(a$) Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Do End If Else Select Case W$ Case "/" If Mid$(a$, Pos + 1, 1) = "/" Then If Pos > 1 Then Pos = Pos - 1 Exit Do End If Case "'", "\" If Pos > 1 Then Pos = Pos - 1 Exit Do Case ":", ")", "}", Is < " ", vbLf Exit Do End Select End If End If Pos = Pos + 1 conthere: Loop End Sub Public Sub aheadstatusNext(a$, Pos As Long, Lang As Long, flag As Boolean) Dim pos2 As Long, what$, W$, lenA As Long, level2 As Integer, CM As Integer CM = 1 Const second1$ = "ΓΙΑ", len1 = 3 Const second2$ = "FOR", len2 = 3 flag = False If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 lenA = Len(a$) Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= lenA Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do End If Else Select Case W$ Case vbLf CM = 0 If Len(what$) > 0 Then what$ = vbNullString Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), vbCr, ":", vbTab again: If Len(what$) > 2 Then If Lang = 0 Then If Len(what$) = 7 Or Len(what$) = len1 Then what$ = myUcase(what$) If what$ = "ΕΠΟΜΕΝΟ" Then If MyTrim$(W$) = "" Then aheadstatusSkipParam a$, Pos If level2 = 0 Then flag = True Exit Sub Else level2 = level2 - 1 End If ElseIf what$ = second1$ Then aheadstatusSkipParam2 a$, Pos If MaybeIsSymbol3(a$, "{", Pos) Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Sub ElseIf MaybeIsSymbol3lot(a$, b1234, Pos) Then level2 = level2 + 1 End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If Else If Len(what$) = 4 Or Len(what$) = len2 Then what$ = UCase(what$) If what$ = "NEXT" Then If MyTrim$(W$) = "" Then aheadstatusSkipParam a$, Pos If level2 = 0 Then flag = True Exit Sub Else level2 = level2 - 1 End If ElseIf what$ = second2$ Then aheadstatusSkipParam2 a$, Pos If MaybeIsSymbol3(a$, "{", Pos) Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Sub ElseIf MaybeIsSymbol3lot(a$, b1234, Pos) Then level2 = level2 + 1 End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If End If Else If Len(what$) > 0 Then ' If EXPR THEN FOR (NOW WORKS FOR INNER FOR NEXT) ' PREVIOUS: IF EXPR THEN : FOR (WORK WITH :, OR A BLOCK { }) Select Case myUcase(what$) Case "IF", "ΑΝ" aheadstatusThen a$, Pos, 0, what$ Case Else aheadstatusSkipParam a$, Pos End Select End If End If what$ = vbNullString Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 Case "/" If CM = 0 Or Mid$(a$, Pos, 2) = "//" Then GoTo skip1 End If Case "'", "\" skip1: If Len(what$) > 0 Then what$ = vbNullString Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf CM = 0 Case ")", "}", Is < " " Exit Do Case ".", "A" To "Z", "a" To "z", Is >= "Ά" CM = 1 what$ = what$ + W$ Case Else If Len(what$) > 0 Then what$ = vbNullString End Select End If End If Pos = Pos + 1 conthere: Loop If Len(what$) > 2 Then GoTo again Pos = lenA + 2 End Sub Public Sub aheadstatusELSEIF(a$, Pos As Long, Lang As Long, jump As Boolean, IFCTRL As Long, flag As Boolean) Dim what$, W$, lenA As Long, level2 As Integer, CM As Integer, pos3 As Long CM = 1 Const second1$ = "ΑΝ", len1 = 2 Const second2$ = "IF", len2 = 2 flag = True If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 lenA = Len(a$) Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= lenA Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do End If Else Select Case W$ Case "%", "$", "0" To "9", vbLf If Len(what$) > 0 Then what$ = vbNullString Case vbLf If Len(what$) > 0 Then what$ = vbNullString CM = 0 Case " ", ChrW(160), vbCr, vbTab ', Check Else and IF If Len(what$) > 1 Then If Lang = 0 Then what$ = myUcase(what$) If what$ = "ΑΛΛΙΩΣ" Then If lookB123(a$, Pos) Then If level2 = 0 Then Pos = Pos - 6: Exit Sub Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = "ΤΕΛΟΣ" Then If FastSymbolAt(Pos, a$, second1$, len1) Then If level2 = 0 Then IFCTRL = 0: Exit Sub level2 = level2 - 1 Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = "ΑΛΛΙΩΣ.ΑΝ" Then If (Not jump) Or IFCTRL = 2 Then aheadstatusSkipParam a$, Pos Else If level2 = 0 Then Pos = Pos - 9: Exit Sub Else aheadstatusSkipParam a$, Pos End If End If ElseIf what$ = second1$ Then ' skip any nested IF aheadstatusThen a$, Pos, 0, what$ If what$ <> vbNullString Then If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos ElseIf MaybeIsSymbol3lot(a$, b123, Pos) Then level2 = level2 + 1 Else 'skip line Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf End If Else flag = False SyntaxError Exit Sub End If Else aheadstatusSkipParam a$, Pos End If Else what$ = UCase(what$) If what$ = "ELSE" Then If lookB123(a$, Pos) Then If level2 = 0 Then Pos = Pos - 4: Exit Sub Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = "END" Then If FastSymbolAt(Pos, a$, second2$, len2) Then If level2 = 0 Then IFCTRL = 0: Exit Sub level2 = level2 - 1 Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = "ELSE.IF" Then If (Not jump) Or IFCTRL = 2 Then aheadstatusSkipParam a$, Pos Else If level2 = 0 Then Pos = Pos - 7: Exit Sub Else aheadstatusSkipParam a$, Pos End If End If ElseIf what$ = second2$ Then aheadstatusThen a$, Pos, 1, what$ If what$ <> vbNullString Then If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos ElseIf MaybeIsSymbol3lot(a$, b123, Pos) Then level2 = level2 + 1 Else 'skip line Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf End If Else flag = False SyntaxError Exit Sub End If Else aheadstatusSkipParam a$, Pos End If End If End If what$ = vbNullString Pos = Pos + 1 Do pos3 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbCr, vbLf, vbTab Pos = Pos + 1 End Select Loop Until pos3 > Pos Pos = Pos - 1 Case "/" If CM = 0 Or Mid$(a$, Pos, 2) = "//" Then GoTo skip1 End If Case "'", "\" skip1: If Len(what$) > 0 Then what$ = vbNullString Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf CM = 0 Case ")", "}", Is < " " Exit Do Case ".", "A" To "Z", "a" To "z", Is >= "Ά" CM = 1 what$ = what$ + W$ Case Else If Len(what$) > 0 Then what$ = vbNullString CM = 1 End Select End If End If Pos = Pos + 1 conthere: Loop Pos = lenA + 2 End Sub ' ' Public Sub aheadstatusENDIF(a$, Pos As Long, Lang As Long, flag As Boolean) Dim pos2 As Long, what$, W$, lenA As Long, level2 As Integer, CM As Integer CM = 1 Const second1$ = "ΑΝ", len1 = 2 Const second2$ = "IF", len2 = 2 flag = True If a$ = vbNullString Then Exit Sub Dim V1 As Long If Pos = 0 Then Pos = 1 lenA = Len(a$) Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= lenA Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do End If Else Select Case W$ Case vbCr, vbLf CM = 0 If Len(what$) > 0 Then what$ = vbNullString Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), vbTab If Len(what$) > 1 Then If Lang = 0 Then If Len(what$) = 5 Or Len(what$) = len1 Then what$ = myUcase(what$) If what$ = "ΤΕΛΟΣ" Then If FastSymbolAt(Pos, a$, second1$, len1) Then If level2 = 0 Then Exit Sub level2 = level2 - 1 Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = second1$ Then aheadstatusThen a$, Pos, 0, what$ If what$ <> vbNullString Then If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos ElseIf MaybeIsSymbol3lot(a$, b123, Pos) Then level2 = level2 + 1 Else 'skip line Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf End If Else flag = False SyntaxError Exit Sub End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If Else If Len(what$) = 3 Or Len(what$) = len2 Then what$ = UCase(what$) If what$ = "END" Then If FastSymbolAt(Pos, a$, second2$, len2) Then If level2 = 0 Then Exit Sub level2 = level2 - 1 Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = second2$ Then aheadstatusThen a$, Pos, 1, what$ If what$ <> vbNullString Then If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos ElseIf MaybeIsSymbol3lot(a$, b123, Pos) Then level2 = level2 + 1 Else 'skip line Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf End If Else flag = False SyntaxError Exit Sub End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If End If End If what$ = vbNullString Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 Case "/" If CM = 0 Or Mid$(a$, Pos, 2) = "//" Then GoTo skip1 End If Case "'", "\" skip1: If Len(what$) > 0 Then what$ = vbNullString Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf CM = 0 Case ")", "}", Is < " " Exit Do Case ".", "A" To "Z", "a" To "z", Is >= "Ά" what$ = what$ + W$ CM = 1 Case Else If Len(what$) > 0 Then what$ = vbNullString CM = 1 End Select End If End If Pos = Pos + 1 conthere: Loop Pos = lenA + 2 End Sub Public Function aheadstatusENDSUBorFUN(a$, Pos As Long, Lang As Long, func As Boolean) As Boolean Dim pos2 As Long, what$, W$, lenA As Long, level2 As Integer, CM As Integer CM = 1 Const second1$ = "ΣΥΝΑΡΤΗΣΗΣ", len1 = 10 Const second2$ = "FUNCTION", len2 = 8 Const second11$ = "ΡΟΥΤΙΝΑΣ", len11 = 8 Const second22$ = "SUB", len22 = 3 If a$ = vbNullString Then Exit Function Dim V1 As Long If Pos = 0 Then Pos = 1 lenA = Len(a$) Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= lenA Then 'If Not blockStringAhead(a$, pos) Then Exit Do Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do End If Else Select Case W$ Case vbCr, vbLf CM = 0 If Len(what$) > 0 Then what$ = vbNullString Case "%", "$", "0" To "9" If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), vbTab If Len(what$) > 1 Then If Lang = 0 Then If Len(what$) = 5 Then what$ = myUcase(what$) If what$ = "ΤΕΛΟΣ" Then If func Then If FastSymbolAt(Pos, a$, second1$, len1) Then aheadstatusENDSUBorFUN = True: Exit Function Else If FastSymbolAt(Pos, a$, second11$, len11) Then aheadstatusENDSUBorFUN = True: Exit Function End If End If End If Else If Len(what$) = 3 Then what$ = UCase(what$) If what$ = "END" Then If func Then If FastSymbolAt(Pos, a$, second2$, len2) Then aheadstatusENDSUBorFUN = True: Exit Function Else If FastSymbolAt(Pos, a$, second22$, len22) Then aheadstatusENDSUBorFUN = True: Exit Function End If End If End If End If aheadstatusSkipParam a$, Pos what$ = vbNullString End If Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 Case "/" If CM = 0 Or Mid$(a$, Pos, 2) = "//" Then GoTo skip1 End If Case "'", "\" skip1: If Len(what$) > 0 Then what$ = vbNullString Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf CM = 0 Case ")", "}", Is < " " Exit Do Case ".", "A" To "Z", "a" To "z", Is >= "Ά" what$ = what$ + W$ CM = 1 Case Else If Len(what$) > 0 Then what$ = vbNullString CM = 1 End Select End If End If Pos = Pos + 1 conthere: Loop Pos = lenA + 2 End Function Public Sub aheadstatusENDWHILE(a$, Pos As Long, Lang As Long, flag As Boolean, V1 As Long) Dim pos2 As Long, what$, W$, lenA As Long, level2 As Integer, CM As Integer Const second1$ = "ΕΝΩ" Const len1 As Long = 3 Const second2$ = "WHILE" Const len2 As Long = 5 flag = False CM = 1 If a$ = vbNullString Then Exit Sub If Pos = 0 Then Pos = 1 lenA = Len(a$) Do While Pos <= lenA W$ = Mid$(a$, Pos, 1) V1 = AscW(W$) If Abs(V1) > 8 Then If W$ = """" Then If Len(what$) > 0 Then what$ = vbNullString Pos = Pos + 1 Do While Pos <= lenA If Mid$(a$, Pos, 1) = """" Then Exit Do If Abs(AscW(Mid$(a$, Pos, 1))) < 31 Then Exit Do Pos = Pos + 1 Loop ElseIf W$ = "(" Then If Len(what$) > 0 Then what$ = vbNullString again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf W$ = "{" Then If Len(what$) > 0 Then what$ = vbNullString If Pos <= lenA Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = lenA: Exit Do End If Else Select Case W$ Case vbLf If Len(what$) > 0 Then what$ = vbNullString CM = 0 Case "%", "$", "0" To "9", vbCr If Len(what$) > 0 Then what$ = vbNullString Case " ", ChrW(160), vbTab If Len(what$) > 1 Then If Lang = 0 Then If Len(what$) = 5 Or Len(what$) = len1 Then what$ = myUcase(what$) If what$ = "ΤΕΛΟΣ" Then V1 = Pos - 5 If FastSymbolAt(Pos, a$, second1$, len1) Then If level2 = 0 Then flag = True: Exit Sub level2 = level2 - 1 Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = second1$ Then Pos = Pos - 1 Do Do Pos = Pos + 1 pos2 = Pos aheadstatusNew a$, Pos, flag Loop While flag And MaybeIsSymbol3(a$, ",", Pos) Loop Until Not MaybeIsSymbol3(a$, ",", Pos) If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos ElseIf MaybeIsSymbol3lot(a$, b1234, Pos) Then level2 = level2 + 1 Pos = Pos + 1 End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If Else If Len(what$) = 3 Or Len(what$) = len2 Then what$ = UCase(what$) If what$ = "END" Then V1 = Pos - 3 If FastSymbolAt(Pos, a$, second2$, len2) Then If level2 = 0 Then flag = True: Exit Sub level2 = level2 - 1 Else aheadstatusSkipParam a$, Pos End If ElseIf what$ = second2$ Then Pos = Pos - 1 Do Do Pos = Pos + 1 pos2 = Pos aheadstatusNew a$, Pos, flag Loop While flag And MaybeIsSymbol3(a$, ",", Pos) Loop Until Not MaybeIsSymbol3(a$, ",", Pos) If MaybeIsSymbol3(a$, "{", Pos) Then aheadstatusSTRUCT a$, Pos ElseIf MaybeIsSymbol3lot(a$, b1234, Pos) Then level2 = level2 + 1 Pos = Pos + 1 End If Else aheadstatusSkipParam a$, Pos End If Else aheadstatusSkipParam a$, Pos End If End If End If what$ = vbNullString Pos = Pos + 1 Do pos2 = Pos + 1 Select Case Mid$(a$, Pos, 1) Case " ", Chr$(160), vbTab Pos = Pos + 1 End Select Loop Until pos2 > Pos Pos = Pos - 1 Case "/" If CM = 0 Or Mid$(a$, Pos, 2) = "//" Then GoTo skip1 End If Case "'", "\" skip1: If Len(what$) > 0 Then what$ = vbNullString Do Pos = Pos + 1 Loop While Pos < lenA And Not Mid$(a$, Pos, 1) = vbLf CM = 0 Case ")", "}", Is < " " Exit Do Case "A" To "Z", "a" To "z", Is >= "Ά" CM = 1 what$ = what$ + W$ Case Else If Len(what$) > 0 Then what$ = vbNullString CM = 1 End Select End If End If Pos = Pos + 1 conthere: Loop Pos = lenA + 2 End Sub Function ChangeValuesMem(bstack As basetask, rest$, Lang As Long) As Boolean Dim aa As mHandler, ah As String, p As Variant, s$, Addr As Long, pp As Variant, what$, r As Double Dim bb1 As MemBlock, w2 As Variant, rs As Single, itisSingle As Boolean, itisInt64 As Boolean, itisCur As Boolean Set aa = bstack.lastobj Set bstack.lastobj = Nothing Set bb1 = aa.objref Do While FastSymbol(rest$, ",") ChangeValuesMem = False pp = bb1.ItemSize ah = aheadstatus(rest$, False) + " " If InStr(ah, "l") Then FoundLogicalExpr Else If Left$(ah, 1) = "N" Then If Not IsExp(bstack, rest$, p, flatobject:=True, nostring:=True) Then GoTo there End If If FastSymbol(rest$, "!") Then If FastPureLabel(rest$, what$) Then If bb1.UseStruct Then If bb1.structref.Find(myUcase(what$, True)) Then pp = bb1.structref.sValue itisSingle = bb1.structref.KeyTypeValue = vbSingle itisInt64 = bb1.structref.KeyTypeValue = 20 itisCur = bb1.structref.KeyTypeValue = vbCurrency If FastSymbol(rest$, "!") Then If Not IsExp(bstack, rest$, r, , True) Then GoTo there ElseIf r >= 0 Then p = bb1.GetPtr(p) + bb1.structref.StructOffset + Int(r) * Abs(pp) Else NegativeIndex1 GoTo there End If Else p = bb1.GetPtr(p) + bb1.structref.StructOffset End If Else rest$ = what$ + rest$ If IsExp(bstack, rest$, r, , True) Then p = bb1.GetPtr(p) + r Else MyErMacro rest$, "Unknown Offset " + what$, "Άγνωστη Μετάθεση " + what$ GoTo there End If End If Else If IsExp(bstack, what$, r, , True) Then p = bb1.GetPtr(p) + r Else GoTo there End If End If Else p = bb1.GetBytePtr(p) End If Else p = bb1.GetPtr(p) itisSingle = bb1.WhatIsBasicItem = vbSingle itisInt64 = bb1.WhatIsBasicItem = 20 itisCur = bb1.WhatIsBasicItem = vbCurrency If bb1.WhatIsBasicItem = 0 Then If Not bb1.structref Is Nothing Then bb1.structref.ToStart pp = bb1.structref.sValue itisSingle = bb1.structref.KeyTypeValue = vbSingle itisInt64 = bb1.structref.KeyTypeValue = 20 itisCur = bb1.structref.KeyTypeValue = vbCurrency End If End If End If If p = 0 Then GoTo err30 End If Addr = CLng(Fix(p)) Else MyEr "No Offset found", "Δεν βρέθηκε Διεύθυνση" GoTo there End If If FastSymbol(rest$, ":=", , 2) Then ah = aheadstatus(rest$, False) + " " If Left$(ah, 1) = "N" Or InStr(ah, "l") > 0 Then If Not IsExp(bstack, rest$, p, , True) Then GoTo there End If If MemInt(VarPtr(p)) = vbString Then s$ = p GoTo q1239877 End If If Addr = 0 Then GoTo err30 Else ' this ia a part to poke some data to buffer If Addr = 0 Then GoTo err30 Else ' here is the part where we copy a string to memblock If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then If IsLabelSymbolNew(rest$, "ΨΗΦΙΟ", "BYTE", Lang) Then pp = 1 ElseIf IsLabelSymbolNew(rest$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then pp = 2 ElseIf IsLabelSymbolNew(rest$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If IsLabelSymbolNew(rest$, "ΜΑΚΡΥΣ", "LONG", Lang) Then pp = -8 itisInt64 = True Else pp = 4 End If ElseIf IsLabelSymbolNew(rest$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then pp = 8 itisCur = True ElseIf IsLabelSymbolNew(rest$, "ΑΠΛΟΣ", "SINGLE", Lang) Then pp = 4 itisSingle = True ElseIf IsLabelSymbolNew(rest$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then pp = 8 Else SyntaxError GoTo there End If End If Err.Clear On Error Resume Next Select Case Abs(pp) Case 1 ChangeValuesMem = True PutMem1 Addr, CByte(LowWord(signlong(p)) And &HFF) Case 2 If bb1.ValidArea(Addr, 2) Then ChangeValuesMem = True PutMem2 Addr, cUint(LowWord(signlong(p))) Else GoTo err10 End If Case 4 If bb1.ValidArea(Addr, 4) Then ChangeValuesMem = True If itisSingle Then rs = CSng(p) PutMemS Addr, rs Else PutMem4 Addr, signlong(p) End If Else GoTo err10 End If Case 8 If bb1.ValidArea(Addr, 8) Then ChangeValuesMem = True If itisCur Then MemCur(Addr) = CCur(p) ElseIf itisInt64 Or pp < 0 Then p = cInt64(p) CopyMemory ByVal Addr, ByVal VarPtr(p) + 8, 8 Else PutMem8 Addr, p End If Else GoTo err10 End If End Select If Err <> 0 Then GoTo err20 End If End If End If ElseIf Left$(ah, 1) = "S" Then If Not IsStrExp(bstack, rest$, s$, False) Then GoTo there End If q1239877: If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then If IsLabelSymbolNew(rest$, "ΓΡΑΜΜΑ", "STRING", Lang) Then pp = -4 Else SyntaxError GoTo there End If End If If Not bstack.lastobj Is Nothing Then MyEr "No objects for buffer", "Όχι αντικείμενα για Διάρθρωση" GoTo there Else If Addr = 0 Then GoTo err30 Else ' here is the part where we copy a string to memblock Err.Clear On Error Resume Next If pp < 0 Or bb1.WhatIsBasicItem = vbString Then If bb1.ValidArea(Addr, 4) Then ChangeValuesMem = True PutMem4 Addr, CLng(bb1.PutStringAtOffset(Addr, s$)) End If Else If bb1.ValidArea(Addr, LenB(s$)) Then ChangeValuesMem = True CopyBytes LenB(s$), Addr, StrPtr(s$) Else GoTo err10 End If End If If Err <> 0 Then ChangeValuesMem = False GoTo err20 End If End If End If Else MyEr "No Data found", "Δεν βρέθηκαν στοιχεία" GoTo there End If End If End If Loop there: Set bb1 = Nothing Set aa = Nothing Exit Function err10: MyEr "Buffer is small", "Η Διάρθρωση είναι μικρή" GoTo there err20: MyEr "Overflow. Problem in Buffer", "Υπερχείλιση. Πρόβλημα στη Διάρθρωση" GoTo there err30: MyEr "Οffset Null or not for buffer", "Διεύθυνση 0 ή εκτός Διάρθρωσης" GoTo there End Function Public Function CopyArray(a As Object) As Variant Dim pppp1 As mArray, pppp0 As tuple If TypeOf a Is mArray Then Set pppp1 = New mArray a.CopyArray pppp1 Set a = Nothing Set CopyArray = pppp1 Set pppp1 = Nothing Else Set pppp0 = New tuple a.CopyArray pppp0 Set a = Nothing Set CopyArray = pppp0 Set pppp0 = Nothing End If End Function Function IsHalfLogic(bstack As basetask, aa$, po As Variant) As Boolean Dim r As Variant, i As Long Dim that As BigInteger, thatone As BigInteger If MemInt(VarPtr(po)) = vbObject Then Set thatone = po po = 0 End If If Len(aa$) > 0 Then i = MyTrimL(aa$) If Mid$(aa$, i, 3) = "<=>" Then MyEr "<=> not supported in case", "ο τελεστής <=> δεν υποστηρίζεται στη Με": Exit Function Else Exit Function End If If MemInt(VarPtr(po)) = vbString Then IsHalfLogic = True If Not logicalSelect(bstack, aa$, po, True) Then IsHalfLogic = False Exit Function End If ElseIf FastSymbol1(aa$, "=") Then IsHalfLogic = True If Left$(aa$, 1) = "=" Then Mid$(aa$, 1, 1) = " " If IsExpA(bstack, aa$, r, 0, False) Then If Not bstack.lastobj Is Nothing Then GoTo CONT1234 Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else If r = 0 Then If po = 0 Then po = True Else po = MyRound(po, 13) = 0 End If Else po = MyRound(((po - r) / r), 10) = 0 End If End If End If Else IsHalfLogic = False Exit Function End If ElseIf IsExpA(bstack, aa$, r, 0, False) Then If Not bstack.lastobj Is Nothing Then CONT1234: If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj Set bstack.lastobj = Nothing If Not thatone Is Nothing Then po = that.compare(thatone) = 0 Else If MemInt(VarPtr(po)) = vbString Then po = that.compare(Module13.CreateBigInteger(CStr(po))) = 0 Else po = that.compare(Module13.CreateBigInteger(format$(Int(po), "0"))) = 0 End If End If ElseIf Not thatone Is Nothing Then If MemInt(VarPtr(r)) = vbString Then po = thatone.compare(Module13.CreateBigInteger(CStr(r))) = 0 Else po = thatone.compare(Module13.CreateBigInteger(format$(Int(r), "0"))) = 0 End If Else GoTo conterr End If Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else po = CBool(po = r) End If End If Else MissNumExpr IsHalfLogic = False Exit Function End If ElseIf FastSymbol1(aa$, "<") Then IsHalfLogic = True If Left$(aa$, 1) = "=" Then Mid$(aa$, 1, 1) = " " If IsExpA(bstack, aa$, r, 0, False) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj Set bstack.lastobj = Nothing If Not thatone Is Nothing Then po = that.compare(thatone) > -1 Else If MemInt(VarPtr(po)) = vbString Then po = that.compare(Module13.CreateBigInteger(CStr(po))) > -1 Else po = that.compare(Module13.CreateBigInteger(format$(Int(po), "0"))) > -1 End If End If Else GoTo conterr End If ElseIf Not thatone Is Nothing Then If MemInt(VarPtr(r)) = vbString Then po = thatone.compare(Module13.CreateBigInteger(CStr(r))) < 1 Else po = thatone.compare(Module13.CreateBigInteger(format$(Int(r), "0"))) < 1 End If Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else po = po <= r End If End If Else MissNumExpr IsHalfLogic = False Exit Function End If ElseIf Left$(aa$, 1) = ">" Then Mid$(aa$, 1, 1) = " " If IsExpA(bstack, aa$, r, 0, False) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj Set bstack.lastobj = Nothing If Not thatone Is Nothing Then po = that.compare(thatone) <> 0 Else If MemInt(VarPtr(po)) = vbString Then po = that.compare(Module13.CreateBigInteger(CStr(po))) <> 0 Else po = that.compare(Module13.CreateBigInteger(format$(Int(po), "0"))) <> 0 End If End If Else GoTo conterr End If ElseIf Not thatone Is Nothing Then If MemInt(VarPtr(r)) = vbString Then po = thatone.compare(Module13.CreateBigInteger(CStr(r))) <> 0 Else po = thatone.compare(Module13.CreateBigInteger(format$(Int(r), "0"))) <> 0 End If Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else po = po <> r End If End If Else MissNumExpr IsHalfLogic = False Exit Function End If ElseIf IsExpA(bstack, aa$, r, 0, False) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj Set bstack.lastobj = Nothing If Not thatone Is Nothing Then po = that.compare(thatone) = 1 Else If MemInt(VarPtr(po)) = vbString Then po = that.compare(Module13.CreateBigInteger(CStr(po))) = 1 Else po = that.compare(Module13.CreateBigInteger(format$(Int(po), "0"))) = 1 End If End If ElseIf Not thatone Is Nothing Then If MemInt(VarPtr(r)) = vbString Then po = thatone.compare(Module13.CreateBigInteger(CStr(r))) = -1 Else po = thatone.compare(Module13.CreateBigInteger(format$(Int(r), "0"))) = -1 End If Else GoTo conterr End If Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else po = po < r End If End If Else MissNumExpr IsHalfLogic = False Exit Function End If '/////////////////////////////////////////////////////////// ElseIf FastSymbol1(aa$, ">") Then IsHalfLogic = True If Left$(aa$, 1) = "=" Then Mid$(aa$, 1, 1) = " " If IsExpA(bstack, aa$, r, 0, False) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj Set bstack.lastobj = Nothing If Not thatone Is Nothing Then po = that.compare(thatone) < 1 Else If MemInt(VarPtr(po)) = vbString Then po = that.compare(Module13.CreateBigInteger(CStr(po))) < 1 Else po = that.compare(Module13.CreateBigInteger(format$(Int(po), "0"))) < 1 End If End If Else GoTo conterr End If ElseIf Not thatone Is Nothing Then If MemInt(VarPtr(r)) = vbString Then po = thatone.compare(Module13.CreateBigInteger(CStr(r))) > -1 Else po = thatone.compare(Module13.CreateBigInteger(format$(Int(r), "0"))) > -1 End If Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else po = po >= r End If End If Else MissNumExpr IsHalfLogic = False Exit Function End If ElseIf IsExpA(bstack, aa$, r, 0, False) Then ' true, true If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj Set bstack.lastobj = Nothing If Not thatone Is Nothing Then po = that.compare(thatone) = -1 Else If MemInt(VarPtr(po)) = vbString Then po = that.compare(Module13.CreateBigInteger(CStr(po))) = -1 Else po = that.compare(Module13.CreateBigInteger(format$(Int(po), "0"))) = -1 End If End If ElseIf Not thatone Is Nothing Then If MemInt(VarPtr(r)) = vbString Then po = thatone.compare(Module13.CreateBigInteger(CStr(r))) = 1 Else po = thatone.compare(Module13.CreateBigInteger(format$(Int(r), "0"))) = 1 End If Else GoTo conterr End If Else If MemInt(VarPtr(r)) = vbBoolean Then po = r Else po = po > r End If End If Else conterr: MissNumExpr IsHalfLogic = False Exit Function End If Else IsHalfLogic = False Exit Function End If again2: If Fast2Label(aa$, "OR", 2, "Η", 1, 2) Then If priorityOr Then If IsExp(bstack, aa$, r, , True) Then If po <> 0 Then po = -1 If r <> 0 Then r = -1 po = po Or r GoTo again2 Else MissLogicalExpr IsHalfLogic = False Exit Function End If Else If IsExp(bstack, aa$, r, False, True) Then If po <> 0 Then po = -1 If r <> 0 Then r = -1 po = po Or r GoTo again2 Else MissLogicalExpr IsHalfLogic = False Exit Function End If End If ElseIf Fast2Label(aa$, "AND", 3, "ΚΑΙ", 3, 3) Then If IsExp(bstack, aa$, r, False, True) Then If po <> 0 Then po = -1 If r <> 0 Then r = -1 po = CBool(po) And CBool(r) GoTo again2 Else MissLogicalExpr IsHalfLogic = False Exit Function End If End If End Function Public Function kUpper(a$, p As Variant) As String 'idea from Bonnie West, FROM VBFORUMS Dim nSize As Long nSize = Len(a$) If nSize Then SysReAllocStringLen VarPtr(kUpper), , nSize Else Exit Function Const LCMAP_UPPERCASE = &H200& Dim mLid As Long If p = 0 Then mLid = Clid Else mLid = p End If If p = 1032 Then If osnum >= System_Windows_Vista Then a$ = Replace(a$, "ς", "Σ") Dim i As Long For i = 1 To Len(a$) Select Case AscW(Mid$(a$, i, 1)) Case 902 Mid$(a$, i, 1) = ChrW(913) Case 904 Mid$(a$, i, 1) = ChrW(917) Case 906 Mid$(a$, i, 1) = ChrW(921) Case 912 Mid$(a$, i, 1) = ChrW(921) Case 905 Mid$(a$, i, 1) = ChrW(919) Case 908 Mid$(a$, i, 1) = ChrW(927) Case 911 Mid$(a$, i, 1) = ChrW(937) Case 910 Mid$(a$, i, 1) = ChrW(933) Case 940 Mid$(a$, i, 1) = ChrW(913) Case 941 Mid$(a$, i, 1) = ChrW(917) Case 943 Mid$(a$, i, 1) = ChrW(921) Case 942 Mid$(a$, i, 1) = ChrW(919) Case 972 Mid$(a$, i, 1) = ChrW(927) Case 974 Mid$(a$, i, 1) = ChrW(937) Case 973 Mid$(a$, i, 1) = ChrW(933) Case 962 If osnum >= System_Windows_Vista Then Mid$(a$, i, 1) = ChrW(963) Else Mid$(a$, i, 1) = ChrW(931) End If End Select Next i End If nSize = LCMapStringW(mLid, LCMAP_UPPERCASE, StrPtr(a$), nSize, StrPtr(kUpper), nSize) End Function Public Function kUpper2(a$, p As Variant) As String 'idea from Bonnie West, FROM VBFORUMS Dim nSize As Long nSize = Len(a$) If nSize Then SysReAllocStringLen VarPtr(kUpper2), , nSize Else Exit Function Const LCMAP_UPPERCASE = &H200& Dim mLid As Long If p = 0 Then mLid = Clid Else mLid = p End If If p = 1032 Then ''If osnum >= System_Windows_Vista Then a$ = Replace(a$, "ς", "Σ") Dim i As Long For i = 1 To Len(a$) Select Case AscW(Mid$(a$, i, 1)) Case 902 Mid$(a$, i, 1) = ChrW(913) Case 904 Mid$(a$, i, 1) = ChrW(917) Case 906 Mid$(a$, i, 1) = ChrW(921) Case 912 Mid$(a$, i, 1) = ChrW(921) Case 905 Mid$(a$, i, 1) = ChrW(919) Case 908 Mid$(a$, i, 1) = ChrW(927) Case 911 Mid$(a$, i, 1) = ChrW(937) Case 910 Mid$(a$, i, 1) = ChrW(933) Case 940 Mid$(a$, i, 1) = ChrW(913) Case 941 Mid$(a$, i, 1) = ChrW(917) Case 943 Mid$(a$, i, 1) = ChrW(921) Case 942 Mid$(a$, i, 1) = ChrW(919) Case 972 Mid$(a$, i, 1) = ChrW(927) Case 974 Mid$(a$, i, 1) = ChrW(937) Case 973 Mid$(a$, i, 1) = ChrW(933) Case 962 Mid$(a$, i, 1) = ChrW(931) End Select Next i End If nSize = LCMapStringW(mLid, LCMAP_UPPERCASE, StrPtr(a$), nSize, StrPtr(kUpper2), nSize) End Function Public Function klower(a$, p As Variant) As String Const LCMAP_LOWERCASE As Long = &H100 Dim nSize As Long nSize = Len(a$) If nSize Then SysReAllocStringLen VarPtr(klower), , nSize Else Exit Function Dim mLid As Long If p = 0 Then mLid = Clid Else mLid = p End If nSize = LCMapStringW(mLid, LCMAP_LOWERCASE, StrPtr(a$), nSize, StrPtr(klower), nSize) a$ = klower If p = 1032 Then a$ = a$ + Chr(0) a$ = Replace(a$, "σ" + Chr(0), "ς") a$ = Replace(a$, Chr(0), "") a$ = Replace(a$, "σ ", "ς ") a$ = Replace(a$, "σ$", "ς$") a$ = Replace(a$, "σ&", "ς&") a$ = Replace(a$, "σ.", "ς.") a$ = Replace(a$, "σ(", "ς(") a$ = Replace(a$, "σ_", "ς_") a$ = Replace(a$, "σ/", "ς/") a$ = Replace(a$, "σ\", "ς\") a$ = Replace(a$, "σ-", "ς-") a$ = Replace(a$, "σ+", "ς+") a$ = Replace(a$, "σ*", "ς*") a$ = Replace(a$, "σ" + vbCr, "ς" + vbCr) a$ = Replace(a$, "σ" + vbLf, "ς" + vbLf) End If klower = a$ End Function Sub processAcAndPo(ac, po) On Error GoTo 100 If TypeOf ac Is Complex Then If MemInt(VarPtr(po)) = 36 Then If Not TypeOf po Is Complex Then Exit Sub ac = nMath2.cxAddVar(ac, po) ElseIf myVarType(po, vbString) Then ac = fixthis(ac) + po Else ac = nMath2.cxAddRealVar(ac, po) End If ElseIf ac = 0 Then If myVarType(po, vbString) Then SwapVariant ac, po Else ac = po End If Else If TypeOf po Is Complex Then ac = nMath2.cxAddRealVar(po, ac) Else ac = ac + po End If End If Exit Sub 100 On Error GoTo 200 If Err.Number = 6 Then Err.Clear ac = CDbl(ac) + CDbl(po) Err.Clear End If 200 End Sub Sub processNegateNonZero(acpor) If TypeOf acpor Is Complex Then If acpor.r = 0 And acpor.r = 0 Then acpor = -True Else acpor = False End If ElseIf acpor <> 0 Then acpor = True Else acpor = False End If End Sub Sub processAcAndPoSimple(ac, po) If TypeOf ac Is Complex Then If MemInt(VarPtr(po)) = 36 Then If Not TypeOf po Is Complex Then Exit Sub po = nMath2.cxAddVar(ac, po) ElseIf myVarType(po, vbString) Then po = fixthis(ac) + po Else po = nMath2.cxAddRealVar(ac, po) End If ElseIf ac <> 0 Then If myVarType(po, vbString) Then If myVarType(ac, vbString) Then po = ac + po Else po = fixthis(ac) + po End If Else po = ac + po End If End If ac = 0 End Sub Public Sub PushStage(basestack As basetask, dummy As Boolean) ' FROM 5 TO 3 REDUCE STACK USAGE With basestack.RetStack basestack.SubLevel = basestack.SubLevel + 1 If dummy Then .Push2long 0&, 0& .Push2long 0&, 0& .PushLong -2& Else .Push2long varhash.Count, subHash.Count .Push2long var2used, sb2used .PushLong -1& numid.pushtop funid.pushtop strfunid.pushtop funid.pushtop basestack.ErrVars = var2used basestack.SetSkip End If End With End Sub Public Sub PopStage(basestack As basetask) Dim one As Long With basestack.RetStack If .LookTopVal = -1 Then basestack.SubLevel = basestack.SubLevel - 1 .drop 1 var2used = .Pop2Long(sb2used) basestack.ErrVars = var2used varhash.ReduceHash .Pop2Long(one), var() subHash.ReduceHash one, sbf() basestack.ResetSkip numid.poptop funid.poptop strfunid.poptop strid.poptop ElseIf .LookTopVal = -2 Then basestack.SubLevel = basestack.SubLevel - 1 .drop 3 ' not 5 End If End With End Sub Public Sub PushErrStage(basestack As basetask) With basestack.RetStack .Push2long varhash.Count, subHash.Count .Push2long basestack.SubLevel, sb2used .PushVal var2used .PushVal -4 ' from 6 to 4 entries basestack.ErrVars = var2used End With End Sub Public Sub PopErrStage(basestack As basetask) Dim nok As Boolean, one As Long With basestack.RetStack If .LookTopVal = -4 Then JUMPHERE: .drop 1 basestack.ErrVars = CLng(.PopVal) If nok Then basestack.SubLevel = .Pop2Long(sb2used) var2used = basestack.ErrVars varhash.ReduceHash .Pop2Long(one), var() subHash.ReduceHash one, sbf() basestack.ResetSkip Else .drop 2 ' not 4 End If Else While basestack.RetStackTotal > 0 Select Case .LookTopVal Case -1 nok = True .drop 5 ' 7-2 reduced basestack.ResetSkip Case -2 nok = True .drop 3 ' 5 - 2 reduced ' never happen??? Case -3 .drop 3 basestack.UseofIf = basestack.UseofIf - 1 Case -4 GoTo JUMPHERE Case -5 .drop 1 ' for select/end select Case Else .drop 2 ' string in topval (gosub to label) nok = True End Select Wend End If End With End Sub Public Sub PopStagePartContinue(basestack As basetask, parts As Long) ' drop until find a If Dim nok As Boolean, target As Long, one As Long target = basestack.RetStackTotal - parts If target < 0 Then target = 0 While basestack.RetStackTotal > target With basestack.RetStack If .LookTopVal = -4 Then JUMPHERE: .drop 1 basestack.ErrVars = CLng(.PopVal) If nok Then basestack.SubLevel = .Pop2Long(sb2used) var2used = basestack.ErrVars varhash.ReduceHash .Pop2Long(one), var() subHash.ReduceHash one, sbf() basestack.ResetSkip Else .drop 2 ' not 4 End If Else While basestack.RetStackTotal > target Select Case .LookTopVal Case -1 nok = True .drop 5 ' 7-2 reduced basestack.ResetSkip Case -2 nok = True .drop 3 '5-2 reduced ' never happen??? Case -3 .drop 3 basestack.UseofIf = basestack.UseofIf - 1 Case -4 GoTo JUMPHERE Case -5 .drop 1 ' for select/end select Case Else Exit Sub End Select Wend End If End With Wend End Sub Public Sub PopStagePartContinue2(basestack As basetask, parts As Long) ' drop until find a If Dim nok As Boolean, target As Long, one As Long target = basestack.RetStackTotal - parts If target < 0 Then target = 0 While basestack.RetStackTotal > target With basestack.RetStack If .LookTopVal = -4 Then JUMPHERE: .drop 1 basestack.ErrVars = CLng(.PopVal) If nok Then basestack.SubLevel = .Pop2Long(sb2used) var2used = basestack.ErrVars varhash.ReduceHash .Pop2Long(one), var() subHash.ReduceHash one, sbf() basestack.ResetSkip basestack.ResetSkip Else .drop 2 End If Else While basestack.RetStackTotal > target Select Case .LookTopVal Case -1 Exit Sub Case -2 nok = True .drop 3 ' never happen??? Case -3 .drop 3 basestack.UseofIf = basestack.UseofIf - 1 Case -4 GoTo JUMPHERE Case Else Exit Sub End Select Wend End If End With Wend End Sub Public Sub PopStagePart(basestack As basetask, parts As Long) Dim nok As Boolean, target As Long target = basestack.RetStackTotal - parts If target < 0 Then target = 0 While basestack.RetStackTotal > target With basestack.RetStack If .LookTopVal = -4 Then JUMPHERE: .drop 1 basestack.ErrVars = CLng(.PopVal) If nok Then basestack.SubLevel = CLng(.PopVal) var2used = basestack.ErrVars sb2used = CLng(.PopVal) varhash.ReduceHash CLng(.PopVal), var() subHash.ReduceHash CLng(.PopVal), sbf() Else .drop 4 End If Else While basestack.RetStackTotal > target Select Case .LookTopVal Case -1 nok = True .drop 7 Case -2 nok = True .drop 5 ' never happen??? Case -3 .drop 3 basestack.UseofIf = basestack.UseofIf - 1 Case -4 GoTo JUMPHERE Case Else .drop 2 ' string in topval (gosub to label) nok = True End Select Wend End If End With Wend End Sub Public Function GetNextLineNoTrim(c$) As String Dim i, j$ i = InStr(c$, vbCrLf) If i = 0 Then GetNextLineNoTrim = c$: c$ = vbNullString Else GetNextLineNoTrim = Left$(c$, i - 1): c$ = Mid$(c$, i) End Function Function expanddot(bstack As basetask, W$) As Boolean Dim i As Integer, j As Long For i = 1 To Len(W$) If Mid$(W$, i, 1) = "." Then j = j + 1 Else Exit For End If Next i W$ = Mid$(W$, j + 1) If bstack.GetDotNew(W$, j) Then If Len(here$) > 0 Then 'If j = 1 Then If Len(W$) > Len(here$) Then If Left$(W$, Len(here$) + 1) = here$ + "." Then W$ = Mid$(W$, Len(here$) + 2) End If 'End If End If expanddot = True End If End Function Public Sub ProcessOper(bstack As basetask, first As Object, oper$, r As Variant, Lang As Long, Optional skip As Boolean = False) Dim where As Long, W$, ok As Boolean Dim soroslen As Long, flag As Boolean, backup As Object, oldkillvars As Boolean flag = Not first Is Nothing 'Dim buser As String oldkillvars = bstack.nokillvars If oper$ = "''" Then 'buser = bstack.UseGroupname 'bstack.UseGroupname = "" bstack.nokillvars = True End If If Not oldkillvars Then PushStage bstack, False soroslen = bstack.soros.Total If soroslen < 0 Then SyntaxError: Exit Sub ' if flag Then bstack.soros.PushObj first ' change in Version 9.2 revision 3 If flag Then Set bstack.lastpointer = Nothing ' this was a very difficult bug Set backup = bstack.lastobj bstack.soros.PushObj bstack.lastobj Set bstack.lastobj = first End If where = AllocVar() '' var(where) W$ = ChrW(&H1FFF) & (where) If here$ <> "" Then varhash.ItemCreator here$ + "." + bstack.GroupName + W$, where UnFloatGroup bstack, W$, where, bstack.lastobj, , True Else varhash.ItemCreator (W$), where UnFloatGroup bstack, W$, where, bstack.lastobj, True, True End If var(where).FloatGroupName = W$ If oper$ = "''" Then ok = MyRead(1, bstack, (W$), Lang) Else NeoCall2 bstack, W$ + "." + ChrW(&H1FFF) + oper$ + "()", ok End If If soroslen < bstack.soros.Total Then If soroslen + 1 = bstack.soros.Total And flag Then r = bstack.soros.PopVal If ok Or skip Then Set bstack.lastobj = Nothing ElseIf flag Then ' when we add two groups which we don't define operator now set result as the last group Set bstack.lastobj = backup End If bstack.DropNdot 2 bstack.nokillvars = oldkillvars If Not oldkillvars Then PopStage bstack ': bstack.UseGroupname = buser Exit Sub End If End If If ok And Not skip Then Set bstack.lastobj = CopyGroupObj(var(where)) Else Set bstack.lastobj = Nothing bstack.DropNdot 2 bstack.nokillvars = oldkillvars If Not oldkillvars Then PopStage bstack ': bstack.UseGroupname = buser End If End Sub Public Sub ProcessOperRemove(first As Group) Dim where As Long, W$, ok As Boolean Dim soroslen As Long, flag As Boolean, backup As Object Dim bstack As New basetask, ohere$ SwapStrings ohere$, here$ Set bstack.Sorosref = NewmStiva Set bstack.Owner = Form1.DIS PushStage bstack, False where = AllocVar() '' var(where) W$ = ChrW(&H1FFF) & (where) 'If here$ <> "" Then 'varhash.ItemCreator here$ + "." + w$, where 'UnFloatGroup bstack, w$, where, bstack.lastobj, , True 'Else varhash.ItemCreator (W$), where, , True Set bstack.lastobj = first UnFloatGroup bstack, W$, where, bstack.lastobj, True, True 'End If var(where).FloatGroupName = W$ NeoCall2 bstack, W$ + "." + ChrW(&H1FFF) + "_%()", ok PopStage bstack SwapStrings ohere$, here$ End Sub Function SizeY(bstack As basetask, a$, s$, s1$, r As Variant) As Boolean Dim R2 As Variant, R3 As Variant, R4 As Variant R3 = 0 R4 = 0 If IsStrExp(bstack, a$, s$, False) Then If Not FastSymbol(a$, ",") Then: missParam a$: SizeY = False: Exit Function If Not IsStrExp(bstack, a$, s1$, False) Then: missParam a$: SizeY = False: Exit Function If Not FastSymbol(a$, ",") Then: missParam a$: SizeY = False: Exit Function If Not IsExp(bstack, a$, R2, , True) Then: missParam a$: SizeY = False: Exit Function If bstack.toprinter Then If szFactor = 0 Then InternalError: Exit Function R2 = R2 * szFactor End If If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, R3, , True) Then missParam a$: SizeY = False: Exit Function End If If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, R4, , True) Then missParam a$: SizeY = False: Exit Function End If R4 = Abs(Int(R4)) End If End If On Error Resume Next r = nTextY(bstack, s$, s1$, CSng(R2), R3, R4) If bstack.toprinter Then r = r * prFactor End If If Err.Number > 0 Then r = 0 On Error GoTo 0 SizeY = FastSymbol(a$, ")", True) End If End Function Function SizeX(bstack As basetask, a$, s$, s1$, r As Variant) As Boolean Dim R2 As Variant, R3 As Variant, R4 As Variant R3 = 0 R4 = 0 If IsStrExp(bstack, a$, s$, False) Then If Not FastSymbol(a$, ",") Then SizeX = False: Exit Function If Not IsStrExp(bstack, a$, s1$, False) Then SizeX = False: Exit Function If Not FastSymbol(a$, ",") Then SizeX = False: Exit Function If Not IsExp(bstack, a$, R2, , True) Then SizeX = False: Exit Function If bstack.toprinter Then If szFactor = 0 Then InternalError: Exit Function R2 = R2 * szFactor End If If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, R3, , True) Then missParam a$: SizeX = False: Exit Function End If If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, R4, , True) Then missParam a$: SizeX = False: Exit Function End If R4 = Abs(Int(R4)) End If End If On Error Resume Next r = nText(bstack, s$, s1$, CSng(R2), R3, R4) If bstack.toprinter Then r = r * prFactor End If If Err.Number > 0 Then r = 0 On Error GoTo 0 SizeX = FastSymbol(a$, ")", True) End If End Function Public Function SpeedGroup(bstack As basetask, pppp As iBoxArray, Prefix$, ByVal W$, b$, v As Long) As Long Dim Vars As Long, Vname As Long, y1 As Long, subs As Long, snames As Long, i As Long, ec$, ohere$, p As Long Dim depth As Long, loopthis As Boolean, v100 As Boolean, RetStackSize As Long, S3 As Long, rest1$ Dim safegroup As Group Dim oldjump As Long, oldifctrl As Long, olduseofif As Long Dim kolpo As Boolean, bb$, once As Boolean, subsfc As FastCollection Dim Lang As Long, ok As Boolean, rv As Variant Dim small$, sbi As Long bstack.SetSkip Vars = var2used: Vname = varhash.Count subs = sb2used: snames = subHash.Count numid.pushtop funid.pushtop strfunid.pushtop funid.pushtop Dim mm As mStiva2, tempRef As Object If Prefix = "VAL" Then If aheadstatusFastNameOnly(b$) Then GoTo contValstr End If ' we stand as right value... If pppp Is Nothing Then GoTo fastexit If InStr(W$, "(") Then ec$ = W$ + ")" Else ec$ = W$ End If If v >= 0 Then W$ = pppp.CodeName & (v) Else W$ = pppp.CodeName & (Abs(v)) End If If Len(pppp.item(v).LastOpen) > 0 Then If GetVar(bstack, pppp.item(v).LastOpen, i) Then jmp1995: Set safegroup = var(i) If safegroup.lasthere = here$ Then W$ = safegroup.GroupName W$ = Left$(W$, Len(W$) - 1) Else LinkGroup bstack, W$, var(i) makegroup bstack, W$, i End If bstack.tmpstr = W$ + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If IsNumberNew(bstack, b$, rv, False) Then bstack.LastValue = rv SpeedGroup = 1 End If GoTo fastexit End If End If If Not MyIsObject(pppp.item(v)) Then GoTo fastexit End If Set safegroup = pppp.item(v) If safegroup Is Nothing Then GoTo fastexit If safegroup.IamApointer Then If Len(safegroup.lasthere) > 0 And Len(safegroup.GroupName) > 0 Then W$ = safegroup.lasthere + "." + safegroup.GroupName bstack.tmpstr = W$ + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If Not IsNumberNew(bstack, b$, rv, False) Then SpeedGroup = 0: GoTo fastexit1 bstack.LastValue = rv SpeedGroup = 1 GoTo fastexit End If If safegroup.link.LastOpen <> vbNullString Then If GetVar(bstack, safegroup.link.LastOpen, i) Then GoTo jmp1995 ElseIf safegroup.LastOpen <> vbNullString Then If GetVar(bstack, (safegroup.LastOpen), y1, True) Then If safegroup.lasthere$ = here$ Then W$ = safegroup.LastOpen Else If safegroup.lasthere$ = vbNullString Then W$ = safegroup.LastOpen Else W$ = safegroup.lasthere$ + "." + safegroup.LastOpen End If End If Set safegroup = safegroup.link GoTo cont3030 Else safegroup.lasthere = vbNullString safegroup.LastOpen = vbNullString End If End If y1 = globalvarGroup(W$, 0#, , here$ = vbNullString) Set safegroup = safegroup.link UnFloatGroup bstack, W$, y1, safegroup, , True globalvarGroup W$, y1, True, True cont3030: Else If Len(safegroup.LastOpen) > 0 Then If Not GetVar(bstack, safegroup.LastOpen, y1, True) Then GoTo fastexit End If GoTo conthere0001 End If y1 = globalvarGroup(W$, 0#, , here$ = vbNullString) If Not safegroup.IamFloatGroup Then Set safegroup = CopyGroupObj(safegroup) ElseIf safegroup.IamApointer Then Set safegroup = CopyGroupObj(safegroup.link) End If UnFloatGroup bstack, W$, y1, safegroup, , True var(y1).FloatGroupName = ec$ globalvarGroup W$, y1, True, True End If Set safegroup = pppp.item(v) conthere0001: If Left$(b$, 1) <> "." And Left$(b$, 1) <> "(" And var(y1).HasParameters Then bstack.tmpstr = W$ + "(" + Left$(b$, 1) Else bstack.tmpstr = W$ + Left$(b$, 1) End If 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If IsNumberNew(bstack, b$, rv, False) Then SpeedGroup = 1 If pppp.arr Then If safegroup.IamApointer Then 'Set tempRef = pppp.GroupRef safegroup.link.ToDelete = True Set safegroup.LinkRefPointer = CopyGroupObj(var(y1), pppp.IhaveClass, pppp.GroupRef) 'Set safegroup.link.LinkRef = pppp.GroupRef Else Set tempRef = pppp.GroupRef 'pppp.item(v).Link pppp.item(v).ToDelete = True Set pppp.item(v) = CopyGroupObj(var(y1)) If TypeOf pppp.itemObject(v) Is Group Then Set pppp.item(v).LinkRef = pppp.GroupRef End If Else If safegroup.IamApointer Then CopyGroup1 var(y1), safegroup.link If v >= 0 Then Set bstack.lastpointer = safegroup Set bstack.lastobj = safegroup.link End If Else CopyGroup1 var(y1), safegroup End If End If If bstack.lastobj Is Nothing Then bstack.LastValue = rv Else bstack.LastValue = 0# GoTo fastexit End If Else SpeedGroup = -1 If Not LastErNum1 = -1 Then MyEr "No Property/member found", "Δεν βρήκα ιδιότητα/μελος" End If Set bstack.lastobj = Nothing GoTo fastexit ElseIf Prefix = "VAL$" Then contValstr: ec$ = W$ + ")" If v >= 0 Then W$ = pppp.CodeName & (v) Else W$ = pppp.CodeName & (Abs(v)) End If If Len(pppp.item(v).LastOpen) > 0 Then If GetVar(bstack, pppp.item(v).LastOpen, i) Then jmp2000: Set safegroup = var(i) If safegroup.lasthere = here$ Then W$ = safegroup.GroupName W$ = Left$(W$, Len(W$) - 1) Else LinkGroup bstack, W$, var(i) makegroup bstack, W$, i End If If safegroup.HasStrValue And Not Right$(W$, 1) = "$" Then bstack.tmpstr = W$ + "$" + Left$(b$, 1) Else bstack.tmpstr = W$ + Left$(b$, 1) End If 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If IsStr1(bstack, b$, bb$) Then bstack.LastValue = bb$ SpeedGroup = 1 End If GoTo fastexit End If End If If Not MyIsObject(pppp.item(v)) Then GoTo fastexit End If Set safegroup = pppp.item(v) If safegroup Is Nothing Then GoTo fastexit If safegroup.IamApointer Then If Len(safegroup.lasthere) > 0 And Len(safegroup.GroupName) > 0 Then W$ = safegroup.lasthere + "." + safegroup.GroupName bstack.tmpstr = W$ + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If Not IsStr1(bstack, b$, bb$) Then SpeedGroup = 0: GoTo fastexit1 bstack.LastValue = bb$ SpeedGroup = 1 GoTo fastexit End If If safegroup.link.LastOpen <> vbNullString Then If GetVar(bstack, safegroup.link.LastOpen, i) Then GoTo jmp2000 ElseIf safegroup.LastOpen <> vbNullString Then If GetVar(bstack, (safegroup.LastOpen), y1, True) Then If safegroup.lasthere$ = here$ Then W$ = safegroup.LastOpen Else If safegroup.lasthere$ = vbNullString Then W$ = safegroup.LastOpen Else W$ = safegroup.lasthere$ + "." + safegroup.LastOpen End If End If Set safegroup = safegroup.link '' ADDED rev 6 ver 9.8 GoTo cont5050 Else safegroup.lasthere = vbNullString '' ADDED rev 6 ver 9.8 safegroup.LastOpen = vbNullString End If End If y1 = globalvarGroup(W$, 0#, , here$ = vbNullString) '' fix it rev 6 ver 9.8 Set safegroup = safegroup.link UnFloatGroup bstack, W$, y1, safegroup, , True var(y1).FloatGroupName = W$ globalvarGroup W$, y1, True, True cont5050: Else If Len(safegroup.LastOpen) > 0 Then If Not GetVar(bstack, safegroup.LastOpen, y1, True) Then GoTo fastexit End If GoTo conthere000 End If y1 = globalvarGroup(W$, 0#, , here$ = vbNullString) If Not safegroup.IamFloatGroup Then Set safegroup = CopyGroupObj(safegroup) ElseIf safegroup.IamApointer Then Set safegroup = CopyGroupObj(safegroup.link) End If UnFloatGroup bstack, W$, y1, safegroup, , True var(y1).FloatGroupName = ec$ globalvarGroup W$, y1, True, True End If Set safegroup = pppp.item(v) If safegroup Is Nothing Then GoTo fastexit conthere000: If Left$(b$, 1) = "." Then bstack.tmpstr = W$ + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) Set bstack.lastpointer = Nothing If IsStr1(bstack, b$, bb$) Then GoTo conthere ElseIf var(y1).HasValue Then If var(y1).HasParameters Then If pppp.arr Then If Left$(b$, 1) = "(" Then bstack.tmpstr = W$ + "$" + Left$(b$, 1) Else bstack.tmpstr = W$ + "$(" + Left$(b$, 1) End If 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) Set bstack.lastpointer = Nothing If IsStr1(bstack, b$, bb$) Then GoTo conthere ElseIf FastSymbol(b$, ")(", , 2) Then bstack.tmpstr = W$ + "(" + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) Set bstack.lastpointer = Nothing If IsStr1(bstack, b$, bb$) Then GoTo conthere Else ec$ = W$ + "(" + BlockParam(b$) + ")" b$ = Mid$(b$, 2) If IsNumber(bstack, ec$, rv) Then GoTo conthere End If Else If IsStr1(bstack, W$ + "$", bb$) Then End If End If conthere: If pppp.arr Then If safegroup.IamApointer Then 'Set tempRef = pppp.GroupRef 'pppp.item(v).Link safegroup.link.ToDelete = True Set safegroup.LinkRefPointer = CopyGroupObj(var(y1)) Else Set tempRef = pppp.GroupRef 'pppp.item(v).Link pppp.item(v).ToDelete = True Set pppp.item(v) = CopyGroupObj(var(y1), pppp.IhaveClass, tempRef) 'If TypeOf pppp.itemObject(v) Is Group Then Set pppp.item(v).LinkRef = pppp.GroupRef End If Else If safegroup.IamApointer Then CopyGroup1 var(y1), safegroup.link If v >= 0 Then Set bstack.lastpointer = safegroup Set bstack.lastobj = safegroup.link End If Else CopyGroup1 var(y1), safegroup End If End If End If SpeedGroup = 1 Set bstack.lastobj = Nothing If bstack.lastobj Is Nothing Then bstack.LastValue = bb$ Else bstack.LastValue = vbNullString End If GoTo fastexit ElseIf Prefix = "FOR" Then Set mm = New mStiva2 oldjump = bstack.jump: oldifctrl = bstack.IFCTRL: olduseofif = bstack.UseofIf RetStackSize = bstack.RetStackTotal If v = -1 Then y1 = 0 If W$ = "THIS" Or W$ = "ΑΥΤΟ" Then W$ = "THIS" ' look this other time.. ElseIf Len(W$) > 5 Then If Len(bstack.UseGroupname) > 0 Then If W$ = "SUPERCLASS" Or W$ = "ΥΠΕΡΚΛΑΣΗ" Then Set pppp = New ppppLight: pppp.PushDim (1): pppp.PushEnd: pppp.arr = True v = 0 W$ = Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) If Right$(here$, 2) = "()" Then If Right$(here$, 3) = ChrW(&H1FFD) + "()" Then If GetVar3(bstack, bstack.fHere + "." + W$, y1) Then If TypeOf var(y1) Is Group Then If Not var(y1).SuperClassList Is Nothing Then Set pppp.item(v) = var(y1).SuperClassList v100 = True GoTo CONT104010 End If End If End If ElseIf GetVar(bstack, bstack.Parent.originalname + "." + W$, y1) Then If TypeOf var(y1) Is Group Then If Not var(y1).SuperClassList Is Nothing Then Set pppp.item(v) = var(y1).SuperClassList v100 = True GoTo CONT104010 End If End If End If End If If GetVar3(bstack, W$, y1) Then If TypeOf var(y1) Is Group Then If Not var(y1).SuperClassList Is Nothing Then Set pppp.item(v) = var(y1).SuperClassList v100 = True GoTo CONT104010 End If End If ElseIf GetVar(bstack, bstack.originalname + "." + W$, y1) Then If TypeOf var(y1) Is Group Then If Not var(y1).SuperClassList Is Nothing Then Set pppp.item(v) = var(y1).SuperClassList v100 = True GoTo CONT104010 End If End If Else MyEr "Double use of SuperClass", "Διπλή χρήση της Υπερκλάσης" GoTo fastexit End If End If End If End If If GetVar3(bstack, W$, y1) Then If TypeOf var(y1) Is Group Then If var(y1).IamApointer Then If Len(var(y1).link.LastOpen) > 0 Then If GetVar(bstack, var(y1).link.LastOpen, i) Then GoTo jmp1998 End If Set safegroup = var(y1) If safegroup.link.IamFloatGroup Then v = 0 Do While safegroup.link.IamApointer Set safegroup = safegroup.link If safegroup.link Is Nothing Then GoTo fastexit Loop Set pppp = BoxGroupVar(safegroup.link) Set pppp.refgroup = safegroup safegroup.link.PointerPtr = ObjPtr(safegroup) safegroup.PointerPtr = ObjPtr(safegroup) W$ = pppp.CodeName & (Abs(v)) GoTo CONT1040102 Else If Len(var(y1).lasthere) = 0 Then If var(y1).IamGlobal Then bstack.MoveNameDot "*" + var(y1).GroupName Else bstack.MoveNameDot var(y1).GroupName End If Else bstack.MoveNameDot var(y1).lasthere + "." + var(y1).GroupName End If v = -1 End If Else If var(y1).IamGlobal Then bstack.MoveNameDot "*" + W$ Else ' If Len(var(y1).Patch) = 0 Then ' bstack.MoveNameDot w$ ' Else bstack.MoveNameDot var(y1).Patch ' End If End If End If Else MissingGroup GoTo fastexit End If Else If W$ = "THIS" Then bstack.MoveNameDot W$ Else MissingGroup GoTo fastexit End If End If Else If pppp Is Nothing Then SpeedGroup = 0: Exit Function If pppp.arr Then If pppp.item(v).IamApointer Then Set safegroup = pppp.item(v) If Not safegroup.link.IamFloatGroup Then If Len(safegroup.lasthere) = 0 Then If safegroup.IamGlobal Then bstack.MoveNameDot "*" + safegroup.GroupName Else bstack.MoveNameDot safegroup.GroupName End If Else bstack.MoveNameDot safegroup.lasthere + "." + safegroup.GroupName End If v = -1 GoTo contheretoo1 End If End If Else Set safegroup = pppp.item(v) End If CONT104010: If pppp.refgroup Is Nothing Then If v >= 0 Then W$ = pppp.CodeName & (v) Else W$ = pppp.CodeName & (Abs(v)) End If If Len(pppp.item(v).LastOpen) > 0 Then If GetVar(bstack, pppp.item(v).LastOpen, i) Then jmp1998: Set safegroup = var(i) If safegroup.lasthere = here$ Then W$ = safegroup.GroupName W$ = Left$(W$, Len(W$) - 1) Else LinkGroup bstack, W$, var(i) makegroup bstack, W$, i End If y1 = -1 Set safegroup = var(i) GoTo conthere145 End If Else If Not safegroup Is Nothing Then If Not safegroup.link Is Nothing Then If Len(safegroup.link.LastOpen) > 0 Then W$ = safegroup.link.LastOpen End If End If End If End If Else If Not pppp.refgroup.LastOpen = vbNullString Then If pppp.refgroup.lasthere$ = here$ Then W$ = pppp.refgroup.LastOpen Else W$ = pppp.refgroup.lasthere$ + "." + pppp.refgroup.LastOpen End If End If End If If Not MyIsObject(pppp.item(v)) Then GoTo fastexit If Not safegroup Is Nothing Then Set safegroup = pppp.item(v) If safegroup Is Nothing Then GoTo fastexit If safegroup.IamApointer Then If safegroup.link.IamFloatGroup Then Set pppp = BoxGroupVar(safegroup.link) Set pppp.refgroup = safegroup safegroup.LastOpen = W$ safegroup.lasthere = here$ Set safegroup = Nothing v = 0 Else bstack.MoveNameDot safegroup.GroupName v = -1 GoTo contheretoo1 End If End If End If CONT1040102: On Error Resume Next ' check for iamglobal ?? If Not GetVar3(bstack, W$, y1) Then y1 = globalvarGroup(W$, CVar(New Group)) If pppp.item(v).IamApointer Then UnFloatGroup bstack, W$, y1, pppp.item(v).link, , True Else UnFloatGroup bstack, W$, y1, pppp.item(v), , True End If ' globalvarGroup w$, y1, True, True Set safegroup = pppp.item(v) safegroup.LastOpen = W$ var(y1).lasthere = here$ var(y1).LastOpen = W$ var(y1).PointerPtr = safegroup.PointerPtr End If If Err.Number > 0 Then mer123: MyEr "This For can't be done", " Αυτή η Για δεν μπορεί να γίνει" Err.Clear GoTo fastexit End If conthere145: If y1 = -1 Then If Not safegroup Is Nothing Then If safegroup.IamGlobal Then bstack.MoveNameDot "*" + var(i).Patch Else bstack.MoveNameDot var(i).Patch End If Else bstack.MoveNameDot var(i).Patch End If Else If Not safegroup Is Nothing Then If safegroup.IamGlobal Then bstack.MoveNameDot "*" + var(y1).Patch Else bstack.MoveNameDot var(y1).Patch End If Else bstack.MoveNameDot var(y1).Patch End If End If ' depth = depth + 1 End If contheretoo1: mm.DataVal CDbl(y1) If v100 Then v = -100: v100 = False mm.DataVal CDbl(v) mm.DataObj pppp Do While FastSymbol(b$, ",") y1 = -1 If Len(b$) < 129 Then i = IsLabelDot(vbNullString, b$, W$, y1) Else rest1$ = Left$(b$, 128) i = IsLabelDot(vbNullString, rest1$, W$, y1) If Len(rest1$) = 0 Then i = IsLabelDot(vbNullString, b$, W$, y1) Else b$ = Mid$(b$, 129 - Len(rest1$)) End If End If If y1 > 0 Then If Left$(W$, 2) = ".." Then i = -bstack.GetDotNew(W$, y1) * i End If Else y1 = 0 End If If i > 4 And i < 8 Then Set safegroup = Nothing If neoGetArray(bstack, W$, pppp) Then If NeoGetArrayItem(pppp, bstack, W$, v, b$) Then If pppp.ItemType(v) = mGroup Then If Left$(b$, 1) = "." Then If SpeedGroup(bstack, pppp, "VAL", "", b$, v) = 1 Then If Typename(bstack.lastobj) = mGroup Then Set pppp = New ppppLight pppp.arr = False Set pppp.GroupRef = bstack.lastobj v = -2 Else MissingGroup GoTo fastexit End If Else GoTo fastexit End If End If contheretoo: W$ = pppp.CodeName & (Abs(v)) If pppp.item(v).IamApointer Then If Len(pppp.item(v).link.LastOpen) > 0 Then If GetVar(bstack, pppp.item(v).link.LastOpen, i) Then GoTo jmp1998 End If End If If pppp.item(v).link.IamFloatGroup Then Set safegroup = pppp.item(v) Set pppp = BoxGroupObj(safegroup.link) Set pppp.refgroup = safegroup v = 0 Else W$ = pppp.item(v).GroupName GoTo conthere3 End If End If If safegroup Is Nothing Then Set safegroup = pppp.item(v) Else If Not pppp.item(v).IamApointer Then If pppp.refgroup Is Nothing Then Set safegroup = pppp.item(v) End If pppp.item(v).PointerPtr = ObjPtr(safegroup) End If End If If safegroup.LastOpen <> vbNullString Then If GetVar(bstack, safegroup.LastOpen, y1, , , True) Then W$ = safegroup.LastOpen y1 = globalvarGroup(W$, (y1), True) GoTo cont1010 Else safegroup.LastOpen = vbNullString End If End If contheretoo123: y1 = globalvarGroup(W$, CVar(New Group)) UnFloatGroup bstack, W$, y1, pppp.item(v), , True 'globalvarGroup w$, y1, True, True var(y1).LastOpen = W$ var(y1).lasthere = here$ safegroup.LastOpen = W$ safegroup.lasthere = here$ var(y1).PointerPtr = pppp.item(v).PointerPtr cont1010: ' where look for global??? bstack.MoveNameDot var(y1).Patch ' w$ 'myUcase(w$) depth = depth + 1 mm.DataVal CDbl(y1) If v100 Then v = -100: v100 = False mm.DataVal CDbl(v) mm.DataObj pppp Else MissingGroup GoTo normalexit End If Else SyntaxError GoTo normalexit End If Else NotExistArray GoTo normalexit End If ElseIf i = 8 Then bstack.tmpstr = W$ + "[" + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If IsNumberNew(bstack, b$, v, False) Then If bstack.lastobj Is Nothing Then er66876: MyErMacro b$, "Not group found at array " + W$, "δεν βρήκα ομάδα στο πίνακα " + W$ GoTo fastexit ElseIf Not TypeOf bstack.lastobj Is Group Then Set bstack.lastobj = Nothing GoTo er66876 End If Set pppp = New ppppLight pppp.arr = False Set pppp.GroupRef = bstack.lastobj v = -2 'Set bstack.lastobj = Nothing 'Set bstack.lastpointer = Nothing Else GoTo er66876 End If GoTo contheretoo ElseIf i = 1 Then If W$ = "THIS" Or W$ = "ΑΥΤΟ" Then W$ = "THIS" If bstack.GroupName = vbNullString Then W$ = vbNullString Else 'If Len(w$) > 5 Then If Len(bstack.UseGroupname) > 0 Then If W$ = "SUPERCLASS" Or W$ = "ΥΠΕΡΚΛΑΣΗ" Then Set pppp = New ppppLight: pppp.PushDim (1): pppp.PushEnd: pppp.arr = True v = 0 W$ = Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) jumpthere: y1 = 0 If GetVar3(bstack, (W$), y1, , , , W$) Then If TypeOf var(y1) Is Group Then If var(y1).IamApointer Then GoTo CONTpointer If Not var(y1).SuperClassList Is Nothing Then Set pppp.item(v) = var(y1).SuperClassList v100 = True GoTo contheretoo End If End If Else If W$ = "SUPERCLASS" Or W$ = "ΥΠΕΡΚΛΑΣΗ" Then MyEr "Double use of SuperClass", "Διπλή χρήση της Υπερκλάσης" Else MissVarName End If GoTo fastexit1 End If Else GoTo jumpthere End If End If If y1 = 0 Then CONTpointer: If GetPointer(bstack, (W$)) Then If bstack.lastpointer.link.IamFloatGroup Then Set safegroup = bstack.lastpointer Do While safegroup.link.IamApointer Set safegroup = safegroup.link If safegroup.link Is Nothing Then GoTo fastexit Loop Set pppp = BoxGroupObj(safegroup.link) Set pppp.refgroup = safegroup i = 5 v = 0 Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing W$ = pppp.CodeName & (Abs(v)) If Len(safegroup.link.LastOpen) > 0 Then If GetVar(bstack, safegroup.link.LastOpen, i) Then GoTo jmp1998 End If Set pppp.item(v) = safegroup.link pppp.item(v).PointerPtr = ObjPtr(safegroup) Set pppp.refgroup = safegroup GoTo contheretoo123 Else If bstack.lastpointer.lasthere = vbNullString Then W$ = "*" + bstack.lastpointer.GroupName Else W$ = bstack.lastpointer.lasthere + "." + bstack.lastpointer.GroupName If GetVar3(bstack, W$, i) Then If var(i).IamGlobal Then W$ = "*" + bstack.lastpointer.GroupName End If End If End If Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing End If End If End If End If conthere3: mm.DataVal 0# mm.DataVal CDbl(-1) mm.DataObj pppp bstack.MoveNameDot W$ depth = depth + 1 ElseIf i = 3 Then '' ???? If IsStrExp(bstack, (W$), W$) Then End If ElseIf i = 6 Then bstack.tmpstr = W$ + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If IsStr1(bstack, b$, W$) Then End If Else SyntaxError GoTo normalexit End If Loop If FastSymbol(b$, "{") Then ec$ = block(b$) Dim nd& Dim oldLL As Long TraceStore bstack, nd&, b$, 0 oldLL = bstack.addlen ' delete true here If True Then SpeedGroup = 1 kolpo = False once = True i = 1 ohere$ = here$ Do bstack.addlen = oldLL bb$ = Mid$(ec$, i) subsentry10: kolpo = False Select Case Execute(bstack, bb$, kolpo, False, loopthis) ' this is a major point Case 0 faultback: thh: If bstack.RetStackTotal - RetStackSize > 0 Then bstack.UseofIf = olduseofif bstack.RetStackDrop bstack.RetStackTotal - RetStackSize End If bstack.addlen = nd& If bstack.ErrorOriginal <> 0 Then b$ = bb$ Else b$ = bb$ + b$ End If SpeedGroup = -1 Set bstack.lastobj = Nothing GoTo normalexit Case 1 bstack.addlen = nd& S3 = bstack.OriginalCode If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If TestShowBypass = False If LastErNum <> 0 Then b$ = vbNullString If FastSymbol(b$, "}") Then If once Then Exit Do Else If Len(bb$) > 0 Then b$ = Right$(ec$, Len(bb$)) + b$ End If here$ = ohere$ Exit Do Case 2 bstack.addlen = 0 If Not kolpo Then i = 1 If bb$ <> "" Then If bb$ = ChrW$(0) Then 'If RetStackSize = bstack.RetStackTotal And bstack.RetStackLookTopVal < 0 Then ' this is a return form other block If RetStackSize >= bstack.RetStackTotal Then If bstack.IsDecimal Then SpeedGroup = 2 SwapStrings b$, bb$ bstack.addlen = nd& GoTo fastexit End If End If 'If bstack.IsInRetStackNumberLong(p) Then 'If LastErNum = -1 Then ' bstack.RetStack.PushLong p ' SpeedGroup = 0 ' bstack.addlen = nd& ' GoTo fastexit 'End If If Not bstack.IsInRetStackString(small$) Then If LastErNum = -1 Then SpeedGroup = 0 bstack.addlen = nd& GoTo fastexit End If p = bstack.isPop3Long(S3, sbi) If p > 0 Then If S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then bb$ = Mid$(ec$, Len(ec$) - p + 1) Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code ElseIf S3 = 0 Then TestShowSub = ec$ + b$ sbi = Len(b$) Else TestShowSub = sbf(S3).sb End If End If bstack.addlen = sbi End If PopStage bstack GoTo subsentry10 Else fulty: MyEr "Fault in Return", "Λάθος στην Επιστροφή" bstack.Flush Exit Do End If Else If InStr(small$, " ") > 0 Then bstack.PushSecondThird S3, sbi If searchsub(0&, bstack.OriginalCode, small$, i, S3, bb$) Then bstack.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead7(bstack, small$, 1) Then GoTo thh GoTo contSub ElseIf bstack.IamChild Then If searchsub(bstack.OriginalCode, FindPrevOriginal(bstack), small$, i, S3, bb$) Then bstack.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead7(bstack, small$, 1) Then GoTo thh contSub: If Len(bb$) = 0 Then If S3 < 0 Then bb$ = Mid$(var(-S3).Code, i) Else bb$ = Mid$(sbf(S3).sb, i) End If sbi = 0 Else If S3 < 0 Then sbi = Len(var(-S3).Code) - i - Len(bb$) + 1 Else sbi = Len(sbf(S3).sb) - i - Len(bb$) + 1 End If End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If End If bstack.addlen = Len(TestShowSub) - i + 1 - Len(bb$) End If GoTo subsentry10 Else jumpbad: If bstack.callx1 < 0 Then bstack.callx1 = 0 small$ = Split(small$, " ")(1) small$ = Left$(small$, Len(small$) - 1) If Not bstack.IsDecimal Then b$ = Right(b$, bstack.LastIdpos - 1 - Len(small$)) End If unknownModule b$, small$ Else If Len(Split(small$, " ")(0)) = 1 Then small$ = Split(small$, " ")(1) unknownLabel b$, small$ Else small$ = Split(small$, " ")(1) unknownSub b$, Left$(small$, Len(small$) - 1) End If End If If bstack.IsDecimal Then p = bstack.Pop3Long(S3, sbi) If bstack.LastIdpos > 0 Then bb$ = Right$(b$, bstack.LastIdpos) ElseIf S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then bb$ = Mid$(ec$, Len(ec$) - p + 1) Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If End If bstack.LastIdpos = 0 bstack.RetStackDrop 3 ' 5 bstack.SubLevel = bstack.SubLevel - 1 GoTo thh End If Else 'If small$ <> "" Then badSubNotFound GoTo jumpbad End If End If End If ElseIf bb$ = "BREAK" Then SpeedGroup = 2 GoTo breakexit Else If subsfc Is Nothing Then Set subsfc = New FastCollection If subsfc.ExistKey(bb$) Then i = subsfc.Value If subsfc.sValue = 0 Then If i = 0 Or i > Len(ec$) Then SwapStrings b$, bb$ SpeedGroup = 2 bstack.addlen = nd& Exit Do Else bb$ = Mid$(ec$, i) End If Else S3 = subsfc.sValue If S3 < 0 Then If i = 0 Or i > Len(var(-S3).Code$) Then SwapStrings b$, bb$ SpeedGroup = 2 bstack.addlen = nd& Exit Do Else GoTo AGAINGOTOLAMBDA End If Else If i = 0 Or i > Len(sbf(S3).sb) Then SwapStrings b$, bb$ SpeedGroup = 2 bstack.addlen = nd& Exit Do End If GoTo AGAINGOTO End If End If GoTo subsentry10 Else If S3 = 0 Then i = PosLabel(bb$, ec$) If i = 0 Or i > Len(ec$) Then GoTo checkother Else subsfc.ItemCreator2 bb$, i, 0 bb$ = Mid$(ec$, i) GoTo subsentry10 End If End If checkother: If S3 < 0 Then i = PosLabel(bb$, var(-S3).Code$) If i = 0 Or i > Len(var(-S3).Code$) Then bstack.LastIdpos = bstack.LastIdpos + Len(b$) SwapStrings b$, bb$ SpeedGroup = 2 bstack.addlen = nd& Exit Do End If subsfc.ItemCreator2 bb$, i, S3 AGAINGOTOLAMBDA: If bstack.SubLevel > 0 Then If Len(var(-S3).Code$) - i > sbi Then bb$ = Mid$(var(-S3).Code$, i, Len(var(-S3).Code$) - i - sbi) Else bb$ = Mid$(var(-S3).Code$, i) sbi = 0 End If Else bb$ = Mid$(var(-S3).Code$, i) sbi = 0 End If Else i = PosLabel(bb$, sbf(S3).sb) If i = 0 Or i > Len(sbf(S3).sb) Then bstack.LastIdpos = bstack.LastIdpos + Len(b$) SwapStrings b$, bb$ SpeedGroup = 2 bstack.addlen = nd& Exit Do End If subsfc.ItemCreator2 bb$, i, S3 AGAINGOTO: If bstack.SubLevel > 0 Then If Len(sbf(S3).sb) - i > sbi Then bb$ = Mid$(sbf(S3).sb, i, Len(sbf(S3).sb) - i - sbi) Else bb$ = Mid$(sbf(S3).sb, i) sbi = 0 End If Else bb$ = Mid$(sbf(S3).sb, i) sbi = 0 End If End If GoTo subsentry10 End If End If Else loopthis = False End If Else If kolpo Then b$ = "BREAK" once = kolpo SpeedGroup = 2: Set bstack.lastobj = Nothing bstack.addlen = nd& GoTo breakexit End If Case Else If FastSymbol(b$, "}") Then If once Then bstack.addlen = nd&: Exit Do Else If Len(bb$) > 0 Then b$ = Right$(ec$, Len(bb$)) + b$ End If here$ = ohere$ bstack.addlen = nd& Exit Do End Select here$ = ohere$ ' If checkbreakEsc(bstack) Then SpeedGroup = 1: bstack.addlen = nd&: Exit Do Loop Else SpeedGroup = Abs(FastSymbol(b$, "}")) End If End If breakexit: Set bstack.lastobj = Nothing While mm.Total > 0 y1 = mm.PopVal v = mm.PopVal Set pppp = mm.PopObj If y1 < 0 Then ElseIf v <> -1 Then If v <> -100 Then If Not MyIsObject(pppp.item(v)) Then pppp.item(v).ToDelete = True If pppp.IhaveClass Then Set pppp.item(v) = CopyGroupObj(var(y1), pppp.IhaveClass, pppp.GroupRef) Else Set pppp.item(v) = CopyGroupObj(var(y1)) End If Else If Not pppp.refgroup Is Nothing Then Set safegroup = pppp.refgroup safegroup.link.ToDelete = True Set safegroup.LinkRefPointer = CopyGroupObj(var(y1)) safegroup.link.PointerPtr = ObjPtr(safegroup) ' pppp.item(v).ToDelete = True safegroup.LastOpen = vbNullString safegroup.lasthere = vbNullString Set safegroup = Nothing Else pppp.item(v).ToDelete = True If pppp.arr Then Set pppp.item(v) = CopyGroupObj(var(y1), pppp.IhaveClass, pppp.GroupRef) Else Set pppp.item(v) = CopyGroupObj(var(y1)) End If End If End If Else ' v=-100 If pppp.arr Then v = 0 If Not MyIsObject(pppp.item(v)) Then Set pppp.item(v) = CopyGroupObj(var(y1)) Else Set pppp.item(v) = CopyGroup1(var(y1), pppp.item(v)) End If Else pppp.item(v).ToDelete = True Set pppp.item(v) = CopyGroupObj(var(y1)) End If End If End If Wend normalexit: bstack.DropNdot depth + 1 If SpeedGroup > 1 Then If bstack.RetStackTotal - RetStackSize > 0 Then bstack.UseofIf = olduseofif bstack.RetStackDrop bstack.RetStackTotal - RetStackSize End If End If bstack.jump = oldjump bstack.IFCTRL = oldifctrl Else i = W$ = "." If v >= 0 Then W$ = pppp.CodeName & (v) Else W$ = pppp.CodeName & (Abs(v)) End If If Len(pppp.item(v).LastOpen) > 0 Then If GetVar(bstack, pppp.item(v).LastOpen, i) Then jump1991: Set safegroup = var(i) If safegroup.lasthere = here$ Then W$ = safegroup.GroupName W$ = Left$(W$, Len(W$) - 1) Else LinkGroup bstack, W$, var(i) makegroup bstack, W$, i End If Set safegroup = Nothing GoTo cont2020 End If End If Set safegroup = pppp.item(v) If safegroup Is Nothing Then GoTo fastexit If safegroup.IamApointer Then If safegroup.link.IamFloatGroup Then If Len(safegroup.link.LastOpen) > 0 Then If GetVar(bstack, safegroup.link.LastOpen, i) Then GoTo jump1991 End If Set pppp = BoxGroupVar(safegroup.link) pppp.item(0).PointerPtr = ObjPtr(safegroup) v = 0 Else If Left$(Prefix$, 1) = "@" Then W$ = safegroup.lasthere + "." + safegroup.GroupName GoTo cont2020 Else bstack.MoveNameDot safegroup.lasthere + "." + safegroup.GroupName v = 0 GoTo contheretoo1 End If End If Else y1 = globalvarGroup(W$, CVar(New Group)) End If If safegroup.LastOpen <> vbNullString Then If GetVar(bstack, (safegroup.LastOpen), y1, True) Then If safegroup.lasthere$ = here$ Then W$ = safegroup.LastOpen Else If safegroup.lasthere$ = vbNullString Then W$ = safegroup.LastOpen Else W$ = safegroup.lasthere$ + "." + safegroup.LastOpen End If End If GoTo cont2020 Else If safegroup.link Is Nothing Then If safegroup.IamFloatGroup Then safegroup.LastOpen = vbNullString safegroup.lasthere$ = vbNullString End If Else If safegroup.link.IamFloatGroup Then safegroup.LastOpen = vbNullString safegroup.lasthere$ = vbNullString End If End If End If UnFloatGroup bstack, W$, y1, pppp.item(v), , True globalvarGroup W$, y1, True, True Else If y1 = 0 Then y1 = globalvarGroup(W$, y1) UnFloatGroup bstack, W$, y1, pppp.item(v), , True globalvarGroup W$, y1, True, True var(y1).PointerPtr = pppp.item(v).PointerPtr pppp.item(v).lasthere = here pppp.item(v).LastOpen = W$ var(y1).lasthere = here var(y1).LastOpen = W$ End If cont2020: If Len(Prefix) > 0 Then If Prefix = "@R2" Then NeoCall2 bstack, W$ + "." + ChrW(&H1FFF) + ":=()", ok SpeedGroup = Abs(ok) GoTo CONTlastEtnum ElseIf Prefix = "@®" Then If i Then bstack.tmpstr = W$ + "." + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) SpeedGroup = Abs(MyRead(1, bstack, b$, 1)) GoTo CONTlastEtnum Else If var(y1).HasStrValue Then SpeedGroup = Abs(MyRead(1, bstack, W$ + "$", 1)) GoTo CONTlastEtnum Else SpeedGroup = Abs(MyRead(1, bstack, (W$), 1)) GoTo CONTlastEtnum End If End If Else If i Then bstack.tmpstr = vbCrLf + Prefix + " " + W$ + "." + Left$(b$, 1) Else If var(y1).HasStrValue Then bstack.tmpstr = vbCrLf + Prefix + " " + W$ + "$ " + Left$(b$, 1) Else bstack.tmpstr = vbCrLf + Prefix + " " + W$ + " " + Left$(b$, 1) End If End If 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) End If Else If Left$(b$, 2) = Chr$(3) + "(" Then If var(y1).HasStrValue Then bstack.tmpstr = W$ + "$( " Mid$(b$, 1, 2) = " " Else bstack.tmpstr = W$ + "( " ''+ Left$(b$, 1) Mid$(b$, 1, 2) = " " End If Else If Left$(b$, 1) = Chr$(3) Then Mid$(b$, 1, 1) = " " If MaybeIsSymbol(b$, "/*-+=~^&|<>") Then bstack.tmpstr = W$ + Left$(b$, 1) Else bstack.tmpstr = W$ + "." + Left$(b$, 1) End If End If If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) End If SpeedGroup = Execute(bstack, b$, True, , , , , True) CONTlastEtnum: If LastErNum <> 0 Then If FK$(13) = vbNullString Then FK$(13) = GetNextLine((sbf(Abs(bstack.OriginalCode)).sb)) End If If safegroup Is Nothing Then ' DO NOTHING ElseIf safegroup.IamApointer Then If safegroup.LastOpen = vbNullString Then If Len(safegroup.lasthere) = 0 Then safegroup.link.lasthere = vbNullString safegroup.link.LastOpen = vbNullString Set tempRef = pppp.GroupRef safegroup.link.ToDelete = True Set safegroup.LinkRefPointer = CopyGroupObj(var(y1)) Set safegroup.link.LinkRef = pppp.GroupRef End If End If ElseIf Vars < y1 Then Set safegroup = pppp.item(v) If safegroup.IamTeam Then safegroup.ToDelete = True Set safegroup = Nothing Set pppp.item(v) = CopyGroupObj(var(y1), pppp.IhaveClass, pppp.GroupRef) Else safegroup.ToDelete = True Set safegroup = Nothing Set pppp.item(v) = CopyGroupObj(var(y1)) End If var(y1) = 0& End If End If fastexit: If SpeedGroup <= 0 Then SpeedGroup = SpeedGroup + 1 fastexit1: bstack.ResetSkip var2used = Vars varhash.ReduceHash Vname, var() sb2used = subs subHash.ReduceHash snames, sbf() numid.poptop funid.poptop strfunid.poptop strid.poptop End Function Public Sub Thing(W$, v$) '' from w$ input this value V$... '' general input On Error Resume Next Dim it As Long, pppp As mArray If Len(W$) < 2 Then Exit Sub If AscW(W$) = 65 Then On Error Resume Next Err.Clear Set pppp = var(Split(Mid$(W$, 2))(0)) '' "A...16charRef....ItemNo" If Err.Number > 0 Then Exit Sub it = val(Split(Mid$(W$, 2))(1)) If pppp.ItemType(it) = doc Then pppp.item(it).textDoc = v$ ' no checked yet Else pppp.item(it) = pppp.item(it) + v$ End If ElseIf AscW(W$) = 86 Then it = val("0" + Mid$(W$, 2)) ''"VItemNo" If CheckInt64(var(it)) Then ' never ElseIf VarTypeName(var(it)) = doc Then var(it).textDoc = v$ ' no checked yet Else var(it) = var(it) + v$ End If Else ' CAN'T READ End If End Sub Function rinstr(a As String, b As String, Optional ByVal fr As Long) As Long Dim i i = Len(a) fr = i - fr If fr < 0 Or fr > i Then fr = i + 1 If fr > 0 Then rinstr = InStrRev(a, b, fr) End Function Function rinstrb(a As String, b As String, Optional ByVal fr As Long) As Long ' Dim i As Long, j As Long fr = fr - LenB(b) + 1 If fr < 0 Then fr = LenB(a) + 1 Do j = i i = InStrB(j + 1, a, b) Loop Until i = 0 Or i > fr rinstrb = j End Function Function RMAX(ByVal q As Single, ByVal W As Single) As Single If q > W Then RMAX = q Else RMAX = W End If End Function Function RMIN(ByVal q As Single, ByVal W As Single) As Single If q < W Then RMIN = q Else RMIN = W End If End Function Public Function GetTaskId() As Long taskid = taskid + 1 If taskid = 10000 Then taskid = 1 GetTaskId = taskid End Function Sub Dispose() 'use strtemp On Error Resume Next Dim r$ While ISSTRINGA(kill2$, r$) KillFile strTemp + r$ Wend End Sub Public Sub NeoSubMain() ' need to read registry form sub main On Error Resume Next maxlonglong = CDec("18446744073709551616") limitlonglong = CDec("9223372036854775808") Dim i As Long For i = 0 To 32 Pow2(i) = CCur(2 ^ i) Pow2minusOne(i) = Pow2(i) - 1 Next i Alphabet = StrConv("0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ", vbFromUnicode) '' From 9.6 by default we have no round to 13d for double One64 = CopyCur64(0.0001@) Zero64 = CopyCur64(0@) EditTabWidth = 4 tParam.cbSize = LenB(tParam) tParam.iTabLength = 4 ReportTabWidth = 8 RoundDouble = False SetUp64 ' for Encoder64/Decoder64 AskCancelGR = "ΑΚΥΡΟ" AskOkGR = "ΕΝΤΑΞΕΙ" LoadFileCaptionGR = "Φόρτωσε Αρχείο" SaveFileCaptionGR = "Σώσε Αρχείο" SelectFolderCaptionGR = "Επιλογή Φακέλου" SelectFolderButtonGR = "*σύρε δεξιά για επιλογή*" FontSelectorGr = "Γραμματοσειρά" ColorSelectorGr = "Χρωματολόγιο" SetUpGR = "Ρυθμίσεις" AskCancelEn = "CANCEL" AskOkEn = "OK" SetUpEn = "Set Up" LoadFileCaptionEn = "Load File" SaveFileCaptionEn = "Save File" SelectFolderCaptionEn = "Select Folder" SelectFolderButtonEn = "*slide right to select*" FontSelectorEn = "Font Selector" ColorSelectorEn = "Color Selector" BigPi = CDec("31415926535897932384626433832") * 1E-28 INK$ = vbNullString 'UINK$ = VbNullString MINK$ = vbNullString MKEY$ = vbNullString RandomizeIt rndbase, 0 ClearCatalog SetLibHdls LCID_DEF = LCID_def1() Mod &H10000 DefCodePage = GetCodePage(OsInfo.LangNonUnicodeCode) UserCodePage = DefCodePage UseTabInForm1Text1 = True ShowBooleanAsString = True Clid = LCID_DEF If Clid = 1032 Then DefBooleanString = ";Αληθές;Ψευδές" Else DefBooleanString = ";\T\r\u\e;\F\a\l\s\e" End If NowDec$ = GetlocaleString(LOCALE_SDECIMAL) NowThou$ = GetlocaleString(LOCALE_STHOUSAND) If dv15 <> 0 Then l_complete = False s_complete = False DisableProcessWindowsGhosting Set HelpStack = New basetask Set oprinter = New cDIBSection Set Basestack1.Sorosref = globalstack Set subHash = New sbHash Set varhash = New Hash Set comhash = New coHash Set numid = New idHash Set funid = New idHash Set strid = New idHash Set strfunid = New idHash GoTo there End If dv15 = 1440 / DpiScrX GetMonitorsNow DisableProcessWindowsGhosting With ScrInfo(Console) If IsWine Then players(0).MAXXGRAPH = .Width - 1 players(0).MAXYGRAPH = .Height - 1 End If End With '' BY DEAFULT IS FALSE priorityOr = False ' TRUE OR FALSE AND FALSE GIVE -1 BECAUSE OR AND XOR PROCESS LEFT FIRST TRUE OR ( FALSE AND FALSE) '' WITH priorityOr = FALSE WE HAVE FLAT SYSTEM.........TRUE OR FALSE AND FALSE GIVE 0 OperatingSystem dv20 = 24.5 Call GetSystemTimeAsFileTime(basictimer) Randomize basictimer JetPrefixUser = JetPrefixHelp JetPostfixUser = JetPostfixHelp JetPostfix = JetPostfixHelp JetPrefix = JetPrefixHelp basickey = "Software\M2000v" & VerMajor & "\" + Mid$(App.path, rinstr(App.path, "\") + 1) + "\" + App.EXENAME + "\" ' by default 'AddTwipsTop = 4 * Screen.TwipsPerPixelY casesensitive = False pagio$ = "ENGLISH" pagiohtml$ = "DARK" REFRESHRATE = 40 SizeDialog = 1 helpSizeDialog = 1 Settings = "time,normal,push" With ScrInfo(Console) selectorLastX = .Height / 4 + .Left selectorLastY = .Width / 4 + .top AskLastX = .Height / 4 + .Left AskLastY = .Width / 4 + .top End With sb2used = 0 ReDim sbf(500) As modfun var2used = 0 ReDim var(3000) As Variant StartingRes 'Dim iccex As tagInitCommonControlsEx 'With iccex ' .lngSize = LenB(iccex) ' .lngICC = ICC_USEREX_CLASSES 'End With 'InitCommonControlsEx iccex clickMe2 = -1 ''Dim soros As New mStiva Dim t As Long ReDim q(0) As target Set Basestack1.Sorosref = globalstack taskid = 999 DisableMidi beat = 400 ' beat of 1/16 baseNote = 23 octava = 4 NOTA = 0 ENTASI = 127 '' volume voices(0) = "CC#" there: Randomize allcommands comhash NumberId numid, funid, numidbackup, funidbackup StringId strid, strfunid, stridbackup, strfunidbackup Set zones = New FastCollection TimeZones zones Set TaskMaster = New TaskMaster TaskMaster.Interval = 5 beeperBEAT = 300 MediaPlayer1.FileName = vbNullString defFontname = "Verdana" my_system = OperatingPlatform vol = 50 MediaPlayer1.setLeftVolume vol * 10 MediaPlayer1.setRightVolume vol * 10 deep = 10000 ReDim MyDM(1 To 1) As Byte DXP = Screen.TwipsPerPixelX DYP = Screen.TwipsPerPixelY Load Form5 If Not l_complete Then Exit Sub Else Form1.something End If End Sub Sub TerminateM2000() NoAction = False DelTemp 'Set DisStack.Owner = Nothing Set Basestack1.Owner = Nothing Set LastGlist = Nothing Set LastGlist2 = Nothing If form5iamloaded Then If IsWine Then Form5.BackPort Else Unload Form5 End If End If End Sub Public Sub terminatefinal() Set NullPointer = Nothing RemoveAllFonts Set globalstack = Nothing Set Basestack1 = Nothing CloseAllConnections ' new for ADO we keep objects not the connections CleanupLibHandles Set globalstack = Nothing Set mycoder = Nothing Set subHash = Nothing Set comhash = Nothing Set numid = Nothing Set funid = Nothing Set strid = Nothing Set strfunid = Nothing Set Prof = Nothing Set MediaPlayer1 = Nothing Set MediaBack1 = Nothing On Error Resume Next Erase sbf() Erase var() s_complete = False l_complete = False End Sub Function GetArr(bstack As basetask, b$, p As Variant, s$, skip As Long, lookCompOrTuple As Boolean) As Boolean Dim pppp As tuple, x1 As Long, usehandler As mHandler, r, that As BigInteger Dim obj1 As Object, val1 As Variant x1 = 1 If skip <> 0 Then FastSymbol b$, "," jmp11: If lookOne(b$, ")") Then Set pppp = New tuple: pppp.myarrbase = 0: pppp.PushDim (1&): pppp.PushEnd: pppp.arr = True If bstack.lastobj Is Nothing Then pppp.item(0&) = p Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If Set pppp.item(0&) = bstack.lastobj Set bstack.lastobj = Nothing End If ' Set bstack.lastobj = pppp p = 0 GetArr = True GoTo cont111 Exit Function End If contSecond: Set obj1 = bstack.lastobj Set bstack.lastobj = Nothing SwapVariant p, val1 p = 0 If IsExp(bstack, b$, p) Then x1 = 3 If Left$(b$, 1) = " " Then b$ = NLtrim(b$) If LCase(Left$(b$, 2)) = "i)" Then lookCompOrTuple = True If Not bstack.lastobj Is Nothing Then p = 0 If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj p = CDbl(StrConv(that.Value, vbUnicode)) End If Set bstack.lastobj = Nothing End If ' so p is the imaginary pert If Not obj1 Is Nothing Then val1 = 0 If TypeOf obj1 Is BigInteger Then Set that = obj1 val1 = CDbl(StrConv(that.Value, vbUnicode)) End If Set obj1 = Nothing End If p = nMath2.cxNew(CDbl(val1), CDbl(p)) Mid$(b$, 1, 2) = " " GetArr = True Exit Function Else Set pppp = New tuple: pppp.myarrbase = 0: pppp.PushDim (2&): pppp.PushEnd: pppp.arr = True End If ' feed item 0 If Not obj1 Is Nothing Then Set pppp.item(0) = obj1 Else pppp.item(0) = val1 End If ' feed item 1 If bstack.lastobj Is Nothing Then pppp.item(1&) = p Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If Set pppp.item(1&) = bstack.lastobj Set bstack.lastobj = Nothing End If ElseIf IsStrExp(bstack, b$, s$, False) Then x1 = 3 Set pppp = New tuple: pppp.myarrbase = 0: pppp.PushDim (2&): pppp.PushEnd: pppp.arr = True ' feed 0 If Not obj1 Is Nothing Then Set pppp.item(0&) = obj1 Else pppp.item(0&) = val1 End If If bstack.lastobj Is Nothing Then pppp.item(1&) = CVar(s$) Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If Set pppp.item(1&) = bstack.lastobj Set bstack.lastobj = Nothing End If End If val1 = 0 Set obj1 = Nothing Else If FastSymbol(b$, ",") Then ' means empty ' GetArr = FastSymbol(b$, ")") Set pppp = New tuple: pppp.myarrbase = 0:: pppp.arr = True p = 0 GoTo cont111 Exit Function Else If IsExpBig(bstack, b$, p) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If End If ElseIf IsStrExp(bstack, b$, s$, False) Then If bstack.lastobj Is Nothing Then p = "" SwapString2Variant s$, p ElseIf TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If End If If FastSymbol(b$, ",") Then If x1 = 1 Then skip = 1: GoTo jmp11 If lookOne(b$, ")") Then GoTo CONTaabb GoTo contSecond End If lookCompOrTuple = True GetArr = FastSymbol1(b$, ")") Exit Function End If End If CONTaabb: Do While MaybeIsSymbol(b$, ",)") IsSymbol b$, "," If pppp Is Nothing Then Set pppp = New tuple: pppp.myarrbase = 0:: pppp.arr = True 'pppp.PushDim (1): pppp.PushEnd: pppp.Arr = True End If If lookOne(b$, ")") Then ' x1 = x1 + 1 If x1 = 1 Then pppp.SerialItem 0, x1, 10 If bstack.lastobj Is Nothing Then pppp.item(0&) = p Else Set pppp.item(0) = bstack.lastobj Set bstack.lastobj = Nothing End If Else pppp.SerialItem 0, x1 - 1, 10 End If Exit Do ElseIf IsExp(bstack, b$, p) Then x1 = x1 + 1 pppp.SerialItem 0, x1, 10 If bstack.lastobj Is Nothing Then pppp.item(x1 - 2) = p Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If Set pppp.item(x1 - 2) = bstack.lastobj Set bstack.lastobj = Nothing End If ElseIf IsStrExp(bstack, b$, s$, False) Then x1 = x1 + 1 pppp.SerialItem 0, x1, 10 If bstack.lastobj Is Nothing Then pppp.item(x1 - 2) = s$ Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If Set pppp.item(x1 - 2) = bstack.lastobj Set bstack.lastobj = Nothing End If End If Loop p = 0 cont111: Set usehandler = New mHandler Set bstack.lastobj = usehandler usehandler.t1 = 3 Set usehandler.objref = pppp Set usehandler = Nothing If FastSymbol(b$, ")#", , 2) Then GetArr = ExpMatrix(bstack, b$, p) If GetArr Then lookCompOrTuple = True End If Else GetArr = FastSymbol1(b$, ")") End If End Function Function IsExpBig(basestack As basetask, a$, r As Variant, Optional ByVal noand1 As Boolean = True, Optional flatobject As Boolean = False, Optional Comp As Boolean = True, Optional nostring As Boolean) As Boolean Dim par As Long, parin As Long, conthere As Boolean If LastErNum = -2 Then LastErNum = 0 If a$ = vbNullString Then Exit Function If Left$(a$, 2) = vbCrLf Then Exit Function IsExpBig = IsExpA(basestack, a$, r, par, noand1, (Comp), , nostring) again: If par > 0 Then If lookOne(a$, ",") Then IsExpBig = GetArr(basestack, a$, r, "", 1, conthere) If LastErNum = -2 Then IsExpBig = False If IsExpBig Then par = par - 1 If conthere Then If Len(a$) > 0 Then IsExpBig = IsExpA(basestack, a$, r, par, noand1, Comp, conthere) End If End If If par > 0 Then GoTo again End If End If End If End If If Not IsExpBig Then If basestack.usestack Then IsExpBig = IsNumber(basestack, a$, r) End If End If If LastErNum = -2 Then IsExpBig = False While par > 0 IsExpBig = FastSymbol(a$, ")") par = par - 1 Wend If flatobject Then basestack.flatobject End Function Private Function MyTrimLi(s$, l As Long) As Long Dim i& Dim P2 As Long, P1 As Integer, p4 As Long If l > Len(s) Then MyTrimLi = Len(s) + 1: Exit Function If l <= 0 Then MyTrimLi = 1: Exit Function l = l - 1 i = Len(s) P2 = StrPtr(s) + l * 2: p4 = P2 + i * 2 For i = P2 To p4 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 9 Case Else MyTrimLi = (i - P2) \ 2 + 1 + l Exit Function End Select Next i MyTrimLi = Len(s) + 1 End Function Private Function MyTrimLi2(s$, l As Long) As Long Dim i& Dim P2 As Long, P1 As Integer, p4 As Long If l > Len(s) Then MyTrimLi2 = Len(s) + 1: Exit Function If l <= 0 Then MyTrimLi2 = 1: Exit Function l = l - 1 i = Len(s) P2 = StrPtr(s) + l * 2: p4 = P2 + i * 2 For i = P2 To p4 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 7, 9 Case Else MyTrimLi2 = (i - P2) \ 2 + 1 + l Exit Function End Select Next i MyTrimLi2 = Len(s) + 1 End Function Function FastOperator(a$, c$, i As Long, Optional cl As Long = 1, Optional Remove As Boolean = True) As Boolean Dim j As Long If i <= 0 Then i = 1 j = Len(a$) If j = 0 Then Exit Function i = MyTrimLi(a$, i) If i > j Then i = 1 ' no spaces If j - i < cl - 1 Then Exit Function If c$ = Mid$(a$, i, cl) Then If Remove Then Mid$(a$, i, cl) = space$(cl) FastOperator = True End If End Function Function FastType(a$, c$) As Boolean Dim W$, i As Long i = 1 If FastPureLabel(a$, W$, i, , True) = 1 Then If c$ = W$ Then a$ = Mid$(a$, i) FastType = True End If End If End Function Function IsNumber(bstack As basetask, a$, r As Variant, Optional flatobject As Boolean = False, Optional sg As Integer = 1) As Boolean Dim sng&, ex$, ig$, DE$, i As Long, sg1 As Boolean, j As Integer If Len(a$) = 0 Then Exit Function If MaybeIsSymbol2(a$, "#+-(\'{" + """", sng&) Then '", sng&) 'If MaybeIsSymbol2(a$, "#+-(\'", sng&) Then Select Case Mid$(a$, sng&, 1) Case "(", "\" Exit Function Case """" r = blockString(a$, 34, sng& + 1) IsNumber = FastSymbol(a$, Chr$(34)) If r = "" Then Dim rr$ Do While a$ <> "" Oldway a$, rr$ r = r + rr$ If Len(a$) > 0 Then If AscW(a$) = 34 Then a$ = Mid$(a$, 2) r = r + Chr$(34) + blockString(a$, 34) IsNumber = FastSymbol(a$, Chr$(34)) Else Exit Do End If Else Exit Do End If Loop End If Exit Function Case "{" r = blockString(a$, 125, sng& + 1) IsNumber = FastSymbol(a$, "}") Exit Function End Select sng& = sng& - 1 Do While sng& < Len(a$) sng& = sng& + 1 Select Case Mid$(a$, sng&, 1) Case "#" If Len(a$) > sng& Then If MaybeIsSymbolNoSpace(Mid$(a$, sng& + 1, 1), "[0-9A-Fa-f]") Then ex$ = "0x00" + Mid$(a$, sng& + 1, 6) If Len(ex$) < 10 Then Exit Function If IsNumberCheck(ex$, r) Then If ex$ <> "" Then Else ex$ = Right$("00000000" + Mid$(a$, sng& + 1, 6), 8) a$ = Mid$(a$, sng& + 7) r = sg * -(CDbl(UNPACKLNG(Right$(ex$, 2)) * 65536#) + CDbl(UNPACKLNG(Mid$(ex$, 5, 2)) * 256#) + CDbl(UNPACKLNG(Mid$(ex$, 3, 2)))) sg = 1 If MaybeIsSymbolNoSpace(Mid$(a$, 1, 1), "[0-9]") Then MyEr "Too many digits", "Πολλά ψηφία" IsNumber = False Else IsNumber = True End If Exit Function End If End If Else End If Else '' out End If Exit Function Case " ", ChrW(160) Case "+" If Abs(sg) < 10 Then sg = sg * 10 Case "-" sg = -sg Case Else Exit Do End Select Loop End If If sng& > 1 Then Mid$(a$, 1, sng& - 1) = space$(sng& - 1) If MaybeIsSymbol3(a$, ".", sng&) Then If Len(a$) = sng& Then ig$ = "0" DE$ = "." GoTo conthere ElseIf Mid$(a$, sng& + 1, 1) Like "[0-9]" Then ig$ = "0" DE$ = "." GoTo conthere Else ' we have an identifier with . like .x IsNumber = IsNumberNew(bstack, a$, r, flatobject) If flatobject Then bstack.flatobject Exit Function End If ElseIf Len(a$) < sng& Then IsNumber = False: Exit Function Else i = AscW(Mid$(a$, sng&, 1)) If i < 10 Or i > 63 Then ' HERE PROCESS UNARY SIGNS?? IsNumber = IsNumberNew(bstack, a$, r, flatobject) If flatobject Then If Not bstack.lastobj Is Nothing Then If Not TypeOf bstack.lastobj Is BigInteger Then Set bstack.lastobj = Nothing End If End If Exit Function Else i = 0 j = 0 If Mid$(a$, sng&, 1) = "0" Then If LCase(Mid$(a$, sng& + 1, 1)) Like "[xχ]" Then jumphere1: sng& = sng& + 2 Do While sng& <= Len(a$) Select Case Mid$(a$, sng&, 1) Case "A" To "F", "a" To "f", "0" To "9" i = i + 1 Case "_" If i = 0 Then Exit Do i = i + 1 j = j + 1 Case Else Exit Do End Select sng& = sng& + 1 Loop If i - j > 16 Then OverflowValue IsNumber = False Mid$(a$, 1, sng& - 1) = space$(sng& - 1) Exit Function End If If Mid$(a$, sng&, 1) = "%" Then If i - j > 4 Then OverflowValue vbInteger IsNumber = False Exit Function End If If j > 0 Then r = CInt("&H" + Replace$(Mid$(a$, sng - i, i), "_", "")) Else r = CInt("&H" + Mid$(a$, sng - i, i)) End If sng& = sng& + 1 ElseIf LCase$(Mid$(a$, sng&, 1)) = "u" Then If Not LCase$(Mid$(a$, sng& + 1, 1)) = "b" Then SyntaxError IsNumber = False Exit Function End If If i - j > 2 Then OverflowValue vbByte IsNumber = False Exit Function End If If j > 0 Then r = CByte("&H" + Replace$(Mid$(a$, sng - i, i), "_", "")) Else r = CByte("&H" + Mid$(a$, sng - i, i)) End If sng& = sng& + 2 Else If i - j > 8 Then ' maybe long long or decimal If Mid$(a$, sng&, 2) = "&&" Then If i - j > 16 Then OverflowValue 20 IsNumber = False Exit Function End If If j > 0 Then r = cInt64("&H" + Replace$(Mid$(a$, sng - i, i), "_", "")) Else r = cInt64("&H" + Mid$(a$, sng - i, i)) End If sng& = sng& + 2 ElseIf Mid$(a$, sng&, 1) = "&" Then OverflowValue vbLong IsNumber = False Exit Function Else If j > 0 Then r = CDec(cInt64("&H" + Replace$(Mid$(a$, sng - i, i), "_", ""))) Else r = CDec(cInt64("&H" + Mid$(a$, sng - i, i))) End If If r < 0 Then r = r + maxlonglong If Mid$(a$, sng&, 1) = "@" Then sng& = sng& + 1 End If End If ElseIf Mid$(a$, sng&, 2) = "&&" Then If j > 0 Then r = cInt64("&H" + Replace$(Mid$(a$, sng - i, i), "_", "")) Else r = cInt64("&H" + Mid$(a$, sng - i, i)) End If sng& = sng& + 2 ElseIf Mid$(a$, sng&, 1) = "&" Then If j > 0 Then r = CLng("&H" + Replace$(Mid$(a$, sng - i, i), "_", "")) Else r = CLng("&H" + Mid$(a$, sng - i, i)) End If sng& = sng& + 1 ElseIf Mid$(a$, sng&, 1) = "@" Then If j > 0 Then r = CDec(HexToUnsigned(Replace$(Mid$(a$, sng - i, i), "_", ""))) Else r = CDec(HexToUnsigned(Mid$(a$, sng - i, i))) End If sng& = sng& + 1 Else If j > 0 Then r = HexToUnsigned(Replace$(Mid$(a$, sng - i, i), "_", "")) Else r = HexToUnsigned(Mid$(a$, sng - i, i)) End If IsNumber = True End If End If Mid$(a$, 1, sng& - 1) = space$(sng& - 1) IsNumber = True Exit Function End If Else If Mid$(a$, sng&, 1) = "&" Then If LCase$(Mid$(a$, sng& + 1, 1)) = "h" Then ' check for name not number FastPureLabel a$, DE$, sng& + 1, False, , , False DE$ = LCase(DE$) For i = 2 To Len(DE$) If InStr("01234567890abcdef", Mid$(DE$, i, 1)) = 0 Then Exit Function End If Exit For Next For i = 3 To Len(DE$) If InStr("01234567890abcdef_", Mid$(DE$, i, 1)) = 0 Then Exit Function End If Next DE$ = "" i = 0 GoTo jumphere1 End If IsNumber = False Exit Function ElseIf Not Mid$(a$, sng&, 1) Like "[1-9]" Then IsNumber = False Exit Function End If End If Dim repl As Boolean Do While sng& <= Len(a$) Select Case Mid$(a$, sng&, 1) Case "0" To "9" i = i + 1 Case "_" i = i + 1 repl = True Case "." ig$ = Mid$(a$, sng& - i, i) If repl Then repl = False: ig$ = Replace(ig$, "_", "") DE$ = "." Exit Do Case Else ig$ = Mid$(a$, sng& - i, i) If repl Then repl = False: ig$ = Replace(ig$, "_", "") Exit Do End Select sng& = sng& + 1 Loop If Len(ig$) = 0 Then ig$ = Mid$(a$, sng& - i, i) If repl Then repl = False: ig$ = Replace(ig$, "_", "") End If End If If Len(DE$) = 0 Then If Len(a$) > sng& Then If InStr("EeΕε", Mid$(a$, sng&, 1)) > 0 Then If InStr("1234567890+-", Mid$(a$, sng& + 1, 1)) > 0 Then DE$ = "." GoTo cont123 End If End If End If Else conthere: sng& = sng& + 1 cont123: i = 0 repl = False Do While sng& <= Len(a$) Select Case Mid$(a$, sng&, 1) Case "0" To "9" i = i + 1 Case "_" i = i + 1 repl = True Case "E", "e", "Ε", "ε" If ex$ = vbNullString Then sg1 = True ex$ = "E" Exit Do End If Case Else Exit Do End Select sng& = sng& + 1 Loop If i > 0 Then DE$ = DE$ + Mid$(a$, sng& - i, i) If repl Then repl = False: DE$ = Replace(DE$, "_", "") End If If sg1 Then sng& = sng& + 1 i = 0 Do While sng& <= Len(a$) Select Case Mid$(a$, sng&, 1) Case "0" To "9" i = i + 1 Case "+", "-" If Len(ex$) = 1 Then i = i + 1 Else Exit Do End If Case Else Exit Do End Select sng& = sng& + 1 Loop If i > 0 Then ex$ = ex$ + Mid$(a$, sng& - i, i) sng = sng - Len(ex$) End If End If If ex$ <> "" Then If Len(ex$) < 3 Then If ex$ = "E" Then ex$ = "0" ElseIf ex$ = "E-" Or ex$ = "E+" Then sng = sng + 2 End If End If If val(Mid$(ex$, 2)) > 308 Or val(Mid$(ex$, 2)) < -324 Then r = 0 ' val(ig$ & DE$) sng = sng - Len(ex$) ex$ = vbNullString MyEr "Exponet Overflow", "Υπερχείλιση Εκθέτη" Mid$(a$, 1, sng& - 1) = space$(sng& - 1) IsNumber = False Exit Function Else sng = sng + Len(ex$) If sng <= Len(a$) Then If Asc(Mid$(a$, sng, 1)) = 126 Then Mid$(a$, sng, 1) = " " If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = DefaultDec$ On Error Resume Next r = CSng(ig$ + DE$ + ex$) If Err.Number = 6 Then Err.Clear Mid$(a$, 1, sng& - 1) = space$(sng& - 1) OverflowValue vbSingle Exit Function Err.Clear Exit Function End If Else On Error Resume Next r = val(ig$ + DE$ + ex$) If Err.Number = 6 Then Err.Clear Mid$(a$, 1, sng& - 1) = space$(sng& - 1) OverflowValue vbDouble Exit Function End If End If Else On Error Resume Next r = val(ig$ + DE$ + ex$) If Err.Number = 6 Then Err.Clear Mid$(a$, 1, sng& - 1) = space$(sng& - 1) OverflowValue vbDouble Exit Function End If End If On Error GoTo 0 End If Else If sg < 0 Then ig$ = "-" + ig$: sg = 2 End If If sng <= Len(a$) Then On Error Resume Next Select Case Asc(Mid$(a$, sng, 1)) Case 64 Mid$(a$, sng, 1) = " " If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = DefaultDec$ r = CDec(ig$ + DE$) If Err.Number = 6 Then Err.Clear OverflowValue vbDecimal 'If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = "." 'R = val(ig$ + DE$) End If Case 35 Mid$(a$, sng, 1) = " " If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = DefaultDec$ r = CCur(ig$ + DE$) If Err.Number = 6 Then Err.Clear OverflowValue vbCurrency 'If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = "." 'R = val(ig$ + DE$) End If Case 38 If Mid$(a$, sng + 1, 1) = "&" Then Mid$(a$, sng, 2) = " " r = cInt64(ig$) If Err.Number = 6 Or CDec(ig$) <> r Then Err.Clear OverflowValue 20 End If Else Mid$(a$, sng, 1) = " " r = CLng(ig$) If Err.Number = 6 Then Err.Clear OverflowValue vbLong End If End If Case 37 Mid$(a$, sng, 1) = " " If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = DefaultDec$ r = CInt(ig$) If Err.Number = 6 Then Err.Clear 'R = val(ig$) OverflowValue vbInteger End If Case 126 Mid$(a$, sng, 1) = " " If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = DefaultDec$ r = CSng(ig$ + DE$) If Err.Number = 6 Then Err.Clear OverflowValue vbSingle 'If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = "." 'R = val(ig$ + DE$) End If Case 117, 85 Select Case Mid$(a$, sng + 1, 1) Case "b", "B" Mid$(a$, sng, 2) = " " sg = 1 r = CByte(Abs(val(ig$))) If Err Then OverflowValue vbByte IsNumber = False Exit Function End If Case "d", "D" Mid$(a$, sng, 2) = " " sg = 1 r = CDate(Abs(val(ig$ + DE$))) Case Else Mid$(a$, sng, 1) = " " r = 0 Set bstack.lastobj = Module13.CreateBigInteger(ig$) Mid$(a$, 1, sng& - 1) = space$(sng& - 1) IsNumber = True Exit Function End Select Case Else r = val(ig$ + DE$) End Select Else r = val(ig$ + DE$) End If End If If Err.Number = 6 Then If Len(ex$) > 2 Then ex$ = Left$(ex$, Len(ex$) - 1) sng = sng - 1 Err.Clear r = val(ig$ + DE$ + ex$) If Err.Number = 6 Then sng = sng - Len(ex$) If DE$ <> vbNullString Then Mid$(DE$, 1, 1) = "." r = val(ig$ + DE$) End If Else End If ErrInExponet a$ Mid$(a$, 1, sng& - 1) = space$(sng& - 1) IsNumber = False Exit Function End If End If Mid$(a$, 1, sng& - 1) = space$(sng& - 1) IsNumber = True Set bstack.lastobj = Nothing End Function Function IsNumberNew(bstack As basetask, a$, r As Variant, flatobject) As Boolean Dim VR As Long, v$, V1&, w1 As Long, w2 As Long, p As Variant, s1$, dd As Long, dn As Long, w3 As Long Dim pp As Variant, pppp As mArray, ppppl As iBoxArray, nbstack As basetask, usehandler As mHandler, usebackup As Boolean Dim anything As Object, n$, useFast As FastCollection, userGroup As Group, UseProp As PropReference, gr As Boolean, big As BigInteger Dim sg1 As Boolean, s$, par As Boolean, tu As tuple, rA As refArray, useFast2 As StructCollection r = 0# If a$ = vbNullString Then Exit Function 'On Error Resume Next Set bstack.lastobj = Nothing againpointer: w2 = Len(a$) If w2 < 129 Then V1& = IsLabelBig(bstack, a$, v$, par, s1$, True, , usebackup, , gr) Else n$ = Left$(a$, 128) s$ = bstack.tmpstr V1& = IsLabelBig(bstack, n$, v$, par, s1$, True, , usebackup, sg1, gr) If Len(n$) = 0 Then If sg1 Then bstack.tmpstr = s$ sg1 = False V1& = IsLabelBig(bstack, a$, v$, par, s1$, True, , usebackup, , gr) Else If sg1 Then sg1 = False Select Case Len(n$) Case Is < 128 Mid$(a$, 129 - Len(n$), Len(n$)) = n$ a$ = Mid$(a$, 129 - Len(n$)) Case Is > 128 a$ = n$ + Mid$(a$, 129) Case Else Mid$(a$, 1, 128) = n$ End Select Else a$ = Mid$(a$, 129 - Len(n$)) End If End If End If If V1& = 0 Then Exit Function If par Then par = False If usebackup Then If V1& > 4 Then GoTo conthere removethis: dn = dn + 1 If dn > 2 Then ' it is a var with name this or ΑΥΤΟ V1& = FastPureLabel((v$), v$) VR = -1 End If contthis1: V1& = Abs(V1&) If V1& = 1 Then GoTo LOOKFORVARNUM ElseIf V1& = 4 Then GoTo LOOKFORVARNUM4 ElseIf V1& = 5 Or V1& = 7 Then GoTo LOOKFORSUBNUM ElseIf V1& = 8 Then GoTo LOOKFORVARNUM Else bstack.tmpstr = v$ + Left$(a$, 1) If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) '' a$ = v$ + a$ ' ???? Exit Function End If End If conthere: Select Case V1& Case 1 If usebackup Then If Not numidbackup.Find(v$, w1) Then GoTo LOOKFORVARNUM Else If Not numid.Find(v$, w1, bstack.numnum) Then GoTo LOOKFORVARNUM If w1 < 0 Then GoTo LOOKFORVARNUM End If findsecond: On w1 GoTo num1, num2, num3, num4, num5, num6, num7, num8, num9, num10, num11, num12, num13, num14, num15, num16, num17, num18, num19, num20, num21, num22, num23, num24, num25, num26, num27, num28, num29, num30, num31, num32, num33, num34, num35, num36, num37, num38, num39, num40, num41, num42, num43, num44, num45, num46, num47, num48, num49, num50, num51, num52, num53, num54, num55, num56, num57, num58, num59, num60, num61, num62, num63, num64, num65, num66, num67, num68, num69, num70, num71, num72, num73, num74, num75, num76, num77, num78, num79, num80, num81, num82, num83, num84, num85, num86, num87, num88, num89, num90, num91, num92, num93, num94, num95, num96, num97, num98, num99, num100, num101, num102, num103, num104, num105, num106, num107, num108, num109, num110, num111, num112 IsNumberNew = 0 InternalError Exit Function num112: r = PrinterQual IsNumberNew = True Exit Function num110: r = oprinter.PrinterOn IsNumberNew = True Exit Function num109: If mydpi = 0 Then Portrait bstack End If r = Round(ph / phoy * 2.54, 0) IsNumberNew = True Exit Function num108: If mydpi = 0 Then Portrait bstack End If r = Round(pw / pwox * 2.54, 0) IsNumberNew = True Exit Function num107: r = MediaPlayer1.Height * Screen.TwipsPerPixelY IsNumberNew = True Exit Function num106: r = MediaPlayer1.Width * Screen.TwipsPerPixelX IsNumberNew = True Exit Function num105: ' "ADDRESSOF","ΔΙΕΥΘΥΝΣΗΑΠΟ" IsNumberNew = False If findAddress(bstack, a$, r) Then IsNumberNew = True End If Exit Function num111: '"SOUNDREC" If sRec Is Nothing Then r = -1 Else r = sRec.getLengthInMS End If IsNumberNew = True Exit Function num104: If sRec Is Nothing Then Set sRec = New RecordMci With sRec If Not .HaveMic Then Set sRec = Nothing: MissMic: Exit Function .Rec_Initialize .Mono .Bit8 .QualityAny 11025 End With End If r = sRec.getLevels() IsNumberNew = True Exit Function num103: r = doslast IsNumberNew = True Exit Function num102: ' Case "MONITORS", "ΟΘΟΝΕΣ" r = DisplayMonitorCount IsNumberNew = True Exit Function num101: ' Case "CLIPBOARD.DRAWING", "ΠΡΟΧΕΙΡΟ.ΣΧΕΔΙΟ" Set bstack.lastobj = GetImageEmf() r = 0 IsNumberNew = True Exit Function num100: ' Case "CLIPBOARD.IMAGE", "ΠΡΟΧΕΙΡΟ.ΕΙΚΟΝΑ" Set bstack.lastobj = GetImageDIB() r = 0 IsNumberNew = True Exit Function num99: ' Case "INTERNET", "ΔΙΑΔΙΚΤΥΟ" r = Connected IsNumberNew = True Exit Function num98: r = pagio$ = "GREEK" IsNumberNew = True Exit Function num82: r = Infinity() IsNumberNew = True Exit Function num93: Set bstack.lastobj = NewVarItem() bstack.lastobj.Typename = ">" r = 0 IsNumberNew = True FastSymbol a$, "?" Exit Function num90: ' "WINDOW","ΣΥΣΚΕΥΗ" r = FindFormSScreen(bstack.Owner) IsNumberNew = True Exit Function num89: '"OSBIT" If Is64bit Then r = 64# Else r = 32# End If IsNumberNew = True Exit Function num88: ' "ΟΘΟΝΗ","SHOW" If Not Screen.ActiveForm Is Nothing Then If bstack.Owner Is Form1.DIS Then r = (Form1.hWnd = Screen.ActiveForm.hWnd And bstack.Owner.Visible) ElseIf Typename(bstack.Owner) = "PictureBox" Then r = bstack.Owner.Visible Else r = bstack.Owner.hWnd = Screen.ActiveForm.hWnd End If Else r = False End If IsNumberNew = True Exit Function num87: ' "ISWINE" r = IsWine IsNumberNew = True Exit Function ' Select Case v$ num1: ' "THIS", "ΑΥΤΟ" ' 1 IsNumberNew = This1(bstack, v$, r) Exit Function num2: ' "RND", "ΤΥΧΑΙΟΣ" r = RndM(rndbase) IsNumberNew = True Exit Function num3: ' "PEN", "ΠΕΝΑ" With players(GetCode(bstack.Owner)) For w1 = 0 To 15 If QBColor(w1) = .mypen Then r = w1 IsNumberNew = True Exit Function End If Next w1 r = -.mypen IsNumberNew = True End With Exit Function num4: ' "HWND","ΠΑΡΑΘΥΡΟ" r = myHwnd(bstack) IsNumberNew = True Exit Function num5: ' Case "LOCALE", "ΤΟΠΙΚΟ" r = Clid IsNumberNew = True Exit Function num6: ' "CODEPAGE", "ΚΩΔΙΚΟΣΕΛΙΔΑ" r = UserCodePage IsNumberNew = True Exit Function num7: ' "SPEECH", "ΛΟΓΟΣ" r = NumVoices IsNumberNew = True Exit Function num8: ' "ERROR", "ΛΑΘΟΣ" If LastErNum2 <> 0 Then r = LastErNum2 Else r = LastErNum1 End If LastErNum2 = 0 LastErNum1 = 0 'reset when readed IsNumberNew = True Exit Function num9: ' "SCREEN.Y", "ΑΝΑΛΥΣΗ.Υ" r = ScrInfo(Console).Height IsNumberNew = True Exit Function num10: ' "SCREEN.X", "ΑΝΑΛΥΣΗ.Χ" r = ScrInfo(Console).Width IsNumberNew = True Exit Function num11: ' "TWIPSY", "ΥΨΟΣ.ΣΗΜΕΙΟΥ" r = Screen.TwipsPerPixelY IsNumberNew = True Exit Function num12: ' "TWIPSX", "ΠΛΑΤΟΣ.ΣΗΜΕΙΟΥ" r = Screen.TwipsPerPixelX IsNumberNew = True Exit Function num13: ' "REPORTLINES", "ΓΡΑΜΜΕΣΑΝΑΦΟΡΑΣ" r = players(GetCode(bstack.Owner)).LastReportLines IsNumberNew = True Exit Function num14: ' "LINESPACE", "ΔΙΑΣΤΙΧΟ" r = players(GetCode(bstack.Owner)).uMineLineSpace '' bstack.linespace IsNumberNew = True Exit Function num15: ' "MODE", "ΤΥΠΟΣ" With players(GetCode(bstack.Owner)) If bstack.toprinter Then If .uMineLineSpace > .MineLineSpace Then r = .SZ / szFactor / 2 Else r = .SZ / szFactor End If Else If .uMineLineSpace > .MineLineSpace Then r = .UseDouble Else r = .SZ End If End If End With IsNumberNew = True Exit Function num16: ' "MEMORY", "ΜΝΗΜΗ" r = check_mem IsNumberNew = True Exit Function num17: ' "CHARSET", "ΧΑΡΑΚΤΗΡΕΣ" ' charset of the object to display r = players(GetCode(bstack.Owner)).charset IsNumberNew = True Exit Function num18: ' "ITALIC", "ITALICS", "ΠΛΑΓΙΑ" ' charset of the object to display r = players(GetCode(bstack.Owner)).italics IsNumberNew = True Exit Function num19: ' "BOLD", "ΦΑΡΔΙΑ" ' charset of the object to display r = players(GetCode(bstack.Owner)).bold IsNumberNew = True Exit Function num20: ' "COLORS", "ΧΡΩΜΑΤΑ" r = 2# ^ bitsPerPixel IsNumberNew = True Exit Function num21: ' "ΑΥΞΟΥΣΑ", "ASCENDING" r = 0 IsNumberNew = True Exit Function num22: ' "ΦΘΙΝΟΥΣΑ", "DESCENDING" r = 1 IsNumberNew = True Exit Function num23: ' "BOOLEAN", "ΛΟΓΙΚΟΣ" r = 1 IsNumberNew = True Exit Function num24: ' "BYTE", "ΨΗΦΙΟ" r = 2 IsNumberNew = True Exit Function num25: ' "INTEGER", "ΑΚΕΡΑΙΟΣ" r = 3 IsNumberNew = True Exit Function num26: ' "LONG", "ΜΑΚΡΥΣ" r = 4 IsNumberNew = True Exit Function num27: ' "CURRENCY", "ΛΟΓΙΣΤΙΚΟΣ" r = 5 IsNumberNew = True Exit Function num28: ' "SINGLE", "ΑΠΛΟΣ" r = 6 IsNumberNew = True Exit Function num29: ' "DOUBLE", "ΔΙΠΛΟΣ" r = 7 IsNumberNew = True Exit Function num30: ' "DATEFIELD", "ΗΜΕΡΟΜΗΝΙΑ" r = 8 IsNumberNew = True Exit Function num31: ' "BINARY", "ΔΥΑΔΙΚΟ" r = 9 IsNumberNew = True Exit Function num32: ' "TEXT", "ΚΕΙΜΕΝΟ" r = 10 IsNumberNew = True Exit Function num33: ' "OLE" r = 11 IsNumberNew = True Exit Function num34: ' "MEMO", "ΥΠΟΜΝΗΜΑ" r = 12 IsNumberNew = True Exit Function num35: ' "REVISION", "ΑΝΑΘΕΩΡΗΣΗ" r = Revision IsNumberNew = True Exit Function num36: ' "BROWSER", "ΑΝΑΛΟΓΙΟ" r = (Trim(LCase(Form1.view1.LocationURL)) = "about:blank" Or Form1.view1.Visible = False) IsNumberNew = True Exit Function num37: ' "VERSION", "ΕΚΔΟΣΗ" r = val(CStr(VerMajor) & "." & CStr(VerMinor)) IsNumberNew = True Exit Function num38: ' "MOTION.X", "ΚΙΝΗΣΗ.Χ" With bstack If .toprinter Then r = 0 Else r = bstack.Owner.Left End If End With IsNumberNew = True Exit Function num39: ' Case "MOTION.Y", "ΚΙΝΗΣΗ.Υ" With bstack If .toprinter Then r = 0 Else r = .Owner.top End If End With IsNumberNew = True Exit Function num40: ' "MOTION.XW", "ΚΙΝΗΣΗ.ΧΠ", "MOTION.WX", "ΚΙΝΗΣΗ.ΠΧ" r = Form1.Left IsNumberNew = True Exit Function num41: ' "MOTION.YW", "ΚΙΝΗΣΗ.ΥΠ", "MOTION.WY", "ΚΙΝΗΣΗ.ΠΥ" r = Form1.top IsNumberNew = True Exit Function num42: ' "FIELD", "ΠΕΔΙΟ" r = result IsNumberNew = True Exit Function num43: ' "MOUSE.KEY", "ΔΕΙΚΤΗΣ.ΚΟΜ" r = mouse2 IsNumberNew = True Exit Function num44: ' "MOUSE", "ΔΕΙΚΤΗΣ" If Not releasemouse Then If Not Form1.Visible Then newshow Basestack1 End If r = mouse If r = 0 Then MyDoEventsNoThread r = mouse ' MOUB End If IsNumberNew = True Exit Function num45: ' "MOUSE.X", "ΔΕΙΚΤΗΣ.Χ" With bstack If .toprinter Then r = Form1.PrinterDocument1.currentX ElseIf .toback Then r = MOUSEX(Form1.Left) Else r = MOUSEX(Form1.Left + bstack.Owner.Left) End If End With IsNumberNew = True Exit Function num46: ' "MOUSE.Y", "ΔΕΙΚΤΗΣ.Υ" With bstack If .toprinter Then r = Form1.PrinterDocument1.currentY ElseIf .toback Then r = MOUSEY(Form1.top) Else r = MOUSEY(Form1.top + bstack.Owner.top) End If End With IsNumberNew = True Exit Function num47: ' "MOUSEA.X", "ΔΕΙΚΤΗΣΑ.Χ" r = MOUSEX(Form1.Left) IsNumberNew = True Exit Function num48: ' "MOUSEA.Y", "ΔΕΙΚΤΗΣΑ.Υ" r = MOUSEY(Form1.top) IsNumberNew = True Exit Function num49: ' "TRUE", "ΑΛΗΘΕΣ", "ΑΛΗΘΗΣ" r = -1# IsNumberNew = True Exit Function num50: ' "FALSE", "ΨΕΥΔΕΣ", "ΨΕΥΔΗΣ" r = 0# IsNumberNew = True Exit Function num51: ' "STACK.SIZE", "ΜΕΓΕΘΟΣ.ΣΩΡΟΥ" IsNumberNew = True r = bstack.soros.Total Exit Function num52: ' "ISNUM", "ΕΙΝΑΡ" IsNumberNew = True If bstack.soros.Total > 0 Then If bstack.soros.PopType = "N" Then r = True ElseIf bstack.soros.PopType = "*" Then If TypeOf bstack.soros.objref(1) Is BigInteger Then r = True Else r = False End If Else r = False End If Else r = False End If Exit Function num53: ' "PI", "ΠΙ" r = BigPi IsNumberNew = True Exit Function num54: ' "NOT", "ΟΧΙ", "ΔΕΝ" If FastSymbol(a$, "(") Then If IsExpBig(bstack, a$, r, , True, , True) Then processNegateNonZero r r = Not r IsNumberNew = FastSymbol(a$, ")") Exit Function Else NotAfter a$ End If ElseIf IsExpBig(bstack, a$, r, False, True, , True) Then processNegateNonZero r r = Not r Else NotAfter a$ End If IsNumberNew = True Exit Function num55: ' "ISLET", "ΕΙΝΓΡ" IsNumberNew = True If bstack.soros.Total > 0 Then If bstack.soros.PopType = "S" Then r = True Else r = False Else r = False End If Exit Function num56: ' Case "WIDTH", "ΠΛΑΤΟΣ" IsNumberNew = True r = players(GetCode(bstack.Owner)).mX Exit Function num57: ' "POINT", "ΣΗΜΕΙΟ" ' dsprite ?? If TypeOf bstack.Owner Is MetaDc Then MyEr "Can't read pixel from metafile", "δεν μπορώ να διαβάσω εικονοστοιχείο" Else IsNumberNew = True With players(GetCode(bstack.Owner)) w1 = GetPixel(bstack.Owner.hDC, .XGRAPH \ dv15, .YGRAPH \ dv15) If w1 = -1 Then r = &H7FFFFFFF Else r = -(w1 And &HFFFFFF) End If End With End If Exit Function num58: ' "POS.X", "ΘΕΣΗ.Χ" IsNumberNew = True r = players(GetCode(bstack.Owner)).XGRAPH Exit Function num59: ' "POS.Y", "ΘΕΣΗ.Υ" IsNumberNew = True r = players(GetCode(bstack.Owner)).YGRAPH Exit Function num60: ' "SCALE.X", "ΚΛΙΜΑΞ.Χ", "Χ.ΣΗΜΕΙΑ", "X.TWIPS" IsNumberNew = True If bstack.toprinter Then r = Form1.PrinterDocument1.ScaleWidth Else r = players(GetCode(bstack.Owner)).MAXXGRAPH End If Exit Function num61: ' "SCALE.Y", "ΚΛΙΜΑΞ.Υ", "Υ.ΣΗΜΕΙΑ", "Y.TWIPS" IsNumberNew = True If bstack.toprinter Then r = Form1.PrinterDocument1.ScaleHeight Else r = players(GetCode(bstack.Owner)).MAXYGRAPH End If Exit Function num62: ' "EMPTY", "ΚΕΝΟ" IsNumberNew = True r = (bstack.soros.Total = 0) Exit Function num63: ' "MOVIE.COUNTER", "MEDIA.COUNTER", "MUSIC.COUNTER", "ΤΑΙΝΙΑ.ΜΕΤΡΗΤΗΣ", "ΜΟΥΣΙΚΗ.ΜΕΤΡΗΤΗΣ" IsNumberNew = True r = MediaPlayer1.getPositionInSec If MediaPlayer1.Error > 0 Then r = -1 End If Exit Function num64: ' "PLAYSCORE", "ΠΑΙΖΕΙΦΩΝΗ" IsNumberNew = True r = MusicMaster.PlayMusic Exit Function num65: ' "MOVIE", "MEDIA", "MUSIC", "ΤΑΙΝΙΑ", "ΜΟΥΣΙΚΗ" IsNumberNew = True AVIRUN = MediaPlayer1.isMoviePlaying r = AVIRUN Exit Function num66: ' "DURATION", "ΔΙΑΡΚΕΙΑ" IsNumberNew = True r = MediaPlayer1.getLengthInMS / 1000 Exit Function num67: ' "VOLUME", "ΕΝΤΑΣΗ" IsNumberNew = True MediaPlayer1.GetMasterVolume vol r = CDbl(vol) Exit Function num68: ' "TAB", "ΣΤΗΛΗ" IsNumberNew = True r = players(GetCode(bstack.Owner)).Column + 1 'CHANGED FROM Ver 7.1 Exit Function num69: ' "HEIGHT", "ΥΨΟΣ" IsNumberNew = True r = players(GetCode(bstack.Owner)).mY Exit Function num70: ' "POS", "ΘΕΣΗ" IsNumberNew = True r = GetRealPos(bstack.Owner) Exit Function num71: ' "ROW", "ΓΡΑΜΜΗ" IsNumberNew = True r = GetRealRow(bstack.Owner) Exit Function num72: ' "TIMECOUNT", "ΦΟΡΤΟΣ" ' **************************** IsNumberNew = True If bstack.Prof Is Nothing Then r = Prof.MARKTWO Else r = bstack.Prof.MARKTWO End If Exit Function num73: ' "TICK", "ΤΙΚ" ' **************************** IsNumberNew = True If TaskMaster Is Nothing Then r = 0 ElseIf TaskMaster.QueueCount = 0 Then r = 0 Else r = tickTimer End If Exit Function num74: ' "TODAY", "ΣΗΜΕΡΑ" IsNumberNew = True r = Date Exit Function num75: ' "NOW", "ΤΩΡΑ" IsNumberNew = True r = time Exit Function num76: ' "MENU.VISIBLE", "ΕΠΙΛΟΓΕΣ.ΦΑΝΕΡΕΣ" ' NEW 6.5 REV 8 IsNumberNew = True r = Form1.List1.Visible Exit Function num77: ' "MENUITEMS", "ΕΠΙΛΟΓΕΣ" IsNumberNew = True r = Form1.List1.listcount Exit Function num78: ' "MENU", "ΕΠΙΛΟΓΗ" IsNumberNew = True r = 0 With Form1.List1 If .listcount > 0 Then r = CDbl(.ListIndex + 1) End If End With Exit Function num85: ' "[]" Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = NewmStiva usehandler.objref.MergeBottom bstack.soros ' Set bstack.Sorosref = newmstiva Set bstack.lastobj = usehandler r = 0 IsNumberNew = True Exit Function num84: ' "ARRAY", "ΠΙΝΑΚΑΣ" If bstack.soros.Total = 0 Then EmptyStack a$ IsNumberNew = False: Exit Function ElseIf bstack.soros.StackItemTypeiBoxArray(1) Then Set bstack.lastobj = bstack.soros.PopObj r = 0 If FastSymbol1(a$, "#") Then GoTo comehere IsNumberNew = True Exit Function Else StackTopNotArray a$ IsNumberNew = False End If Exit Function num97: IsNumberNew = NewInventory(bstack, a$, r, True) Exit Function num96: IsNumberNew = NewInventory(bstack, a$, r, False) Exit Function num95: w1 = 1 GoTo num941 num94: '"BUFFER", "ΔΙΑΡΘΡΩΣΗ" w1 = 2 num941: If bstack.soros.Total = 0 Then EmptyStack a$ IsNumberNew = False: Exit Function ElseIf bstack.soros.StackItemType(1) = "*" Then Set bstack.lastobj = bstack.soros.PopObj If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If usehandler.t1 <> w1 Then Set usehandler = Nothing pushback: bstack.soros.PushObj bstack.lastobj Set bstack.lastobj = Nothing WrongObject IsNumberNew = False Exit Function End If Else GoTo pushback End If r = 0 IsNumberNew = True Exit Function Else MyErMacro a$, "Stack top isn't " + v$, "Η κορυφή του σωρού δεν είναι " + v$ IsNumberNew = False End If Exit Function num83: ' "GROUP", "ΟΜΑΔΑ" If bstack.soros.Total = 0 Then EmptyStack a$ IsNumberNew = False: Exit Function ElseIf bstack.soros.StackItemTypeObjectType(1) = mGroup Then Set bstack.lastobj = bstack.soros.PopObj r = 0 IsNumberNew = True Exit Function Else StackTopNotGroup a$ IsNumberNew = False End If Exit Function num79: ' "NUMBER", "ΑΡΙΘΜΟΣ", "ΤΙΜΗ" If bstack.soros.Total = 0 Then EmptyStack a$ IsNumberNew = False: Exit Function ElseIf bstack.soros.PopType = "N" Then r = bstack.soros.PopVal IsNumberNew = True Exit Function ElseIf bstack.soros.PopType = "L" Then r = bstack.soros.PopVal IsNumberNew = True Exit Function Else If bstack.soros.Count > 0 Then If bstack.soros.IsObj Then Set anything = bstack.soros.objref(1) If TypeOf anything Is mHandler Then Set usehandler = anything If usehandler.t1 = 4 Then If myVarType(usehandler.index_cursor, vbString) Then r = usehandler.index_cursor Else r = usehandler.index_cursor * usehandler.sign End If bstack.soros.drop 1 IsNumberNew = True Exit Function ElseIf usehandler.UseIterator Then r = usehandler.index_cursor bstack.soros.drop 1 IsNumberNew = True Exit Function End If ElseIf TypeOf anything Is BigInteger Then bstack.soros.drop 1 r = 0 Set bstack.lastobj = anything IsNumberNew = True Exit Function End If End If End If StackTopNotNumber a$ IsNumberNew = False End If Exit Function num81: ' "ΛΑΜΔΑ" Set bstack.lastobj = ProcLambda(bstack, a$, 0) r = 0 If FastSymbol(a$, "(") Then If Not CallLambdaASAP(bstack, a$, r) Then IsNumberNew = False: Exit Function IsNumberNew = True Else IsNumberNew = Not bstack.lastobj Is Nothing End If Exit Function num80: ' "LAMBDA" Set bstack.lastobj = ProcLambda(bstack, a$, 1) r = 0 If FastSymbol(a$, "(") Then If Not CallLambdaASAP(bstack, a$, r) Then IsNumberNew = False: Exit Function IsNumberNew = True Else IsNumberNew = Not bstack.lastobj Is Nothing End If Exit Function num86: ' Case "STACK", "ΣΩΡΟΣ" IsNumberNew = IsStackObj(v$, bstack, a$, r) Exit Function num91: 'MONITOR.STACK - ΕΛΕΓΧΟΣ.ΣΩΡΟΥ r = CurrentStackSize() IsNumberNew = True Exit Function Exit Function num92: 'MONITOR.STACK.SIZE - ΕΛΕΓΧΟΣ.ΜΕΓΕΘΟΣ.ΣΩΡΟΥ r = stacksize IsNumberNew = True Exit Function Exit Function LOOKFORVARNUM: If GetVar(bstack, v$, VR) Then If MyIsObject(var(VR)) Then SwapStrings n$, v$ SwapStrings v$, Typename(var(VR)) If var(VR) Is Nothing Then Set bstack.lastobj = Nothing r = 0 ElseIf TypeOf var(VR) Is PropReference Then Set UseProp = var(VR) UseProp.UseIndex = False r = UseProp.Value If UseProp.LastHasObject Then If Left$(a$, 2) = "=>" Then Set anything = UseProp.lastobj UseProp.clearlastobject r = 0 GoTo com123cont Else Set bstack.lastobj = UseProp.lastobj UseProp.clearlastobject r = 0 End If End If Set UseProp = Nothing ElseIf TypeOf var(VR) Is Group Then Set userGroup = var(VR) If userGroup.IamCleared Then Set userGroup = New Group userGroup.BeginFloat 0 userGroup.EndFloat Set bstack.lastobj = userGroup IsNumberNew = True Exit Function End If If userGroup.HasValue And Not IsOperator(a$, "::", 2) Then If Len(userGroup.Patch) > 0 Then s1$ = userGroup.Patch + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" Else s1$ = n$ + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" End If If GetSub(s1$, V1&) Then foundprivate: Set nbstack = New basetask Set nbstack.Parent = bstack If bstack.IamThread Then Set nbstack.Process = bstack.Process Set nbstack.Owner = bstack.Owner nbstack.OriginalCode = V1& nbstack.UseGroupname = sbf(V1&).sbgroup nbstack.tpointer = sbf(V1&).tpointer nbstack.SetV If GoFunc(nbstack, s1$, ")", p) Then If Not nbstack.StaticCollection Is Nothing Then bstack.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If If Mid(a$, 1, 2) = "=>" Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then Set userGroup = bstack.lastobj Set bstack.lastobj = Nothing If userGroup.IamApointer Then Set ppppl = BoxGroupVar(CVar(userGroup)) w2 = 0 Set nbstack.lastobj = Nothing Set nbstack.lastpointer = Nothing Mid$(a$, 1, 2) = "." + Chr(3): GoTo contgroup Else NoOperatorForThatObject "=>" End If End If Else NoOperatorForThatObject "=>" End If IsNumberNew = False Exit Function ElseIf IsOperator(a$, "(") Then Set ppppl = New ppppLight Set ppppl.GroupRef = bstack.lastobj Set bstack.lastobj = Nothing If Not nbstack Is Nothing Then Set nbstack.lastobj = Nothing ppppl.arr = False w2 = -2 Set nbstack = Nothing v$ = vbNullString GoTo contrightpar ElseIf FastSymbol1(a$, "#") Then Set nbstack = Nothing GoTo comehere ElseIf Left$(a$, 1) = "|" Then contUDT1: Mid$(a$, 1, 1) = " " If MemInt(VarPtr(p)) = vbUserDefinedType Then w2 = FastPureLabel(a$, s$) If w2 > 0 Then If w2 = 1 Then r = UDTValue(p, s$) ElseIf w2 = 5 Then If IsExp(bstack, a$, p) Then If FastSymbol(a$, ")") Then r = GetUDTValueArray(p, CVar(s$), CLng(p)) End If End If End If If MemInt(VarPtr(r)) = vbEmpty Then If LastErNum = 0 Then BadUDTName Else IsNumberNew = True End If Exit Function End If Else If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing If Not nbstack Is Nothing Then Set nbstack.lastobj = Nothing If usehandler.t1 = 2 Then If TakeOffset(bstack, usehandler, a$, r) Then IsNumberNew = True Exit Function End If End If End If End If Set bstack.lastobj = Nothing If Not nbstack Is Nothing Then Set nbstack.lastobj = Nothing WrongType End If IsNumberNew = False Exit Function Else Set nbstack = Nothing r = p End If IsNumberNew = True Else IsNumberNew = False End If Else If userGroup.HasStrValue Then r = 0 Set bstack.lastobj = CopyGroupObj(var(VR)) Else r = 0 s1$ = userGroup.Patch + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" If Left$(s1$, Len(here$) + 1) = here$ + "." Then s1$ = Mid$(s1$, Len(here$) + 2) End If If GetSub(s1$, V1&) Then GoTo foundprivate InternalError IsNumberNew = False End If End If Else r = 0 If userGroup.IamApointer Then If Mid(a$, 1, 2) = "=>" Then If userGroup.link.IamFloatGroup Then Set ppppl = BoxGroupVar(var(VR)) Mid$(a$, 1, 2) = "." + Chr(3) IsNumberNew = SpeedGroup(bstack, ppppl, "VAL", "", a$, (0)) = 1 If Not IsNumberNew Then r = 0 Else r = bstack.LastValue End If Exit Function Else Mid(a$, 1, 2) = Chr$(0) + "." Set bstack.lastpointer = userGroup GoTo againpointer End If Else Set bstack.lastpointer = userGroup.link Set bstack.lastobj = userGroup End If Else CopyGroup2 var(VR), bstack Set bstack.lastpointer = Nothing End If IsNumberNew = True Exit Function End If ElseIf TypeOf var(VR) Is refArray Then If V1& = 8 Then Set rA = var(VR) jump8: If Not IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If Not FastSymbol(a$, "]") Then SyntaxError Exit Function Else Set bstack.lastobj = rA.Copy r = 0 End If Else If Not FastSymbol(a$, "]") Then SyntaxError Exit Function End If p = Abs(Int(p)) conthere123: If rA.MarkTwoDimension Then If Not FastOperator(a$, "[", 1) Then ReDim r(0) r(0) = rA(p) Set bstack.lastobj = rA.NewRef(r) r = 0 ElseIf Not IsExp(bstack, a$, pp, flatobject:=True, nostring:=True) Then If Not FastSymbol(a$, "]") Then SyntaxError Exit Function End If ReDim r(0) r(0) = rA(p) Set bstack.lastobj = rA.NewRef(r) r = 0 Else If Not FastSymbol(a$, "]") Then SyntaxError Exit Function End If pp = Abs(Int(pp)) 'Set bstack.lastobj = Nothing '' check for object?? not implemented yet If rA.Count <= p Then OutOfLimit Exit Function ElseIf rA.Count(p) <= pp Then If rA.vtType(p) = 9 Then If rA.IsInnerRefArray(p, rA) Then ' IT IS A REFARRAY??? 'Set ra = R p = pp GoTo conthere123 End If Else ' not impl... End If OutOfLimit Exit Function End If Select Case rA.vtType(p, pp) Case vbObject Set nbstack = bstack Set nbstack.lastobj = rA(p, pp) p = 0 GoTo goodjump Case vbUserDefinedType If FastSymbol(a$, "|") Then w2 = IsLabelOnly(a$, s$) If w2 = 1 Then r = rA.GetUDTValue(p, pp, CVar(s$)) ElseIf w2 = 5 Then w1 = CLng(pp) If IsExp(bstack, a$, pp) Then If FastSymbol(a$, ")") Then r = rA.GetUDTValue(p, CVar(w1), CVar(s$), pp) End If End If Else SyntaxError Exit Function End If If MemInt(VarPtr(r)) = vbEmpty Then If LastErNum = 0 Then BadUDTName Exit Function End If Else r = rA(p, pp) End If If MyIsObject(r) Then Set bstack.lastobj = r Set r = Nothing r = 0 End If Case Else r = rA(p, pp) End Select If MyIsObject(r) Then Set bstack.lastobj = r Set r = Nothing r = 0 End If End If Else Set bstack.lastobj = Nothing '' check for object?? not implemented yet If rA.Count((0)) <= p Then OutOfLimit Exit Function Else If rA.vtType((0), p) = vbObject Then Set nbstack = bstack Set nbstack.lastobj = rA((0), p) p = 0 If IsGroup(nbstack.lastobj) Then Set userGroup = nbstack.lastobj If Not userGroup.IamApointer Then If userGroup.refcount1 > 2 Then Set anything = Nothing CopyGroupObjRef userGroup, anything rA((0), p) = CVar(anything) Set nbstack.lastobj = anything End If End If End If GoTo goodjump Else If rA.vtType(0, p) = vbUserDefinedType Then If FastSymbol(a$, "|") Then w2 = IsLabelOnly(a$, s$) If w2 = 1 Then r = rA.GetUDTValue((0), p, CVar(s$)) ElseIf w2 = 5 Then If IsExp(bstack, a$, pp) Then If FastSymbol(a$, ")") Then r = rA.GetUDTValue((0), p, CVar(s$), pp) End If End If Else SyntaxError Exit Function End If If MemInt(VarPtr(r)) = vbEmpty Then If LastErNum = 0 Then BadUDTName Exit Function End If Else r = rA((0), p) End If Else r = rA((0), p) End If If MyIsObject(r) Then Set bstack.lastobj = r Set r = Nothing r = 0 End If End If End If End If End If Else Set bstack.lastobj = var(VR) r = 0 End If IsNumberNew = True Exit Function ElseIf TypeOf var(VR) Is mEvent Then CopyEvent var(VR), bstack r = 0 ElseIf TypeOf var(VR) Is lambda Then CopyLambda var(VR), bstack r = 0 ElseIf TypeOf var(VR) Is mHandler Then ' this is ok for both buffer and inventory Set usehandler = var(VR) If usehandler.t1 = 2 Then comehere11: If V1& = 8 Then If IsExp(bstack, a$, pp, , flatobject:=True, nostring:=True) Then If Left$(a$, 1) = "]" Then pp = CLng(pp) If Left$(a$, 2) = "]|" Then Mid$(a$, 1, 2) = " " GoTo cont8case Else If Left$(a$, 2) = "]!" Then SyntaxError: Exit Function Mid$(a$, 1, 1) = " " If usehandler.objref.structref Is Nothing Then If TakeOffset(bstack, usehandler, a$, r, pp) Then IsNumberNew = True End If Exit Function Else Set pp = usehandler.objref.CopyItem(CLng(pp), par) If par Then Set usehandler = New mHandler Set usehandler.objref = pp usehandler.t1 = 2 Set bstack.lastobj = usehandler IsNumberNew = True End If r = 0 Set pp = Nothing End If Exit Function End If ElseIf FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, , flatobject:=True, nostring:=True) Then If FastSymbol(a$, "]") Then s1$ = usehandler.objref.CopyItemString(CLng(pp), CLng(p), par) r = "" SwapString2Variant s1$, r IsNumberNew = True Exit Function End If End If End If End If SyntaxError Exit Function End If pp = 0& If Left$(a$, 1) = "|" Then cont8case: Set p = var(VR) If TakeOffset(bstack, usehandler, a$, r, pp) Then Else SyntaxError Exit Function End If Else CopyHandler var(VR), bstack r = 0 End If Else If Not usehandler.UseIterator Then Set nbstack = Nothing ' ??? If FastSymbol1(a$, "#") Then If Not usehandler.t1 = 3 Then WrongObject: Exit Function If Not fMatrix(bstack, a$, usehandler, r) Then Exit Function End If If lookOne(a$, ".") Then ' MAYBE IS AN OBJECT If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then Mid$(a$, 1, 1) = "#" Set anything = bstack.lastobj GoTo jumpgroup001 End If End If End If ElseIf flatobject Then If usehandler.t1 = 4 Then r = usehandler.index_cursor Else r = 0 End If Else If usehandler.t1 = 4 Then If FastSymbol(a$, "|") Then If FastPureLabel(a$, s1$, , , , , , gr) = 1 Then s1$ = myUcase(s1$, gr) r = usehandler.objref.SearchSimple(s1$, gr) If Not gr Then GoTo a11212121 Else a11212121: SyntaxError IsNumberNew = False Exit Function End If ElseIf FastSymbol(a$, "^") Then r = usehandler.index_start Set bstack.lastobj = Nothing Else CopyHandler var(VR), bstack r = 0 End If Else If Left$(a$, 2) = "=>" Then Set usehandler = var(VR) GetObjFromHandler: If usehandler.indirect = -1 Then Set anything = usehandler.objref Else Set anything = var(usehandler.indirect) End If Set usehandler = Nothing GoTo com123cont Else CopyHandler var(VR), bstack End If r = 0 End If End If ElseIf FastSymbol(a$, "^") Then r = usehandler.index_cursor ElseIf FastSymbol1(a$, "#") Then Set nbstack = Nothing '??? IsNumberNew = fMatrix(bstack, a$, usehandler, r) If MyIsObject(r) Then r = 0# Else Set bstack.lastobj = var(VR) r = 0 End If End If Set usehandler = Nothing ElseIf TypeOf var(VR) Is Constant Then If var(VR).flag Then Set r = var(VR).Value If r Is Nothing Then ElseIf TypeOf r Is lambda Then CopyLambda var(VR).Value, bstack r = 0 ElseIf TypeOf r Is BigInteger Then Set bstack.lastobj = r ElseIf TypeOf r Is Group Then If r.HasValue Or r.HasStrValue Then Set bstack.lastobj = r r = 0 GoTo again1001 Else Set bstack.lastobj = r End If Else If lookOne(a$, "#") Then If IsmHandler(r) Then Set usehandler = r r = 0 FastSymbol a$, "#" If Not fMatrix(bstack, a$, usehandler, r) Then Exit Function End If Else WrongType Exit Function End If Else Set bstack.lastobj = r r = 0 End If End If Else r = var(VR) If Left$(a$, 1) = "|" Then If MemInt(VarPtr(r)) = 36 Then p = 0 SwapVariant p, r GoTo contUDT1 Else SyntaxError IsNumberNew = False Exit Function End If End If End If ElseIf TypeOf var(VR) Is tuple Then If FastSymbol1(a$, "#") Then Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = var(VR) If Not fMatrix(bstack, a$, usehandler, r) Then Exit Function End If Else Set bstack.lastobj = var(VR) 'MakeitObjectGeneric(VR) r = 0 End If ElseIf TypeOf var(VR) Is mArray Then If FastSymbol1(a$, "#") Then Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = var(VR) If Not fMatrix(bstack, a$, usehandler, r) Then Exit Function End If Else Set bstack.lastobj = var(VR) 'MakeitObjectGeneric(VR) r = 0 End If Else If Left$(a$, 2) = "=>" Then Set anything = var(VR) com123cont: Mid$(a$, 1, 2) = " " If IsLabelObj(a$, s1$) Then If Not anything Is Nothing Then VR = FindDISPIDExt(anything, s1$) If VR <> -1 Then Set UseProp = New PropReference UseProp.ConstructObj anything, VR, True contBigjob: If FastSymbol(a$, "(") Then If lookOne(a$, ")") Then ' this is a function GoTo contreadprop3 ElseIf getindexes(bstack, UseProp, a$) Then '??? SyntaxError Exit Function Else GoTo contreadprop3 End If Else UseProp.UseIndex = False End If Set bstack.lastobj = UseProp r = UseProp.Value If UseProp.LastHasObject Then If Left$(a$, 2) = "=>" Then Set anything = UseProp.lastobj UseProp.clearlastobject r = 0 GoTo com123cont Else ' Set anything = useProp.lastobj UseProp.clearlastobject r = 0 End If End If IsNumberNew = True Exit Function Else UnknownProperty1 a$, s1$ End If Else MyEr "Nothing Has no Properties", "Το τίποτα δεν έχει Ιδιότητες" End If Else Mid$(a$, 1, 2) = "=>" SyntaxError Exit Function End If Else Set bstack.lastobj = var(VR) 'MakeitObjectGeneric(VR) r = 0 End If End If Else Select Case MemInt(VarPtr(var(VR))) Case Is < 9, 11, 17, 14, 20 r = var(VR) Case vbUserDefinedType ' udt On Error Resume Next If FastSymbol(a$, "|") Then w2 = FastPureLabel(a$, s$) If w2 > 0 Then If w2 = 1 Then r = UDTValue(var(VR), s$) ElseIf w2 = 5 Then If IsExp(bstack, a$, p) Then If FastSymbol(a$, ")") Then r = GetUDTValueArray(var(VR), CVar(s$), CLng(p)) End If End If End If If MemInt(VarPtr(r)) = vbEmpty Then If LastErNum = 0 Then BadUDTName Exit Function End If Else SyntaxError End If Else r = var(VR) End If If MyIsObject(r) Then Set bstack.lastobj = r Set r = Nothing r = 0 End If Case 8192 To 8228 ' make it an refarray??? r = var(VR) Case Else If MyIsUnknown(var(VR)) Then Set bstack.lastobj = var(VR) End If r = 0 End Select End If IsNumberNew = True ElseIf VR = -1 Then r = ReadVarDouble(bstack, v$) If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then If bstack.lastobj.IamApointer Then If Left$(a$, 2) = "=>" Then Set ppppl = BoxGroupVar(bstack.lastobj) Mid$(a$, 1, 2) = "." + Chr(3) IsNumberNew = SpeedGroup(bstack, ppppl, "VAL", "", a$, (0)) = 1 r = bstack.LastValue End If End If End If End If IsNumberNew = True Exit Function Else If Len(v$) > 5 Then If Left$(v$, 5) = "THIS." Or Left$(v$, 5) = "ΑΥΤΟ." Then v$ = Mid$(v$, 5) V1& = IsLabel(bstack, (v$), v$) If v$ <> "" Then GoTo removethis End If End If IsNumberNew = False If IsObject(bstack.LastEnum) Then r = bstack.LastEnum.SearchSimple(v$, par) If par Then Set usehandler = New mHandler Set usehandler.objref = bstack.LastEnum usehandler.t1 = 4 usehandler.ReadOnly = True usehandler.index_cursor = r usehandler.index_start = bstack.LastEnum.index Set bstack.lastobj = usehandler IsNumberNew = True Exit Function End If End If If V1& = 1 Then If numidbackup.Find(v$, w1) Then GoTo findsecond If w2 >= Len(a$) Then If v$ = myUcase(s1$, True) Then a$ = s1$ + a$ Else a$ = v$ + a$ End If End If If FindNameForGroup(bstack, v$) Then UnknownProperty1 a$, v$ Else If LenB(v$) = 0 Then v$ = s1$ If GetSub(myUcase(v$, True) + "()", V1&) Then If Right$(sbf(V1&).sb, 1) = ChrW(&H1FFD) Then V1& = val(Mid$(sbf(V1&).sb, InStr(sbf(V1&).sb, "CALL EXTERN ") + 12)) If var2used >= V1& Then If VarType(var(V1&)) = vbObject Then If TypeOf var(V1&) Is stdCallFunction Then r = CVar(var(V1&).GetAddress) IsLabel bstack, a$, v$ IsNumberNew = True Exit Function End If End If End If ElseIf InStr(sbf(V1&).sb, ChrW(&H1FFD)) > 0 Then w1 = sbf(V1&).tpointer If w1 > 0 Then For w3 = 1 To var(w1).FieldsCount v$ = var(w1).ReadField(w3) If InStr(sbf(V1&).sb, "EXTERN ." + Mid$(Split(v$, " ")(0), 2)) > 0 Then w1 = val(Split(v$, " ")(1)) If TypeOf var(w1) Is stdCallFunction Then If var(w1).IsInterfaceCall Then MyEr "not for calling interfaces", "όχι για κλήσεις διεπαφών" Else r = CVar(var(w1).GetAddress) IsLabel bstack, a$, v$ IsNumberNew = True End If Exit Function End If End If Next End If r = 0 IsLabel bstack, a$, v$ IsNumberNew = True Exit Function End If End If UnknownVariable1 a$, v$ End If End If Exit Function Case 4 LOOKFORVARNUM4: If GetVar(bstack, v$, VR) Then If VarTypeName(var(VR)) = "lambda" Then CopyLambda var(VR), bstack Else r = var(VR) End If IsNumberNew = True Else If VR = -1 Then r = ReadVarInt(bstack, v$) IsNumberNew = True Exit Function End If IsNumberNew = False If w2 >= Len(a$) Then a$ = Left$(v$ + space$(Len(v$)), w2 - Len(a$)) + a$ Else If FindNameForGroup(bstack, v$) Then UnknownProperty1 a$, v$ Else UnknownVariable1 a$, v$ End If End If Exit Function Case 7 If usebackup Then GoTo isasub Else GoTo LOOKFORSUBNUM End If Case 6 If usebackup Then If strfunid.Find(v$, w1, bstack.strnum) Then bstack.tmpstr = "@" + v$ + Left$(a$, 1) If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) v$ = vbNullString If IsStr1(bstack, a$, v$) Then r = vbNullString SwapString2Variant v$, r IsNumberNew = True End If Exit Function ElseIf Not stridbackup.Find(v$, w1) Then GoTo isasub End If End If IsNumberNew = False bstack.tmpstr = s1$ + Left$(a$, 1) If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) Exit Function Case 5 'On Error Resume Next If usebackup Then If Not funidbackup.Find(v$, w1) Then ' GoTo LOOKFORSUBNUM GoTo isasub End If Else If Not funid.Find(v$, w1, bstack.numfunnum) Then GoTo LOOKFORSUBNUM If w1 < 0 Then GoTo LOOKFORSUBNUM End If 'Select Case v$ findthird: On w1 GoTo fun1, fun2, fun3, fun4, fun5, fun6, fun7, fun8, fun9, fun10, fun11, fun12, fun13, fun14, fun15, fun16, fun17, fun18, fun19, fun20, fun21, fun22, fun23, fun24, fun25, fun26, fun27, fun28, fun29, fun30, fun31, fun32, fun33, fun34, fun35, fun36, fun37, fun38, fun39, fun40, fun41, fun42, fun43, fun44, fun45, fun46, fun47, fun48, fun49, fun50, fun51, fun52, fun53, fun54, fun55, fun56, fun57, fun58, fun59, fun60, fun61, fun62, fun63, fun64, fun65, fun66, fun67, fun68, fun69, fun70, fun71, fun72, fun73, fun74, fun75, fun76, fun77, fun78, fun79, fun80, fun81, fun82, fun83, fun84, fun85, fun86, fun87, fun88, fun89, fun90, fun91, fun92, fun93, fun94, fun95, fun96, fun97, fun98, fun99, fun100, fun101, fun102, fun103, fun104, fun105, fun106, fun107, fun108, fun109, fun110, fun111, fun112, fun113, fun114, fun115, fun116, fun117, fun118, fun119, fun120, fun121, fun122, fun123, fun124, fun125, fun126, fun127, fun128, fun129, fun130, fun131, fun132 IsNumberNew = False Exit Function fun116: If IsExpBig(bstack, a$, p) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set big = bstack.lastobj Set bstack.lastobj = Module13.CreateBigInteger(StrConv(big.Reminder, vbUnicode)) r = 0 End If ElseIf TypeOf p Is Complex Then r = nMath2.cxModVar(p) End If End If IsNumberNew = FastSymbol(a$, ")", True) Exit Function fun115: If IsExpBig(bstack, a$, p) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then ' IT IS FOR NOW ALWAYS Set big = bstack.lastobj Set bstack.lastobj = Nothing If FastSymbol(a$, ",") Then If IsExpBig(bstack, a$, p) Then If Not bstack.lastobj Is Nothing Then Set p = bstack.lastobj If Not TypeOf p Is BigInteger Then WrongType: Exit Function ElseIf MemInt(VarPtr(p)) = vbString Then Set p = Module13.CreateBigInteger(CStr(p)) Else Set p = Module13.CreateBigInteger(format$(Int(p), "0")) End If If FastSymbol(a$, ",") Then If IsExpBig(bstack, a$, pp) Then If Not bstack.lastobj Is Nothing Then Set pp = bstack.lastobj If Not TypeOf pp Is BigInteger Then WrongType: Exit Function ElseIf MemInt(VarPtr(p)) = vbString Then Set pp = Module13.CreateBigInteger(CStr(p)) Else Set pp = Module13.CreateBigInteger(format$(Int(p), "0")) End If Set bstack.lastobj = big.modpow1(p, pp) r = 0 End If Else missParam a$ Exit Function End If End If Else missParam a$ Exit Function End If End If End If End If IsNumberNew = FastSymbol(a$, ")", True) Exit Function fun113: IsNumberNew = getVarPtr(bstack, a$, r) Exit Function fun112: ' "GETOBJECT(", "ΑΝΤΙΚΕΙΜΕΝΟ(" r = 0 IsNumberNew = createAnobject(bstack, a$) Exit Function fun111: ' "PLAYER(", "ΠΑΙΚΤΗΣ(" If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then r = SpriteVisible(CLng(p)) IsNumberNew = FastSymbol(a$, ")", True) End If Exit Function fun108: '"POINTER(", "ΔΕΙΚΤΗΣ(" IsNumberNew = GetPointer(bstack, a$) Set bstack.lastobj = bstack.lastpointer Set bstack.lastpointer = Nothing If IsNumberNew Then IsNumberNew = FastSymbol(a$, ")") Exit Function fun101: ' "BANK(", "ΤΡΑΠ(" IsNumberNew = False If IsExp(bstack, a$, r, , True) Then If FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then r = Round(r, CLng(p)) IsNumberNew = FastSymbol(a$, ")", True) Else missParam a$ End If Else r = Round(r) IsNumberNew = FastSymbol(a$, ")", True) End If Else missParam a$ End If Exit Function fun99: ' case "IF(","ΑΝ(" IsNumberNew = False If IsExp(bstack, a$, p) Then IsNumberNew = ProcessIf(p, bstack, a$, r) Exit Function fun97: ' "READY(", "ΕΤΟΙΜΟ(" IsNumberNew = False w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then r = Not var(w1).Busy Else r = True End If IsNumberNew = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, ppppl) Then If Not NeoGetArrayItem(ppppl, bstack, s$, w2, a$) Then Exit Function If ppppl.ItemType(w2) = doc Then r = Not ppppl.item(w2).Busy Else r = True End If Else End If IsNumberNew = FastSymbol(a$, ")", True) Else missParam a$ End If Exit Function fun100: ' "ORDER(","ΤΑΞΗ(" ok If IsFlatStringExpr(bstack, a$, s1$) Then If FastSymbol(a$, ",") Then If IsFlatStringExpr(bstack, a$, s$) Then If FastSymbol(a$, ")") Then IsNumberNew = True r = -compareStr4(s$, s1$) Else SyntaxError End If ElseIf LastErNum1 Then Else MissStringExpr End If Else missParam a$ End If ElseIf LastErNum1 Then Else MissStringExpr End If Exit Function fun1: ' "PARAM(", "ΠΑΡΑΜ(" ok (added Complex numbers) v$ = vbNullString If IsStrExp(bstack, a$, s1$) Then j1993874: Do w1 = Len(s1$) If IsNumberD2(s1$, p) Then If v$ = vbNullString Then SwapVariant r, p p = vbNullString v$ = " " Else Select Case VarType(p) Case vbDate v$ = v$ + "," + str$(MemDbl(VarPtr(p) + 8)) + "ud" Case vbByte v$ = v$ + "," + str$(p) + "ub" Case vbLong v$ = v$ + "," + str$(p) + "&" Case vbDecimal v$ = v$ + "," + str$(p) + "@" Case vbSingle v$ = v$ + "," + str$(p) + "~" Case vbCurrency v$ = v$ + "," + str$(p) + "#" Case vbInteger v$ = v$ + "," + str$(p) + "%" Case 20 v$ = v$ + "," + str$(p) + "&&" Case vbObject If TypeOf p Is BigInteger Then Set big = p v$ = v$ + "," + big.ToString + "u" Set big = Nothing Else v$ = v$ + ", 0" End If Case 36 If TypeOf p Is Complex Then v$ = v$ + ", " + strComplex(p, , True) Else v$ = v$ + ", 0" End If Case Else v$ = v$ + "," + str$(p) End Select End If Else ISSTRINGA s1$, s$ If v$ = vbNullString Then Exit Do Else v$ = v$ + ",{" + s$ + "}" End If FastSymbol s1$, "," Loop Until Trim$(s1) = vbNullString Or w1 = Len(s1$) If IsObject(r) Then ' ??? Set bstack.lastobj = r r = 0 End If ElseIf LastErNum1 Then ElseIf IsExp(bstack, a$, p) Then If MemInt(VarPtr(p)) = vbString Then s1$ = p: GoTo j1993874 If bstack.lastobj Is Nothing Then ExpectedObjInline a$ ElseIf TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing If usehandler.indirect >= 0 Then If MyIsObject(var(usehandler.indirect)) Then dd = usehandler.indirect Set usehandler = New mHandler On Error Resume Next FastSymbol a$, "," Set usehandler.objref = MakeATypeLib(var(dd)) If Err Then Err.Clear Set bstack.lastobj = Nothing cantreadlib a$ Else usehandler.t1 = 1 Set bstack.lastobj = usehandler End If On Error GoTo 0 Set usehandler = Nothing Else ExpectedObjInline a$ End If Else If usehandler.IamEnum Then Set anything = usehandler.objref: GoTo contparamhere End If ElseIf TypeOf bstack.lastobj Is PropReference Then Set UseProp = bstack.lastobj If UseProp.IsObj Then UseProp.UseIndex = False r = UseProp.Value If UseProp.LastHasObject Then Set anything = UseProp.lastobj UseProp.clearlastobject r = 0 Else Set anything = Nothing End If contparamhere: Set usehandler = New mHandler On Error Resume Next FastSymbol a$, "," Set usehandler.objref = MakeATypeLib(anything) If Err Then Err.Clear Set bstack.lastobj = Nothing cantreadlib a$ Else usehandler.t1 = 1 Set bstack.lastobj = usehandler End If On Error GoTo 0 Else ExpectedObjInline a$ End If Else Set anything = bstack.lastobj Set usehandler = New mHandler On Error Resume Next FastSymbol a$, "," Set usehandler.objref = MakeATypeLib(anything) If Err Then Err.Clear Set bstack.lastobj = Nothing cantreadlib a$ Else usehandler.t1 = 1 Set bstack.lastobj = usehandler End If On Error GoTo 0 End If ElseIf LastErNum1 Then Exit Function Else missParam a$ End If If FastSymbol(a$, ")", True) Then ' EMIT CODE IN CODE a$ = Mid$(v$, 2) + a$ IsNumberNew = True End If Exit Function fun73: ' "EACH(" If iter(bstack, a$, 1) Then r = 0 IsNumberNew = FastSymbol(a$, ")", True) End If Exit Function fun72: ' "ΚΑΘΕ(" If iter(bstack, a$, 0) Then r = 0 IsNumberNew = FastSymbol(a$, ")", True) Else IsNumberNew = False End If Exit Function fun2: ' "STACKITEM(", "ΤΙΜΗΣΩΡΟΥ(" IsNumberNew = StackItem(bstack, a$, r) If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun3: ' "SGN(", "ΣΗΜ(" If IsExpBig(bstack, a$, p, flatobject:=True, nostring:=True) Then If bstack.lastobj Is Nothing Then r = Sgn(MyRound(p, 28)) Else r = bstack.lastobj.bSgn() Set bstack.lastobj = Nothing End If IsNumberNew = FastSymbol(a$, ")", True) Else missParam a$: IsNumberNew = False End If Exit Function fun4: ' "FRAC(", "ΔΕΚ(" If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then p = Abs(p) If Left(a$, 1) = "!" Then Mid$(a$, 1, 1) = " " r = Abs(p - Int(p)) IsNumberNew = True Else r = MyRound(Abs(p - Int(p)), 13) End If IsNumberNew = FastSymbol(a$, ")", True) Else missParam a$: IsNumberNew = False End If Exit Function fun5: ' "MATCH(", "ΤΑΥΤΙΣΗ(" ok If IsFlatStringExpr(bstack, a$, s1$) Then If s1$ = vbNullString Then r = 0 IsNumberNew = FastSymbol(a$, ")", True) ElseIf VALIDATEmStiva(bstack, UCase$(s1$), s$) Then ' Only S and N If s$ = vbNullString Then r = False Else r = True End If Else r = False End If IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun6: ' "LOCALE(", "ΤΟΠΙΚΟ(" ok If IsFlatStringExpr(bstack, a$, s1$) Then If FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then r = FoundSpecificLocaleId(s1$, CLng(Fix(p))) ElseIf LastErNum1 Then Else missParam a$ Exit Function End If Else r = FoundLocaleId(s1$) End If IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun7: ' "FILELEN(", "ΑΡΧΕΙΟΥ.ΜΗΚΟΣ(" ok If IsFlatStringExpr(bstack, a$, s1$) Then If s1$ = vbNullString Then r = 0 nosuchfile Exit Function Else If ExtractPath(s1$) = vbNullString Then If CFname(s1$) <> "" Then s1$ = CFname(s1$) ElseIf mylcasefILE(s1$) = ExtractName(s1$, True) Then s1$ = mcd + s1$ End If End If If GetDosPath(s1$) = "" Then nosuchfile Exit Function Else r = myFileLen(GetDosPath(s1$)) End If End If IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun8: ' "TAB(", "ΣΤΗΛΗ(" If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then r = p * (players(GetCode(bstack.Owner)).Column + 1) IsNumberNew = FastSymbol(a$, ")", True) End If Exit Function fun9: ' "KEYPRESS(", "ΠΑΤΗΜΕΝΟ(" ok If Not IsExp(bstack, a$, p) Then MissNumExpr Exit Function ElseIf LastErNum1 Then Exit Function ElseIf FastSymbol(a$, "!") Then ' new from Rev 20 Version 14 r = CLng(KeyPressed1(CLng(Fix(p)))) Else r = CLng(KeyPressed(CLng(Fix(p)))) End If IsNumberNew = FastSymbol(a$, ")", True) Exit Function fun10: ' "INKEY(", "ΕΝΚΟΜ(" ok BLOCKkey = True If Not IsExp(bstack, a$, p) Then p = 50: dn = 1 If p < 50 Then p = 50 p = p / 2 Call GetSystemTimeAsFileTime(basictimer) p = p + basictimer If dn = 1 Then r = 0 Else r = clickMe If Not (bstack.IamThread And dn = 1) Then clickMe2 = -2 w1 = -1 Do While p > basictimer Call GetSystemTimeAsFileTime(basictimer) If Not bstack.IamThread Then MyDoEvents mywait bstack, 5 Else p = 0 If r = clickMe2 Then Exit Do r = -3 clickMe2 = clickMe End If If clickMe2 = r Then clickMe2 = -2 If w1 = -1 Then If clickMe2 <> -2 Then w1 = clickMe2 If w1 = 19 Or w1 = 131139 Then 'this IS A BREAK BLOCKkey = False Form1.GiveASoftBreak (w1 = 19) End If p = 0 End If End If Loop If bstack.IamThread Then If bstack.LastClick = w1 Then w1 = -1 Else bstack.LastClick = w1 End If End If r = w1 clickMe2 = -1 IsNumberNew = FastSymbol(a$, ")", True) BLOCKkey = False Exit Function fun11: ' "ΤΜΗΜΑ(", "MODULE(" If FastSymbol(a$, ")") Then r = uintnew1(Addr(AddressOf Module2.ExtCall)) IsNumberNew = True Else MakeThisSub1 bstack, a$ If IsLabel(bstack, a$, s$) Then r = True If Right$(s$, 1) = "(" Then FastSymbol a$, ")" s$ = s$ + ")" End If If GetlocalSub(s$, w1) Then ElseIf Not GetSub(s$, w1) Then If Not GetSub2(bstack, s$, w1) Then r = False End If End If If FastSymbol(a$, "!") Then r = w1 End If IsNumberNew = True End If IsNumberNew = FastSymbol(a$, ")", True) End If Exit Function fun12: ' "ΒΑΣΗ(", "MDB(" ok If IsFlatStringExpr(bstack, a$, s$) Then If ExtractType(s$) = vbNullString Then s$ = s$ + ".MDB" s$ = CFname(s$) If s$ <> "" Then r = CheckMine(s$) Else r = False IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun13: ' "ASK(", "ΡΩΤΑ(" ok If IsFlatStringExpr(bstack, a$, AskText$) Then If Not CallAsk(bstack, a$, v$) Then IsNumberNew = False: Exit Function r = Form1.NeoASK(bstack) AskInput = False IsNumberNew = FastSymbol(a$, ")", True) End If Exit Function fun14: ' "ΣΥΓΚΡΟΥΣΗ(", "COLLIDE(" IsNumberNew = IsCollide(bstack, a$, r) Exit Function fun15: ' "ΜΕΓΕΘΟΣ.Υ(", "SIZE.Y(" IsNumberNew = SizeY(bstack, a$, s$, s1$, r) Exit Function fun16: ' "ΜΕΓΕΘΟΣ.Χ(", "SIZE.X(" IsNumberNew = SizeX(bstack, a$, s$, s1$, r) Exit Function fun17: ' "WRITABLE(", "ΕΓΓΡΑΨΙΜΟ(" If IsFlatStringExpr(bstack, a$, s$) Then r = WeCanWrite(s$) IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun110: '"HSL(","ΧΚΦ(" If Not ColorHSL(bstack, a$, r) Then Exit Function r = -r IsNumberNew = FastSymbol(a$, ")", True) Exit Function fun18: ' "COLOR(", "COLOUR(", "ΧΡΩΜΑ(" If Not ColorRGB(bstack, a$, r) Then Exit Function r = -r IsNumberNew = FastSymbol(a$, ")", True) Exit Function fun19: ' "DIMENSION(", "ΔΙΑΣΤΑΣΗ(" IsNumberNew = IsDimension(bstack, a$, r) Exit Function fun20: ' "ARRAY(", "ΠΙΝΑΚΑΣ(" IsNumberNew = IsArrayFun(bstack, a$, r) If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun21: ' "FUNCTION(", "ΣΥΝΑΡΤΗΣΗ(" ok If IsFlatStringExpr(bstack, a$, s$) Then If IsSymbolBracket(s$) Then PushStage bstack, False s1$ = block(s$) FastSymbol s$, "}" GlobalSub "A_()", s1$, Trim$(s$) IsSymbol3 a$, "," a$ = "A_(*" + a$ IsNumberNew = IsExp(bstack, a$, r) PopStage bstack Else If lookOne(a$, ".") Then dd = 1 s1$ = aheadstatus(a$, , dd) s$ = s$ + Left$(a$, dd - 1) a$ = Mid$(a$, dd) End If FastSymbol a$, "," ' manipulate inline the code... If Right$(s$, 1) = ")" Then a$ = Left$(s$, Len(s$) - 1) + a$ ElseIf InStr(s$, ").") > 0 Then If Not FastSymbol(a$, ")") Then a$ = s$ + "(*" + a$ Else a$ = s$ + a$ End If Else a$ = s$ + "(*" + a$ End If IsNumberNew = IsExp(bstack, a$, r) End If ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun22: ' "DRIVE.SERIAL(", "ΣΕΙΡΙΑΚΟΣ.ΔΙΣΚΟΥ(" ok IsNumberNew = DriveSerial1(bstack, a$, r) Exit Function fun23: ' "FILE.STAMP(", "ΑΡΧΕΙΟΥ.ΣΤΑΜΠΑ(" ok If IsFlatStringExpr(bstack, a$, s$) Then pp = 1 If IsSymbol(a$, ",") Then If Not IsExp(bstack, a$, pp) Then MissNumExpr Exit Function End If End If If CFname(s$, p, pp) <> vbNullString Then If p = 0 Then CantReadFileTimeStap a$ Else r = p End If Else BadFilename Exit Function End If IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun25: ' "EXIST.DIR(", "ΥΠΑΡΧΕΙ.ΚΑΤΑΛΟΓΟΣ(" ok If IsFlatStringExpr(bstack, a$, s$) Then r = isdir(s$) IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun26: ' "EXIST(", "ΥΠΑΡΧΕΙ(" ok IsNumberNew = ExistNum(bstack, a$, r) Exit Function fun27: ' "JOYPAD(", "ΛΑΒΗ(" ok If IsExp(bstack, a$, r, , True) Then If Not JoyPadRead(r, a$) Then Exit Function r = MYJOYSTAT(r).lngButton IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun28: ' "JOYPAD.DIRECTION(", "ΛΑΒΗ.ΚΑΤΕΥΘΥΝΣΗ(" ok If IsExp(bstack, a$, r, , True) Then If Not JoyPadRead(r, a$) Then Exit Function r = MYJOYSTAT(r).joyPaD IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun29: ' "JOYPAD.ANALOG.X(", "ΛΑΒΗ.ΑΝΑΛΟΓΙΚΟ.Χ(" ok IsNumberNew = False If IsExp(bstack, a$, r, , True) Then If Not JoyPadRead(r, a$) Then Exit Function r = MYJOYSTAT(r).AnalogX ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun30: ' "JOYPAD.ANALOG.Y(", "ΛΑΒΗ.ΑΝΑΛΟΓΙΚΟ.Υ(" ok If IsExp(bstack, a$, r, , True) Then If Not JoyPadRead(r, a$) Then Exit Function r = MYJOYSTAT(r).AnalogY IsNumberNew = FastSymbol(a$, ")", True) ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fun104: ' "BUFFER(", "ΔΙΑΡΘΡΩΣΗ(" ok IsNumberNew = False If IsStrExp(bstack, a$, s$) Then j243423: If Not bstack.lastobj Is Nothing Then GoTo contbuf1 w1 = Abs(Asc(v$) < 128) If IsLabelSymbolNew(a$, "ΩΣ", "AS", w1) Then If IsLabelSymbolNew(a$, "ΔΕΚΑΕΞ", "HEX", w1) Then Set usehandler = New mHandler usehandler.t1 = 2 Set usehandler.objref = DecodeHEXtoMemBloc(s$, par) ElseIf Not IsSymbol(a$, "DECODE64", 8) Then MyEr "Only Decode64 supported", "Μόνο το Decode64 υποστηρίζεται" Exit Function Else Set usehandler = New mHandler usehandler.t1 = 2 Set usehandler.objref = Decode64toMemBloc(s$, par) End If If par Then Set bstack.lastobj = usehandler IsNumberNew = FastSymbol(a$, ")", True) Exit Function Else MyEr "Can't Decode String", "Δεν μπορώ να αποκωδικοποιήσω το αλφαριθμητικό" IsNumberNew = False Exit Function End If ElseIf CFname(s$) <> "" Then Set usehandler = New mHandler usehandler.t1 = 2 If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, p) Then MissNumExpr Exit Function End If End If Set usehandler.objref = File2newMemblock(s$, r, p) If r = 0# Then Set bstack.lastobj = usehandler IsNumberNew = FastSymbol(a$, ")", True) Exit Function End If Else MissFile End If ElseIf IsExp(bstack, a$, r) Then If myVarType(r, vbString) Then s$ = r: GoTo j243423 End If contbuf1: r = 0# p = 0# If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing r = 0 If usehandler.t1 = 2 Then p = 0 If FastSymbol(a$, ",") Then IsExp bstack, a$, r If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, p) Then MissNumExpr Exit Function End If End If End If Set anything = Nothing If usehandler.CopyMemBlock(r, p, anything) Then Set usehandler = New mHandler usehandler.t1 = 2 Set usehandler.objref = anything Set bstack.lastobj = usehandler End If IsNumberNew = FastSymbol(a$, ")", True) Exit Function End If End If End If Else IsNumberNew = FastSymbol(a$, ")", True) End If ' no buffer return (using Buffer() as empty function) r = 0# Set bstack.lastobj = Nothing Exit Function fun103: ' "IMAGE(", "ΕΙΚΟΝΑ(" ok IsNumberNew = ImageFunc(bstack, a$, r, -(AscW(v$) < 256)) Exit Function fun31: ' "IMAGE.X(", "ΕΙΚΟΝΑ.Χ(" ok IsNumberNew = GetImageX(bstack, a$, r) Exit Function fun32: ' "IMAGE.Y(", "ΕΙΚΟΝΑ.Υ(" ok IsNumberNew = GetImageY(bstack, a$, r) Exit Function fun33: ' "IMAGE.X.PIXELS(", "ΕΙΚΟΝΑ.Χ.ΣΗΜΕΙΑ(" ok IsNumberNew = GetImageXpixels(bstack, a$, r) Exit Function fun34: ' "IMAGE.Y.PIXELS(", "ΕΙΚΟΝΑ.Υ.ΣΗΜΕΙΑ(" ok IsNumberNew = GetImageYpixels(bstack, a$, r) Exit Function fun35: ' "VALID(", "ΕΓΚΥΡΟ(" IsNumberNew = Validator(bstack, a$, v$, r) Exit Function fun36: ' "EVAL(", "ΕΚΦΡ(", "ΕΚΦΡΑΣΗ(" IsNumberNew = IsEval(v$, bstack, a$, r) If FastOperator(a$, "(", 1) Then If Not bstack.lastobj Is Nothing Then If Typename(bstack.lastobj) = mHdlr Then Set ppppl = New tuple Set ppppl.GroupRef = bstack.lastobj Set bstack.lastobj = Nothing ppppl.arr = False GoTo contAr2L ElseIf Typename(bstack.lastobj) = myArray Then Set ppppl = bstack.lastobj Set bstack.lastobj = Nothing v$ = ppppl.CodeName + "(" GoTo contAr2 ElseIf Typename(bstack.lastobj) = mGroup Then GoTo contgrouppar End If Else SyntaxError Exit Function End If End If If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun37: ' "POINT(", "ΣΗΜΕΙΟ(" IsNumberNew = IsPoint(bstack, a$, r) Exit Function fun38: ' "CTIME(", "ΥΠΩΡΑ(" IsNumberNew = IsCtime(bstack, a$, r) Exit Function fun39: ' "CDATE(", "ΥΠΜΕΡ(" IsNumberNew = IsCdate(bstack, a$, r) Exit Function fun40: ' "TIME(", "ΧΡΟΝΟΣ(" IsNumberNew = IsTimeVal(bstack, a$, r) Exit Function fun41: ' "DATE(", "ΗΜΕΡΑ(" IsNumberNew = IsDataVal(bstack, a$, r) Exit Function fun42: ' "VAL(", "ΤΙΜΗ(", "ΑΞΙΑ(" IsNumberNew = IsVal(bstack, a$, r, Left$(v$, 1) = "V") If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun43: ' "ΘΕΣΗΔΕΞΙΑ(" IsNumberNew = IsRinstr(bstack, a$, r, (1), 0) Exit Function fun107: ' "RINSTR(" IsNumberNew = IsRinstr(bstack, a$, r, (1), 1) Exit Function fun44: ' "INSTR(", "ΘΕΣΗ(" IsNumberNew = IsInstr(bstack, a$, r, (1), 0) Exit Function fun106: IsNumberNew = IsInstr(bstack, a$, r, (1), 1) Exit Function fun45: ' "RECORDS(", "ΕΓΓΡΑΦΕΣ(" IsNumberNew = IsRecords(bstack, a$, r) Exit Function fun46: ' "GROUP.COUNT(", "ΟΜΑΔΑ.ΣΥΝΟΛΟ(" IsNumberNew = IsGroupCount(bstack, a$, r) Exit Function fun47: ' "PARAGRAPH(", "ΠΑΡΑΓΡΑΦΟΣ(" IsNumberNew = IsParagr(bstack, a$, r) Exit Function fun48: ' "PARAGRAPH.INDEX(", "ΑΡΙΘΜΟΣ.ΠΑΡΑΓΡΑΦΟΥ(" IsNumberNew = IsParIndex(bstack, a$, r) Exit Function fun49: ' "BACKWARD(", "ΠΙΣΩ(" IsNumberNew = IsForwBack(1, bstack, a$, r) Exit Function fun50: ' "FORWARD(", "ΜΠΡΟΣΤΑ(" IsNumberNew = IsForwBack(0, bstack, a$, r) Exit Function fun51: ' "DOC.PAR(", "ΕΓΓΡΑΦΟΥ.ΠΑΡ(" IsNumberNew = IsDocPar(bstack, a$, r) Exit Function fun52: ' "MAX.DATA(", "ΜΕΓΑΛΟ.ΣΕΙΡΑΣ(" IsNumberNew = IsMaxData(bstack, a$, r) Exit Function fun53: ' "MIN.DATA(", "ΜΙΚΡΟ.ΣΕΙΡΑΣ(" IsNumberNew = IsMinData(bstack, a$, r) Exit Function fun54: ' "MAX(", "ΜΕΓΑΛΟ(" IsNumberNew = IsCompMinMax(2, bstack, a$, r) Exit Function fun55: ' "MIN(", "ΜΙΚΡΟ(" IsNumberNew = IsCompMinMax(1, bstack, a$, r) Exit Function fun56: ' "COMPARE(", "ΣΥΓΚΡΙΝΕ(" IsNumberNew = IsCompMinMax(0, bstack, a$, r) Exit Function fun57: ' "DOC.UNIQUE.WORDS(", "ΕΓΓΡΑΦΟΥ.ΜΟΝΑΔΙΚΕΣ.ΛΕΞΕΙΣ(" IsNumberNew = IsDocUniqueWords(bstack, a$, r) Exit Function fun58: ' "DOC.WORDS(", "ΕΓΓΡΑΦΟΥ.ΛΕΞΕΙΣ(" IsNumberNew = IsDocWords(bstack, a$, r) Exit Function fun59: ' "DOC.LEN(", "ΕΓΓΡΑΦΟΥ.ΜΗΚΟΣ(" IsNumberNew = IsDocLen(bstack, a$, r) Exit Function fun60: ' "LEN.DISP(", "ΜΗΚΟΣ.ΕΜΦ(" IsNumberNew = IsLenDisp(bstack, a$, r) Exit Function fun61: ' "LEN(", "ΜΗΚΟΣ(" IsNumberNew = IsLen(bstack, a$, r) Exit Function fun62: ' "SQRT(", "ΡΙΖΑ(" IsNumberNew = IsSqrt(bstack, a$, r) Exit Function fun63: ' "FREQUENCY(", "ΣΥΧΝΟΤΗΤΑ(" IsNumberNew = IsFreq(bstack, a$, r) Exit Function fun64: ' "LOG(", "ΛΟΓ(" IsNumberNew = IsLog(bstack, a$, r) Exit Function fun65: ' "LN(", "ΛΦ(" IsNumberNew = IsLn(bstack, a$, r) Exit Function fun66: ' "ATN(", "ΤΟΞ.ΕΦ(" IsNumberNew = IsAtan(bstack, a$, r) Exit Function fun125: ' "RATN(", "ΗΤΟΞ.ΕΦ(" IsNumberNew = IsAtanRad(bstack, a$, r) Exit Function fun126: ' "PLAYVALUE(", "ΠΑΙΖΕΙΑΞΙΑ(" IsNumberNew = IsMusicBox(0, bstack, a$, r) Exit Function fun127: ' "PLAYVOLUME(", "ΠΑΙΖΕΙΕΝΤΑΣΗ(" IsNumberNew = IsMusicBox(1, bstack, a$, r) Exit Function fun128: ' "PLAYNOTE(", "ΠΑΙΖΕΙΝΟΤΑ(" IsNumberNew = IsMusicBox(2, bstack, a$, r) Exit Function fun129: ' "PLAYNOW(", 129, "ΠΑΙΖΕΙΤΩΡΑ(", IsNumberNew = IsMusicBox(3, bstack, a$, r) Exit Function fun130: ' "PLAYDOTS(", 130, "ΠΑΙΖΕΙΤΕΛΕΙΕΣ(", 130 IsNumberNew = IsMusicBox(4, bstack, a$, r) Exit Function fun131: ' "PLAYGATE(", 131, "ΠΑΙΖΕΙΠΟΡΤΑ(", 131 IsNumberNew = IsMusicBox(5, bstack, a$, r) Exit Function fun132: ' "PLAYTUPLET(", 132, "ΠΑΙΖΕΙΣΧΗΜΑ(", 132 IsNumberNew = IsMusicBox(6, bstack, a$, r) Exit Function fun67: ' "TAN(", "ΕΦΑΠ(" IsNumberNew = IsTan(bstack, a$, r) Exit Function fun124: ' "RTAN(", "ΑΕΦΑΠ(" IsNumberNew = IsTanRad(bstack, a$, r) Exit Function fun68: ' "COS(", "ΣΥΝ(" IsNumberNew = IsCos(bstack, a$, r) Exit Function fun122: ' "RCOS(", "ΑΣΥΝ(" IsNumberNew = IsCosRad(bstack, a$, r) Exit Function fun69: ' "SIN(", "ΗΜ(" IsNumberNew = IsSin(bstack, a$, r) Exit Function fun123: ' "RSIN(", "ΑΗΜ(" IsNumberNew = IsSinRad(bstack, a$, r) Exit Function fun70: ' "ABS(", "ΑΠΟΛ(" IsNumberNew = IsAbs(bstack, a$, r) Exit Function fun71: ' "LOWORD(", "LOWWORD(", "ΚΑΤΩΜΙΣΟ(" IsNumberNew = IsLOWORD(bstack, a$, r) Exit Function fun74: ' "HIWORD(", "HIGHWORD(", "ΠΑΝΩΜΙΣΟ(" IsNumberNew = IsHIWORD(bstack, a$, r) Exit Function fun75: ' "BINARY.NEG(", "ΔΥΑΔΙΚΟ.ΑΝΤΙ(", "ΔΥΑΔΙΚΟ.ΑΝΤΙΣΤΡΟΦΟ(" IsNumberNew = IsBinaryNeg(bstack, a$, r) Exit Function fun76: ' "BINARY.OR(", "ΔΥΑΔΙΚΟ.Η(" IsNumberNew = IsBinaryOr(bstack, a$, r) Exit Function fun105: ' "BINARY.NOT(", "ΔΥΑΔΙΚΟ.ΟΧΙ(" IsNumberNew = IsBinaryNot(bstack, a$, r) Exit Function fun77: ' "BINARY.AND(", "ΔΥΑΔΙΚΟ.ΚΑΙ(" IsNumberNew = IsBinaryAnd(bstack, a$, r) Exit Function fun78: ' "BINARY.XOR(", "ΔΥΑΔΙΚΟ.ΑΠΟ(" IsNumberNew = IsBinaryXor(bstack, a$, r) Exit Function fun79: ' "HILOWWORD(", "ΔΥΟΜΙΣΑ(" IsNumberNew = IsHILOWWORD(bstack, a$, r) Exit Function fun80: ' "BINARY.SHIFT(", "ΔΥΑΔΙΚΟ.ΟΛΙΣΘΗΣΗ(" IsNumberNew = IsBinaryShift(bstack, a$, r) Exit Function fun81: ' "BINARY.ROTATE(", "ΔΥΑΔΙΚΗ.ΠΕΡΙΣΤΡΟΦΗ(" IsNumberNew = IsBinaryRotate(bstack, a$, r) Exit Function fun82: ' "SINT(", "ΑΚΕΡΑΙΟ.ΔΥΑΔΙΚΟ(" ' GET AN Unsigned AND GIVES A SIGN...AS READING BITS IsNumberNew = IsSint(bstack, a$, r) Exit Function fun83: ' "USGN(", "ΔΥΑΔΙΚΟ(" IsNumberNew = IsUsgn(bstack, a$, r) Exit Function fun84: ' "UINT(", "ΔΥΑΔΙΚΟ.ΑΚΕΡΑΙΟ(" ' READING BITS OF A SIGN AND GIVE AN Unsigned OF SAME BITS IsNumberNew = IsUint(bstack, a$, r) Exit Function fun102: ' "CEIL(","ΟΡΟΦ(" IsNumberNew = IsCeil(bstack, a$, r) Exit Function fun85: ' "ROUND(", "ΣΤΡΟΓΓ(" IsNumberNew = IsRound(bstack, a$, r) Exit Function fun86: ' "INT(", "ΑΚ(", "FLOOR(","ΔΑΠΕΔ(" IsNumberNew = IsInt(bstack, a$, r) Exit Function fun87: ' "SEEK(", "ΜΕΤΑΘΕΣΗ(" IsNumberNew = IsSeek(bstack, a$, r) Exit Function fun88: ' "EOF(", "ΤΕΛΟΣ(" IsNumberNew = IsEof(bstack, a$, r) Exit Function fun89: ' "RANDOM(", "ΤΥΧΑΙΟΣ(" IsNumberNew = IsRandom(bstack, a$, r) Exit Function fun24: ' "STACK(", "ΣΩΡΟΣ(" IsNumberNew = IsStack(bstack, a$, r) Exit Function fun92: ' "GROUP(", "ΟΜΑΔΑ(" IsNumberNew = IsGroupCom(bstack, a$, r) Exit Function fun98: ' "PROPERTY(", "ΙΔΙΟΤΗΤΑ(" IsNumberNew = IsProperty(bstack, a$, r) Exit Function fun90: ' "CHRCODE(", "ΧΑΡΚΩΔ(" IsNumberNew = IsChrCode(bstack, a$, r) Exit Function fun91: ' "ASC(", "ΚΩΔ(" IsNumberNew = IsAsc(bstack, a$, r) Exit Function fun94: ' "CONS(", "ΕΝΩΣΗ(" IsNumberNew = IsCons(bstack, a$, r) If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun95: ' "CAR(", "ΠΡΩΤΟ(" IsNumberNew = IsCar(bstack, a$, r) If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun96: ' "CDR(", "ΕΠΟΜΕΝΑ(" IsNumberNew = IsCdr(bstack, a$, r) If FastSymbol1(a$, "#") Then GoTo comehere Exit Function fun93: ' "TEST(", "ΔΟΚΙΜΗ(" IsNumberNew = IsTest(bstack, a$, r) Exit Function fun109: ' "BINARY.ADD(", "ΔΥΑΔΙΚΟ.ΠΡΟΣΘΕΣΗ(","ΔΥΑΔΙΚΟ.ΠΡΟ(" IsNumberNew = IsBinaryAdd(bstack, a$, r) Exit Function fun114: ' ok If IsExp(bstack, a$, p) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p GoTo FUN114A End If MissStringExpr Exit Function ElseIf IsStrExp(bstack, a$, s$, False) Then FUN114A: p = 0 If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, p, , True, , True) Then MissNumExpr Exit Function End If Else p = 10 End If If FastSymbol(a$, ")") Then IsNumberNew = True r = 0 If p > 1 And p < 37 Then Set bstack.lastobj = CreateBigInteger(s$, p) Else Set bstack.lastobj = CreateBigInteger(s$) End If End If ElseIf FastSymbol(a$, ")") Then IsNumberNew = True r = 0 Set bstack.lastobj = CreateBigInteger("0") End If Exit Function fun117: IsNumberNew = isConj(bstack, a$, r) Exit Function fun118: IsNumberNew = isArg(bstack, a$, r) Exit Function fun119: IsNumberNew = isPhase(bstack, a$, r) Exit Function fun120: IsNumberNew = isPolar(bstack, a$, r) Exit Function fun121: IsNumberNew = isExpFun(bstack, a$, r) Exit Function LOOKFORSUBNUM: ''On Error Resume Next If Len(s1$) = 1 Then If s1$ = Chr(0) Then If bstack.lastpointer Is Nothing Then GoTo skiperror Set ppppl = bstack.lastpointer Set bstack.lastpointer = Nothing w2 = 0 GoTo contAr22 Else SyntaxError Exit Function End If End If s$ = s1$ s1$ = v$ + ")" ' ANY CHAR HERE MakeThisSubNum bstack, s1$ If IsSymbol(a$, "*") Then 'is a function allways... If GetlocalSub(s1$, V1&) Then GoTo contAr1 ElseIf GetSub(s1$, V1&) Then GoTo contAr1 ElseIf GetSub2(bstack, s1$, V1&) Then GoTo contAr1 Else GoTo skiphere End If Else If neoGetArray(bstack, v$, ppppl, , , True) Then GoTo contAr2L ElseIf LastErNum <> 0 Then Exit Function ElseIf GetlocalSub(s1$, V1&) Then GoTo contAr1 ElseIf neoGetArray(bstack, v$, ppppl, , True) Then GoTo contAr2 ElseIf GetSub2(bstack, s1$, V1&) Then GoTo contAr1 ElseIf GetSub(s1$, V1&) Then GoTo contAr1 Else skiphere: If Len(bstack.UseGroupname) > 0 Then If InStr(s1$, bstack.UseGroupname) = 1 Then s1$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(s1$, Len(bstack.UseGroupname) + 1) If GetSub(s1$, V1&) Then GoTo contAr1 End If End If If Right$(s1$, 1) = ")" Then If here$ Like "*." + s1$ Then subHash.ItemCreatorNoSwap s1$, bstack.OriginalCode, True GoTo contAr1 ElseIf s1$ = "LAMBDA()" Then contlambda01: If bstack.IamLambda Then s1$ = bstack.FuncRec Else s1$ = Mid$(here$, rinstr(here$, "».") + 2) If Right$(here$, 2) = "()" And bstack.UseGroupname = vbNullString Then s1$ = sbf(bstack.OriginalCode).goodname V1& = bstack.OriginalCode ElseIf Not GetSub(s1$, V1&) Then If here$ Like "*." + s1$ Then s1$ = sbf(bstack.OriginalCode).goodname V1& = bstack.OriginalCode Else GoTo skiperror End If End If End If GoTo contAr1 ElseIf s1$ = "ΛΑΜΔΑ()" Then GoTo contlambda01 Else If Right$(s1$, 3) <> "$()" Then If neoGetArray(bstack, Left$(s1$, Len(s1$) - 2) + "$(", ppppl) Then If Typename(ppppl.GroupRef) = mGroup Then If TypeOf ppppl Is iBoxArray Then v$ = Left$(s1$, Len(s1$) - 2) ppppl.CodeName = v$ End If End If GoTo contAr2 End If End If dd = dd + 1 If dd > 30 Then IsNumberNew = False Exit Function End If End If End If If funidbackup.Find(v$, w1) Then GoTo findthird GoTo skiperror End If End If '''ver 18 If GetSub(s1$, V1&) Then GoTo contAr1 ElseIf neoGetArray(bstack, v$, ppppl) Then GoTo contAr2 Else GoTo skiperror End If If GetSub(s1$, V1&) Then contAr1: 's1$ = Trim$(s1$) If bstack.NoFuncError Then CallNext bstack, a$, par, p, v$ If par Then r = p IsNumberNew = True Else r = 0 IsNumberNew = False End If ElseIf V1& = -1 Then s1$ = s$ GoTo isasub Else Set nbstack = New basetask Set nbstack.Parent = bstack If bstack.IamThread Then Set nbstack.Process = bstack.Process Set nbstack.Owner = bstack.Owner nbstack.OriginalCode = V1& nbstack.UseGroupname = sbf(V1&).sbgroup nbstack.tpointer = sbf(V1&).tpointer nbstack.SetV If GoFunc(nbstack, s1$, a$, p) Then ' Lookone(a$,"#") goodjump: If Left$(a$, 1) = "#" Then If nbstack.lastobj Is Nothing Then NotArray IsNumberNew = False End If Set nbstack = Nothing Set anything = bstack.lastobj ' Set bstack.lastobj = anything If TypeOf bstack.lastobj Is mHandler Then FastSymbol a$, "#" ' Set nbstack = Nothing Set bstack.lastobj = anything GoTo comehere ElseIf TypeOf bstack.lastobj Is Group Then jumpgroup001: Set userGroup = anything Set nbstack = Nothing Set bstack.lastobj = anything If Not (userGroup.HasValue And Not userGroup.HasParameters) Then Mid$(a$, 1, 1) = "." End If again1001: Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstack.lastobj w2 = -2 Set nbstack = Nothing Set bstack.lastobj = Nothing GoTo contgroup3 Else Mid$(a$, 1, 1) = Chr$(1) GoTo comehere End If ElseIf Left$(a$, 1) = "." Then If TypeOf bstack.lastobj Is Group Then group00012: Mid$(a$, 1, 1) = "#" Set anything = bstack.lastobj GoTo jumpgroup001 End If ElseIf Left$(a$, 1) = "(" Then If Not bstack.lastobj Is Nothing Then If IsObjLambda(bstack.lastobj) Then FastSymbol a$, "(" If Not CallLambdaASAP(bstack, a$, r) Then IsNumberNew = False: Exit Function ElseIf IsObjmHandler(bstack.lastobj) Or IsobjArray(bstack.lastobj) Then Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstack.lastobj w2 = -2 ' GET THE OBJECT FastSymbol a$, "(" GoTo contlambdahere End If End If ElseIf Left$(a$, 2) = "=>" Then Mid$(a$, 1, 2) = "." + Chr(3) ' Chr$(7) + "." GoTo again1001 ElseIf Left$(a$, 1) = "[" Then If Not nbstack.lastobj Is Nothing Then If TypeOf nbstack.lastobj Is refArray Then Set rA = nbstack.lastobj Set nbstack.lastobj = Nothing Set bstack.lastobj = Nothing Mid$(a$, 1, 1) = " " GoTo jump8 ElseIf IsObjmHandler(nbstack.lastobj) Then Set usehandler = nbstack.lastobj Set nbstack.lastobj = Nothing If usehandler.t1 = 2 Then If FastSymbol(a$, "[") Then GoTo comehere11 End If End If End If End If SyntaxError IsNumberNew = False Exit Function ElseIf Left$(a$, 1) = "|" Then GoTo contUDT1 ElseIf InStr(v$, "%") > 0 Then r = MyRound(p) Else r = p End If IsNumberNew = True Else '' IsNumberNew = False End If End If Exit Function ElseIf neoGetArray(bstack, v$, ppppl) Then contAr2: contAr2L: If MaybeIsSymbol3(a$, ")", w3) Then IsNumberNew = True If Not ppppl.arr Then If Typename(ppppl.GroupRef) = mGroup Then If ppppl.GroupRef.HasParameters Then GoTo conthere102030 Else MyErMacro a$, "No parameter list for this group", "Δεν υπάρχει λίστα παραμέτρων για αυτήν την ομάδα" End If ElseIf Typename(ppppl.GroupRef) = mHdlr Then '' here the poke as alfa(3).value or Αλφα(3).τιμή Set usehandler = ppppl.GroupRef a$ = Mid$(a$, w3 + 1) If usehandler.indirect >= 0 Then MyErMacro a$, "Not implemented yet", "Δεν εχει ακόμα υλοποιηθεί αυτό" Exit Function End If If Left$(a$, 1) = "." Then ' LOOK FOR GROUP w2 = -usehandler.objref.index - 2 GoTo contgroup ElseIf FastSymbol(a$, "(") Then w2 = -usehandler.objref.index - 2 Set usehandler = Nothing GoTo contlambdahere Else Set bstack.lastobj = ppppl If usehandler.t1 = 2 Then r = usehandler.objref.GetPtr(0) Else r = usehandler.objref.Done End If End If Set usehandler = Nothing ElseIf IsObjProp(ppppl.GroupRef) Then Set bstack.lastobj = ppppl a$ = Mid$(a$, w3 + 1) Else a$ = Mid$(a$, w3 + 1) ' what object we have here???? End If Else a$ = Mid$(a$, w3 + 1) r = 0 If FastSymbol1(a$, "#") Then Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = ppppl Set nbstack = Nothing Set bstack.lastobj = usehandler GoTo comehere End If If TypeOf ppppl Is mArray Then Set pppp = ppppl Set bstack.lastobj = pppp ElseIf TypeOf ppppl Is tuple Then Set tu = ppppl Set bstack.lastobj = tu Else Set bstack.lastobj = ppppl End If End If Exit Function End If If ppppl.arr Then ' Set pppp = ppppL dn = 0 ppppl.SerialItem (0), dd, 5 dd = dd - 1 If dd < 0 Then If IsObjProp(ppppl.GroupRef) Then GoTo contreadprop End If End If p = 0 pp = 0 IsNumberNew = True w2 = 0 If TypeOf ppppl Is tuple Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If Not FastSymbol(a$, ")") Then: MissSymbol ")": IsNumberNew = False: Exit Function If p >= ppppl.Count Then GoTo toohigh ElseIf p < 0 Then GoTo toolow Else w2 = p IsNumberNew = True End If End If Else Do While dn <= dd ' pppp.SerialItem w3, dn, 6 Set pppp = ppppl pppp.GetDnum dn, w3, V1& If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If dn < dd Then If Not FastSymbol(a$, ",") Then: MyErMacro a$, "need index for " + v$ + ")", "χρειάζομαι δείκτη για το πίνακα " + v$ + ")": IsNumberNew = False: Exit Function Else If FastSymbol(a$, ",") Then IsNumberNew = False MyErMacro a$, "too many indexes for array " + v$ + ")", "πολλοί δείκτες για το πίνακα " + v$ + ")" Exit Function End If If Not FastSymbol(a$, ")") Then: MissSymbol ")": IsNumberNew = False: Exit Function End If On Error Resume Next If p < -V1& Then IsNumberNew = False toolow: MyErMacro a$, "index too low for array " + v$ + ")", "χαμηλός δείκτης στο πίνακα " + v$ + ")" Exit Function End If If Not pppp.PushOffset(w2, dn, CLng(Fix(p))) Then toohigh: MyErMacro a$, "index too high for array " + v$ + ")", "δείκτης υψηλός για το πίνακα " + v$ + ")" IsNumberNew = False Exit Function End If On Error GoTo 0 Else IsNumberNew = False If Not LastErNum = -2 Then MyErMacro a$, "missing index for array " + v$ + ")", "χάθηκε δείκτης για το πίνακα " + v$ + ")" End If Exit Function End If dn = dn + 1 Loop End If 'Set ppppL = pppp ' here here here contAr22: If ppppl.ItemType(w2) = mGroup Then contgroup00: If Left$(a$, 1) = "." Then contgroup: IsNumberNew = SpeedGroup(bstack, ppppl, "VAL", v$, a$, w2) = 1 r = bstack.LastValue ElseIf Left$(a$, 1) = "(" Then contgroup3: IsNumberNew = SpeedGroup(bstack, ppppl, "VAL", v$, a$, w2) = 1 r = bstack.LastValue Else contgroup2: If ppppl.item(w2).IamApointer Then IsNumberNew = True If Left$(a$, 2) = "=>" Then Mid$(a$, 1, 2) = "." + Chr(3): GoTo contgroup Set bstack.lastpointer = ppppl.item(w2).link Set bstack.lastobj = ppppl.item(w2) r = 0 ElseIf ppppl.item(w2).HasValue Then If ppppl.item(w2).HasParameters Then GoTo contgroup Else IsNumberNew = SpeedGroup(bstack, ppppl, "VAL", v$, "", w2) = 1 r = bstack.LastValue End If Else If ppppl.item(w2).IamApointer Then If Mid(a$, 1, 2) = "=>" Then Mid(a$, 1, 2) = Chr$(0) + "." Set bstack.lastpointer = ppppl.item(w2) GoTo againpointer Else Set bstack.lastobj = ppppl.item(w2) End If Else bstack.soros.CopyGroupObj ppppl.item(w2), anything Set bstack.lastobj = anything End If End If End If Exit Function ElseIf ppppl.ItemIsObject(w2) Then If FastSymbol(a$, "(") Then contlambdahere: w3 = 0 'Set ppppL = pppp Select Case ppppl.ItemType(w2) Case "lambda" contlambdahere2: PushStage bstack, False w1 = globalvarGroup("A_" & (Abs(w2)), 0#) Set var(w1) = ppppl.item(w2) If here$ = vbNullString Then GlobalSub "A_" & (Abs(w2)) & "()", "", , , w1 Else GlobalSub here$ & "." & bstack.GroupName & "A_" & (Abs(w2)) & "()", "", , , w1 End If againlambda: bstack.tmpstr = "A_" & (Abs(w2)) & "(" & Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) IsNumberNew = IsNumberNew(bstack, a$, p, False) If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is lambda Then If IsOperator(a$, "(") Then Set var(w1) = bstack.lastobj GoTo againlambda End If ElseIf IsOperator(a$, "(") Then If TypeOf bstack.lastobj Is iBoxArray Then PopStage bstack ' PopStage bstack Set ppppl = bstack.lastobj Set bstack.lastobj = Nothing w3 = 0 GoTo contAr2 ElseIf TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If usehandler.t1 = 3 Then PopStage bstack Set anything = usehandler If CheckAnyArray(anything) Then Set ppppl = anything Else Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = usehandler End If Set anything = Nothing ElseIf usehandler.t1 = 1 Then PopStage bstack Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = usehandler w2 = -2 GoTo contrightpar Else Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = usehandler End If Set usehandler = Nothing GoTo contAr2 ElseIf TypeOf bstack.lastobj Is Group Then PopStage bstack cont100203030: Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstack.lastobj w2 = -2 GoTo contgroup3 End If ElseIf TypeOf bstack.lastobj Is iBoxArray Then ' mArray PopStage bstack Set ppppl = bstack.lastobj Set bstack.lastobj = Nothing w3 = 0 GoTo contAr2 ElseIf TypeOf bstack.lastobj Is Group Then PopStage bstack Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstack.lastobj w2 = -2 If Left$(a$, 1) = "." Then GoTo contgroup Else GoTo contgroup2 End If End If End If Set var(w1) = Nothing If Right$(ppppl.arrname, 2) = "%(" Then r = MyRound(p) Else r = p End If PopStage bstack IsNumberNew = True Exit Function Case myArray, "tuple" Set ppppl = ppppl.item(w2) w3 = 0 GoTo contAr2 Case mHdlr Set bstack.lastobj = ppppl.item(w2) Set usehandler = bstack.lastobj If usehandler.t1 = 3 Then Set anything = usehandler If CheckAnyArray(anything) Then Set ppppl = anything Else Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = usehandler End If Else If w2 <> -2 Then Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = usehandler End If End If Set anything = Nothing Set bstack.lastobj = Nothing Set usehandler = Nothing w3 = 0 GoTo contAr2 Case mProp ppppl.GetPorp UseProp, w2 w3 = 0 Set bstack.lastobj = Nothing Set usehandler = Nothing GoTo contreadprop2 Case "ppppLight" Set bstack.lastobj = Nothing Set usehandler = Nothing w3 = 0 Set ppppl = ppppl.item(w2) GoTo contreadprop2 End Select Set bstack.lastobj = Nothing Set usehandler = Nothing w3 = 0 'Set ppppL = pppp GoTo contAr2 ElseIf Left$(a$, 2) = "=>" Then Set anything = ppppl.itemObject(w2) GoTo com123cont Else ' here is the fault r = rValue(bstack, ppppl.itemObject(w2)) If FastSymbol1(a$, "#") Then Set nbstack = Nothing ' ??? comehere: If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing IsNumberNew = fMatrix(bstack, a$, usehandler, r) If Left$(a$, 1) = "." And Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then GoTo cont100203030 End If ElseIf bstack.lastobj Is Nothing Then ElseIf Not TypeOf bstack.lastobj Is mHandler And Not bstack.lastobj Is Nothing Then Set bstack.lastobj = usehandler Set usehandler = Nothing End If If MyIsObject(r) Then r = 0# Exit Function ElseIf IsobjArray(bstack.lastobj) Then Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = bstack.lastobj Set bstack.lastobj = Nothing IsNumberNew = fMatrix(bstack, a$, usehandler, r) If Left$(a$, 1) = "." And Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then GoTo cont100203030 End If If MyIsObject(r) Then r = 0# Exit Function End If Exit Function End If SyntaxError IsNumberNew = False Exit Function End If End If Exit Function End If On Error Resume Next If TypeOf ppppl Is iBoxArray Then If ppppl.ItemTypeNum(w2) = vbUserDefinedType Then If FastSymbol(a$, "|") Then w1 = FastPureLabel(a$, s$) r = Empty IsNumberNew = False If w1 > 0 Then If w1 = 1 Then r = ppppl.GetUDTValue(w2, s$) ElseIf w1 = 5 Then If IsExp(bstack, a$, p, , True) Then If FastSymbol(a$, ")") Then r = ppppl.GetUDTValue(w2, s$, p) End If End If End If If MemInt(VarPtr(r)) = vbEmpty Then If LastErNum = 0 Then BadUDTName Exit Function End If Else SyntaxError End If Else r = ppppl.itemnumeric(w2) End If Else r = ppppl.itemnumeric(w2) End If If MyIsObject(r) Then Set bstack.lastobj = r Set r = Nothing r = 0 End If If Err Then r = 0: Err.Clear On Error GoTo 0 Else r = 0 End If IsNumberNew = True Else contrightpar: If Typename(ppppl.GroupRef) = mHdlr Then Set usehandler = ppppl.GroupRef If IsExp(bstack, a$, p, flatobject:=True) Then If usehandler.t1 = 2 Then ' OK for Buffer If MemInt(VarPtr(p)) = vbString Then ' no good goto this GoTo syntax1 End If With usehandler.objref If FastSymbol(a$, "!") Then r = .GetBytePtr(p) Else If FastSymbol(a$, ",") Then If IsStrExp(bstack, a$, s$) Then ElseIf LastErNum1 Then Exit Function ElseIf FastPureLabel(a$, s$, , True) <> 1 Then syntax1: SyntaxError Exit Function End If If .structref.Find(s$) Then If FastSymbol(a$, ",") Then If IsExp(bstack, a$, r) Then r = .GetPtr(p) + .structref.Value + r Else GoTo syntax1 End If Else r = .GetPtr(p) + .structref.Value End If If FastSymbol(a$, "!") Then r = r - .GetPtr(0) Else End If Else GoTo syntax1 End If Else r = .GetPtr(p) End If End If If .status = 4 Then MyErMacro a$, "Buffer locked, wrong use of pointer", "Η Διάρθρωση κλειδώθηκε, κακή χρήση δείκτη" IsNumberNew = FastSymbol(a$, ")") And .status = 0 End With Exit Function ElseIf usehandler.t1 = 3 Then Set bstack.lastobj = Nothing Set anything = usehandler If CheckLastHandler(anything) Then Set usehandler = anything If TypeOf usehandler.objref Is iBoxArray Then Set ppppl = usehandler.objref Set usehandler = Nothing w2 = CLng(p) If ppppl.Count > w2 And w2 >= 0 Then ppppl.index = w2 If MyIsObject(ppppl.Value) Then FastSymbol a$, ")" GoTo contAr22 Else r = ppppl.itemnumeric(w2) GoTo finishnum End If Else indexout a$ End If Else SyntaxError End If Set usehandler = Nothing Else MyEr "???", "???" End If Exit Function End If Set bstack.lastobj = Nothing If VarType(p) = vbBoolean Then p = CLng(p) If Not FastSymbol(a$, "!") Then If CheckInt64(p) Then s$ = CStr(p) ElseIf VarType(p) = vbString Then SwapString2Variant s$, p Else s$ = LTrim$(str(p)) End If GoTo contlabel End If If TypeOf usehandler.objref Is mHandler Then Set usehandler = usehandler.objref If usehandler.indirect = -1 Then Set anything = usehandler.objref Set usehandler = New mHandler Set ppppl.GroupRef = usehandler Set usehandler.objref = anything Set anything = Nothing Set bstack.lastobj = Nothing End If End If With usehandler.objref p = MyRound(p) If Abs(p) < .Count Then If p < 0 Then .index = .Count + MyRound(p) Else .index = MyRound(p) End If .Done = True '' what??? here here here IsNumberNew = FastSymbol(a$, ")") If Left$(a$, 1) = "." Then If Fast2NoSpace(a$, ".ΑΞΙΑ", 5, ".VALUE", 6, 6) Then w2 = -100 Else w2 = -MyRound(p) - 100 End If GoTo contgroup ElseIf FastSymbol(a$, "(") Then If .IsObj Then If TypeOf .ValueObj Is mHandler Then Set ppppl.GroupRef = .ValueObj w3 = 0 GoTo contAr2 ElseIf TypeOf .ValueObj Is Group Then Set ppppl.GroupRef = .ValueObj w2 = -2 GoTo contgroup End If w2 = -.index - 100 If TypeOf .ValueObj Is lambda Then GoTo contlambdahere If TypeOf .ValueObj Is iBoxArray Then Set ppppl = .ValueObj w3 = 0 GoTo contAr2 End If Else MissObject a$ End If End If If Not .IsObj Then If usehandler.t1 = 5 Then r = .Value ElseIf .ValueType(0, r, s$) Then Else r = 0 End If Else Set bstack.lastobj = usehandler.objref.ValueObj r = 0 End If Exit Function Else indexout a$ End If End With Exit Function ElseIf IsStrExp(bstack, a$, s$) Then w3 = 0 contlabel: Set usehandler = ppppl.GroupRef If usehandler.t1 = 1 Then If Typename(usehandler.objref) <> "FastCollection" Then If usehandler.indirect = -1 Then Set usehandler = usehandler.objref Set useFast = usehandler.objref Set usehandler = ppppl.GroupRef Set usehandler.objref = useFast Else GoTo inv100 End If Else Set useFast = usehandler.objref End If ElseIf usehandler.t1 = 5 Then If Typename(usehandler.objref) <> "StructCollection" Then If usehandler.indirect = -1 Then Set useFast2 = usehandler.objref s$ = myUcase(s$) Set usehandler = ppppl.GroupRef Set usehandler.objref = useFast2 ccontagainFast2: With useFast2 If .Find(s$) Then IsNumberNew = FastSymbol(a$, ")") r = .Value End If End With Exit Function Else GoTo inv100 End If Else Set useFast2 = usehandler.objref GoTo ccontagainFast2 End If Else inv100: If usehandler.t1 = 1 Then Expected "Inventory", "Κατάσταση" Else Expected "Structure", "Δομή" End If Exit Function End If With useFast If .Find(s$) Then IsNumberNew = FastSymbol(a$, ")") If Left$(a$, 1) = "." Then w2 = -.index - 100 GoTo contgroup ElseIf Left$(a$, 1) = "(" Then Mid$(a$, 1, 1) = " " If .IsObj Then w2 = -.index - 100 If TypeOf .ValueObj Is lambda Then GoTo contlambdahere2 If TypeOf .ValueObj Is iBoxArray Then Set ppppl = .ValueObj w3 = 0 GoTo contAr2 ElseIf TypeOf .ValueObj Is mHandler Then Set usehandler = .ValueObj If usehandler.t1 = 3 Then Set ppppl = usehandler.objref Else Set ppppl.GroupRef = usehandler End If w3 = 0 GoTo contAr2 End If Else MissObject a$ End If End If If Not .IsObj Then r = s$ If Not .ValueType(0, r, s$) Then r = 0 ElseIf Left$(a$, 1) = "|" Then SwapVariant p, r GoTo contUDT1 End If Else If Typename(.ValueObj) = mGroup Then Set userGroup = .ValueObj If userGroup.HasValue Then w2 = -.index - 100 GoTo contgroup Else r = 0 Set bstack.lastobj = userGroup Exit Function End If ElseIf Left$(a$, 2) = "=>" Then Set anything = .ValueObj If Not anything Is Nothing Then If TypeOf anything Is mHandler Then Set usehandler = anything GoTo GetObjFromHandler Else GoTo com123cont End If End If WrongObject Exit Function Else r = rValue(bstack, .ValueObj) If FastSymbol1(a$, "#") Then If Not bstack.lastobj Is Nothing Then If Typename(bstack.lastobj) = mHdlr Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing IsNumberNew = fMatrix(bstack, a$, usehandler, r) If MyIsObject(r) Then r = 0# Exit Function End If End If SyntaxError IsNumberNew = False Exit Function End If End If End If Exit Function Else indexout a$ End If End With Exit Function End If ElseIf Typename(ppppl.GroupRef) = mGroup Then conthere102030: Set userGroup = ppppl.GroupRef If Len(v$) > Len(userGroup.GroupName) Then If Len(ppppl.CodeName) = 0 Then s1$ = Left$(v$, Len(v$) - 1) + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" Else s1$ = ppppl.CodeName + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" End If Else s1$ = userGroup.GroupName + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" End If If GetSub(s1$, V1&) Then Set nbstack = New basetask Set nbstack.Parent = bstack If bstack.IamThread Then Set nbstack.Process = bstack.Process Set nbstack.Owner = bstack.Owner nbstack.OriginalCode = V1& nbstack.UseGroupname = sbf(V1&).sbgroup nbstack.tpointer = sbf(V1&).tpointer nbstack.SetV If GoFunc(nbstack, s1$, a$, p) Then If Not nbstack.StaticCollection Is Nothing Then bstack.Parent.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If IsNumberNew = True If IsOperator(a$, "(") Then contgrouppar: Set ppppl = New ppppLight If Typename(bstack.lastobj) = mGroup Then If bstack.lastobj.IamApointer Then Set ppppl.GroupRef = bstack.lastobj.link Else Set ppppl.GroupRef = bstack.lastobj End If Set bstack.lastpointer = Nothing Set bstack.lastobj = Nothing Else Set ppppl.GroupRef = bstack.lastobj End If ppppl.arr = False w2 = -2 Set nbstack = Nothing v$ = vbNullString GoTo contrightpar ElseIf Left$(a$, 1) = "." Then Set ppppl = New ppppLight If bstack.lastobj.IamApointer Then Set ppppl.GroupRef = bstack.lastobj.link Else Set ppppl.GroupRef = bstack.lastobj End If Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing ppppl.arr = False w2 = -2 Set nbstack = Nothing v$ = vbNullString GoTo contgroup ElseIf Left$(a$, 1) = "|" Then GoTo contUDT1 ElseIf FastSymbol1(a$, "#") Then Set nbstack = Nothing GoTo comehere End If Set nbstack = Nothing r = p IsNumberNew = True Else IsNumberNew = False End If Else If VarTypeName(var(VR)) = mGroup Then Set userGroup = var(VR) If userGroup.HasStrValue Then r = 0 Set bstack.lastobj = CopyGroupObj(var(VR)) Else r = 0 InternalError IsNumberNew = False End If Else r = 0 InternalError IsNumberNew = False End If End If Exit Function Else contreadprop: If TypeOf ppppl.GroupRef Is PropReference Then contreadprop2: Set UseProp = ppppl.GroupRef If lookOne(a$, ")") Then ' this is a function GoTo contreadprop3 ElseIf getindexes(bstack, UseProp, a$) Then Set bstack.lastobj = ppppl Else contreadprop3: Set bstack.lastobj = Nothing If Left$(a$, 2) = ")^" Then Mid$(a$, 1, 2) = ") " Set bstack.lastobj = UseProp.ValueObj r = 0 ElseIf Left$(a$, 3) = ")=>" Then Mid$(a$, 1, 3) = " " Set anything = UseProp.ValueObj If IsLabelObj(a$, n$) Then dd = FindDISPIDExt(anything, n$) Set UseProp = New PropReference UseProp.ConstructObj anything, dd, True GoTo contBigjob Else SyntaxError Exit Function End If Else r = UseProp.Value If UseProp.LastHasObject Then Set bstack.lastobj = UseProp.lastobj UseProp.clearlastobject End If End If End If If Not bstack.lastobj Is Nothing Then r = 0 GoTo finishnum End If End If If TypeOf ppppl.GroupRef Is mHandler Then MyEr "Not for this kind of object", "Όχι για αυτό το αντικείμενο" r = 0 Exit Function Else Set UseProp = ppppl.GroupRef r = UseProp.Value Set bstack.lastobj = UseProp.lastobj If Not MyIsNumeric(r) Then If VarType(r) = 8 Then If Len(r) = 0 Then r = 0 Else r = val(r) Else r = 0# End If End If finishnum: End If IsNumberNew = FastSymbol(a$, ")") If IsGroup(bstack.lastobj) Then If lookOne(a$, ".") Then Mid$(a$, 1, 1) = "#" Set anything = bstack.lastobj GoTo jumpgroup001 ElseIf Left$(a$, 2) = "=>" Then If bstack.lastobj.IamApointer Then Set ppppl = BoxGroupVar(bstack.lastobj) Mid$(a$, 1, 2) = "." + Chr(3) IsNumberNew = SpeedGroup(bstack, ppppl, "VAL", "", a$, (0)) = 1 r = bstack.LastValue Else Mid$(a$, 1, 2) = Chr$(7) + "." GoTo again1001 End If End If Else If Left$(a$, 1) = "|" Then SwapVariant p, r GoTo contUDT1 ElseIf FastSymbol1(a$, "#") Then GoTo comehere End If End If End If Exit Function Else skiperror: IsNumberNew = False If FindNameForGroup(bstack, v$) Then UnknownMethod1 a$, v$ Else If Len(v$) > 5 Then If Left$(v$, 5) = "THIS." Or Left$(v$, 5) = "ΑΥΤΟ." Then v$ = Mid$(v$, 5) V1& = IsLabel(bstack, (v$), v$) s1$ = vbNullString If v$ <> "" Then IsNumberNew = True: GoTo contthis1 End If End If If Len(here$) > 0 Then subHash.ItemCreator here$ + "." + v$ + ")", -1, True s1$ = s$ s$ = v$ GoTo isasub End If UnknownFunction1 a$, v$ End If Exit Function End If Case 105 isasub: If CurrentStackSize > stacksize Then MyEr "Function's Stack is Full - 15", "Η στοίβα των συναρτήσεων έχει γεμίσει - 15" MOUT = True IsNumberNew = False: Exit Function End If PushStage bstack, False w1 = bstack.soros.Total If Not PushParamSUB(bstack, a$) Then w1 = bstack.soros.Total - w1 PopStage bstack If w1 > 0 Then bstack.soros.drop w1 IsNumberNew = False: Exit Function End If If FastSymbol(a$, ")") Then V1& = bstack.OriginalCode w2 = V1& v$ = bstack.originalname$ bstack.originalname$ = s1$ If gr Then s1$ = "ΣΥΝΑΡΤΗΣΗ " + s1$ Else s1$ = "FUNCTION " + s1$ End If If searchsub(0&, V1&, s1$, w1, V1&, n$, True) Then againsub: If Len(s1$) > 0 Then If Not MyRead7(bstack, s1$, 1) Then bstack.originalname$ = v$ PopStage bstack IsNumberNew = False Exit Function End If End If bstack.FuncValue = r Set bstack.FuncObj = Nothing dn = bstack.addlen bstack.RetStack.PushVal CDec(0) If trace Then s1$ = TestShowSub: sg1 = TestShowBypass If V1& > 0 Then bstack.addlen = Len(sbf(V1&).sb) - w1 - Len(n$) + 1 TestShowSub = sbf(V1&).sb ElseIf V1& = 0 Then bstack.addlen = 0 TestShowSub = n$ Else bstack.addlen = Len(var(-V1&).Code) - w1 - Len(n$) + 1 TestShowSub = var(-V1&).Code End If w1 = w1 + Len(n$) TestShowBypass = True dd = 1 Module10.executeblock dd, bstack, n$, False, True, , True SwapStrings s1$, TestShowSub: TestShowBypass = sg1 Else w1 = w1 + Len(n$) dd = 1 Module10.executeblock dd, bstack, n$, False, True, , True End If bstack.RetStackDrop 1 bstack.addlen = dn If dd > 0 Then IsNumberNew = True Set bstack.lastobj = bstack.FuncObj Set bstack.FuncObj = Nothing r = bstack.FuncValue bstack.FuncValue = Empty If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then If FastSymbol1(a$, "#") Then GoTo comehere End If ElseIf TypeOf bstack.lastobj Is Group Then Set userGroup = bstack.lastobj If Left$(a$, 2) = "=>" Then If userGroup.IamApointer Then Mid$(a$, 1, 2) = "." + Chr(3) 'Chr$(7) + "." Else Mid$(a$, 1, 2) = Chr$(7) + "." End If GoTo again1001 ElseIf Left$(a$, 1) = "#" Then If Not (userGroup.HasValue And Not userGroup.HasParameters) Then Mid$(a$, 1, 1) = "." End If GoTo again1001 End If ElseIf TypeOf bstack.lastobj Is iBoxArray Then If FastSymbol1(a$, "#") Then GoTo comehere End If ElseIf Left$(a$, 1) = "#" Then If Len(a$) > 0 Then Mid$(a$, 1, 1) = Chr$(1) End If GoTo comehere End If If Left$(a$, 1) = "(" Then If TypeOf bstack.lastobj Is lambda Then FastSymbol a$, "(" If Not CallLambdaASAP(bstack, a$, r) Then IsNumberNew = False: Exit Function End If End If End If Else PopStage bstack IsNumberNew = False If bstack.ErrorOriginal = 0 Then LastErNum = -1 LastErNum1 = -1 bstack.ErrorOriginal = V1& If V1& > 0 Then a$ = n$ + space$(Len(sbf(V1&).sb) - w1 + 1) ElseIf V1& = 0 Then a$ = n$ Else a$ = n$ + space$(Len(var(-V1&).Code) - w1 + 1) End If End If Exit Function End If ElseIf bstack.IamChild Then w3 = FindPrevOriginal(bstack) If searchsub(w2, w3, s1$, w1, V1&, n$, True) Then If w3 <> V1& And V1& < 0 Then V1& = w3 End If GoTo againsub Else If subHash.Count > 0 Then If Len(s$) > 0 Then subHash.ReadVar subHash.Count - 1, v$, dn If here$ + "." + s$ + ")" = v$ Then UnknownFunction1 a$, s$ + ")" Exit Function End If End If End If s1$ = myUcase(s1$, True) GoTo nofun1 End If Else nofun1: MyEr "Function @" + Mid$(s1$, InStr(s1$, " ") + 1) + ") not found", "Η συνάρτηση @" + Mid$(s1$, InStr(s1$, " ") + 1) + ") δεν βρέθηκε" IsNumberNew = False End If bstack.originalname$ = v$ PopStage bstack Else IsNumberNew = False End If Exit Function Case 3 IsNumberNew = False bstack.tmpstr = v$ + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) Exit Function End Select '' THESE THREE STATEMENDS NOT USED ANY MORE IsNumberNew = False a$ = v$ + a$ Exit Function ''End Select zerohere: End Function Function ValidNumberOnlyMatrix(a$, r As Variant, skipdec As Boolean) As Boolean r = Empty Dim i As Long If Not IsNumberOnly(a$, 1, r, i, , True) Then If Fast3NoSpace(a$, "ΑΛΗΘΕΣ", 6, "ΑΛΗΘΗΣ", 6, "TRUE", 4, 6) Then i = MyTrimL(a$) r = CBool(True) ValidNumberOnlyMatrix = i > Len(a$) ElseIf Fast3NoSpace(a$, "ΨΕΥΔΕΣ", 6, "ΨΕΥΔΗΣ", 6, "FALSE", 5, 6) Then r = CBool(False) ValidNumberOnlyMatrix = i > Len(a$) Else r = 0 End If Else ValidNumberOnlyMatrix = i > Len(a$) End If End Function Private Sub MyDoEventsNoThread() On Error GoTo there If TaskMaster Is Nothing Then DoEvents Exit Sub Else If Not TaskMaster.Processing And TaskMaster.QueueCount = 0 Then MusicMaster.StopProcess MusicMaster.TimerTickNow DoEvents MusicMaster.StartProcess Exit Sub Else If MusicMaster.PlayMusic Then MusicMaster.TimerTickNow End If MusicMaster.StopProcess TaskMaster.StopProcess DoEvents TaskMaster.StartProcess MusicMaster.StartProcess End If End If Exit Sub there: If Not TaskMaster Is Nothing Then TaskMaster.RestEnd1 End Sub Function ProcLambda(bstack As basetask, rest$, Lang As Long) As Object ' no named functio- object Dim Body As New lambda, k As Long, n$, dummy As Variant, er As Boolean, pos1 As Long, p As Variant, s$ Dim pppp As iBoxArray, pppp2 As iBoxArray, frm$, Find As basetask, rest1$ Dim ppppl As iBoxArray, ar As refArray, usehandler As mHandler ' need fixed param...with & again1: ClearStr rest$ Do While MaybeIsSymbol(rest$, "/\'"): SetNextLine rest$: ClearStr rest$: Loop If Not FastSymbol(rest$, "->", , 2) Then ' put here description for error If er Then Exit Function Do If Len(rest$) < 129 Then k = IsPureLabel(rest$, n$) Else rest1$ = Left$(rest$, 128) k = IsPureLabel(rest1$, n$) If Len(rest1$) = 0 Then k = IsPureLabel(rest$, n$) Else rest$ = Mid$(rest$, 129 - Len(rest1$)) End If End If If k = 0 Then If frm$ <> "" Then Exit Function If FastSymbol(rest$, "(") Then er = True frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ FastSymbol rest$, ")" frm$ = Trim$(frm$) GoTo again1 Else MyEr "Symbol -> for Lambda needed", "Χρειάζεται το σύμβολο -> για την λάμδα συνάρτηση" Exit Function End If End If If k > 4 Then If Not FastSymbol(rest$, ")") Then Exit Function n$ = myUcase(n$, True) If FastSymbol(rest$, "=") Then Select Case k Case 1 If IsExp(bstack, rest$, p) Then If Not bstack.lastobj Is Nothing Then Set dummy = bstack.lastobj Set bstack.lastobj = Nothing Body.FeedNonLocal n$, dummy, False, var() Set dummy = Nothing Else dummy = p Body.FeedNonLocal n$, dummy, False, var() End If dummy = Empty ElseIf IsStrExp(bstack, rest$, s$, False) Then dummy = s$ Body.FeedNonLocal n$, dummy, False, var() dummy = Empty End If Case 4 If IsExp(bstack, rest$, p, flatobject:=True, nostring:=True) Then dummy = MyRound(p) Body.FeedNonLocal n$, dummy, False, var() dummy = Empty End If Case 3 If IsStrExp(bstack, rest$, s$, False) Then If Not bstack.lastobj Is Nothing Then Set dummy = bstack.lastobj Set bstack.lastobj = Nothing Body.FeedNonLocal n$, dummy, False, var() Set dummy = Nothing Else dummy = s$ Body.FeedNonLocal n$, dummy, False, var() End If dummy = Empty End If Case 5, 7 If IsExp(bstack, rest$, p) Then again11: If IsobjmArray(bstack.lastobj) Then Set pppp = bstack.lastobj Set pppp2 = New mArray pppp.CopyArray pppp2 Set dummy = pppp2 Set pppp2 = Nothing Set pppp = Nothing Body.FeedNonLocal n$, dummy, False, var() ElseIf IsobjTuple(bstack.lastobj) Then Set pppp = bstack.lastobj Set pppp2 = New mArray pppp.CopyArray pppp2 Set dummy = pppp2 Set pppp2 = Nothing Set pppp = Nothing Body.FeedNonLocal n$, dummy, False, var() ElseIf IsObjmHandler(bstack.lastobj) Then Set usehandler = bstack.lastobj If usehandler.t1 = 3 Then Set bstack.lastobj = usehandler.objref GoTo again11 Else WrongObject Exit Function End If Else Exit Function End If Else Exit Function End If Case 6 If IsStrExp(bstack, rest$, s$) Then again22: If IsobjmArray(bstack.lastobj) Then Set pppp = bstack.lastobj pppp.arrname = n$ Set dummy = pppp Body.FeedNonLocal n$, dummy, False, var() Set dummy = Nothing Set pppp = Nothing ElseIf IsobjTuple(bstack.lastobj) Then Set pppp = bstack.lastobj pppp.arrname = n$ Set dummy = pppp Body.FeedNonLocal n$, dummy, False, var() Set dummy = Nothing Set pppp = Nothing ElseIf IsObjmHandler(bstack.lastobj) Then Set usehandler = bstack.lastobj If usehandler.t1 = 3 Then Set bstack.lastobj = usehandler.objref GoTo again22 Else WrongObject Exit Function End If Else Exit Function End If 'Else ' Exit Function 'End If Else Exit Function End If Case 8 GoTo ER122 End Select ElseIf k < 5 Then Dim novariant As Boolean If GetVar(bstack, n$, pos1, , , True, , novariant) Then If VarTypeName(var(pos1)) = "lambda" Then Dim aaa As lambda var(pos1).CopyTo aaa, var() Set dummy = aaa Body.FeedNonLocal n$, dummy, Not novariant, var() Set dummy = Nothing dummy = Empty Set aaa = Nothing ElseIf VarTypeName(var(pos1)) = mGroup Then Set dummy = CopyGroupObj(var(pos1)) Body.FeedNonLocal n$, dummy, Not novariant, var() Set bstack.lastobj = dummy ' why Set dummy = Nothing ElseIf VarTypeName(var(pos1)) = "RefArray" Then Set ar = var(pos1) Set dummy = ar.Copy() Body.FeedNonLocal n$, dummy, Not novariant, var() Set bstack.lastobj = dummy Set dummy = Nothing Else Body.FeedNonLocal n$, var(pos1), Not novariant, var() End If Else If Right$(n$, 1) = "$" Then skiperror = True If Not IsStr1(bstack, (n$), s$) Then MyEr "", "" dummy = vbNullString Else dummy = s$ End If skiperror = False Else skiperror = True If Not IsNumberNew(bstack, (n$), dummy, True) Then dummy = Empty End If skiperror = False End If Body.FeedNonLocal n$, dummy, False, var() dummy = Empty End If ElseIf k < 8 Then If neoGetArray(bstack, n$, ppppl) Then If TypeOf ppppl Is mArray Then Set pppp = ppppl Set pppp2 = New mArray pppp.CopyArray pppp2 Set dummy = pppp2 Set pppp2 = Nothing Set pppp = Nothing Body.FeedNonLocal n$, dummy, False, var() ElseIf TypeOf ppppl Is tuple Then Set pppp = ppppl Set pppp2 = New tuple pppp.CopyArray pppp2 Set dummy = pppp2 Set pppp2 = Nothing Set pppp = Nothing Body.FeedNonLocal n$, dummy, False, var() Else MyEr "not an array " + n$, "δεν είνα πίνακας " + n$ Exit Function End If Else MyEr "Array not exist", "Δεν υπάρχει πίνακας" Exit Function End If Else ER122: MyEr "Pass array without []", "Δώσε πίνακα χωρίς []" Exit Function End If If Not FastSymbol(rest$, ",") Then Exit Do ClearStr rest$ Do While MaybeIsSymbol(rest$, "/\'"): SetNextLine rest$: ClearStr rest$: Loop Loop If frm$ <> "" Then Exit Function ClearStr rest$ Do While MaybeIsSymbol(rest$, "/\'"): SetNextLine rest$: ClearStr rest$: Loop If FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then frm$ = Trim$(frm$) GoTo again1 End If End If er = True GoTo again1 ElseIf FastSymbol(rest$, "{") Then ' get block getfunc: If frm$ <> "" Then ' If Lang = 1 Then frm$ = neoReadEng + frm$ + vbCrLf ' Else ' frm$ = neoReadGr + frm$ + vbCrLf ' End If Body.Code = frm$ + vbCrLf + block(rest$) Else Body.Code = block(rest$) End If If Trim$(Body.Code) = vbNullString Then Exit Function If Not FastSymbol(rest$, "}") Then Exit Function k = Len(rest$) Else GetLine: ' get one line only pos1 = 1 Body.Code = aheadstatus(rest$, False, pos1) If pos1 = 1 Then Exit Function If frm$ <> "" Then ' If Lang = 1 Then ' check for NEW frm$ = neoReadEng + frm$ + vbCrLf ' Else ' check for ΝΕΟ ' frm$ = neoReadGr + frm$ + vbCrLf ' End If Body.Code = frm$ + ": =" + Left$(rest$, pos1 - 1) Else Body.Code = "=" + Left$(rest$, pos1 - 1) End If k = Len(rest$) rest$ = Mid$(rest$, pos1) End If If bstack.OriginalCode < 0 Then Set Find = bstack Do While Find.IamChild If Find.OriginalCode > -1 Then Exit Do If TypeOf var(-Find.OriginalCode) Is Constant Then Set p = var(-Find.OriginalCode).Value k = k + p.lastlen Body.OriginalCode = p.OriginalCode Else k = k + var(-Find.OriginalCode).lastlen Body.OriginalCode = var(-Find.OriginalCode).OriginalCode End If Set Find = Find.Parent Loop Body.lastlen = k Else If Not bstack.Parent Is Nothing Then ' Left$(sbf(bstack.OriginalCode).sb, 10) = "'11001EDIT" Set Find = bstack While Not Find Is Nothing If Find.OriginalCode < 0 Then If TypeOf var(-Find.OriginalCode) Is Constant Then Set p = var(-Find.OriginalCode).Value k = k + p.lastlen Body.OriginalCode = p.OriginalCode Else k = k + var(-Find.OriginalCode).lastlen Body.OriginalCode = var(-Find.OriginalCode).OriginalCode End If Set Find = Find.Parent ElseIf Left$(sbf(Find.OriginalCode).sb, 10) = "'11001EDIT" Then frm$ = Mid$(sbf(Find.OriginalCode).sb, 1, InStr(sbf(Find.OriginalCode).sb, vbCr)) k = k - val(Mid$(frm$, InStr(frm$, ",") + 1)) Body.OriginalCode = iRVAL(Find.originalname, 0) Set Find = Find.Parent Else Body.OriginalCode = iRVAL(Find.originalname, 0) Set Find = Nothing End If Wend If Body.OriginalCode = 0 Then Body.OriginalCode = bstack.OriginalCode Body.lastlen = k Else If Left$(sbf(bstack.OriginalCode).sb, 10) = "'11001EDIT" Then frm$ = Mid$(sbf(bstack.OriginalCode).sb, 1, InStr(sbf(bstack.OriginalCode).sb, vbCr)) k = k - val(Mid$(frm$, InStr(frm$, ",") + 1)) Body.OriginalCode = iRVAL(bstack.originalname, 0) If Body.OriginalCode = 0 Then IsLabelOnly Mid$(frm$, 11), frm$ If subHash.Find(frm$, pos1) Then Body.OriginalCode = pos1 End If End If Else Body.OriginalCode = bstack.OriginalCode End If Body.lastlen = k End If End If Set ProcLambda = Body End Function Function IsLabelBig(bstack As basetask, a$, rrr$, Optional nocommand As Boolean, Optional r$, Optional noconvert As Boolean = False, Optional StrPointer As Boolean, Optional iscommand As Boolean, Optional fixlen As Boolean, Optional gr As Boolean) As Long Dim rr&, one As Boolean, br As Integer, c$, dot&, skipcase As Boolean, cc As Long, isstrparam As Boolean, ascwc As Integer Dim i As Long Dim p, s$ Dim P1, s1$ Dim pppp As iBoxArray, a1$, w2 As Long r$ = vbNullString gr = False If a$ = vbNullString Then IsLabelBig = 0: Exit Function 'ok a$ = NLtrim$(a$) If Left$(a$, 1) = "&" Then ' a$ = Mid$(a$, 2) If Len(r$) > 0 Then 'ERROR rr& = 0 '' r$ = VbNullString rrr$ = vbNullString Exit Function Else nocommand = True If noconvert Then IsLabelBig = 0 Exit Function Else a$ = Mid$(a$, 2) varhash.flat rr& = Abs(IsLabelBig(bstack, a$, r$, , c$)) If rr& < 5 And varhash.lastNDX > 0 Then i = varhash.lastNDX usethat: r$ = varhash.lastkey If MyIsObject(var(i)) Then If var(i) Is Nothing Then ElseIf TypeOf var(i) Is Group Then If Len(var(i).LastOpen) > 0 Then c$ = var(i).LastOpen If GetlocalVar(c$, i) Then If IsBadCodePtr(var(i).PointerPtr) = 0 Then c$ = r$ End If End If End If End If End If rrr$ = r$ IsLabelBig = -50 Exit Function End If End If skipcase = True If rr& < 5 Then c$ = myUcase(c$, True) again2134: If GetlocalVar(r$, i) Then bypass1: If MyIsObject(var(i)) Then If var(i) Is Nothing Then ElseIf TypeOf var(i) Is Group Then If Len(var(i).LastOpen) > 0 Then c$ = var(i).LastOpen If GetlocalVar(c$, i) Then If IsBadCodePtr(var(i).PointerPtr) = 0 Then c$ = r$ End If End If End If End If End If rrr$ = here$ + "." + r$ IsLabelBig = -50 Exit Function ElseIf bstack.ExistVar2(c$) Then r$ = c$ If Not bstack.modfuncall Then abnormal_exit: MyEr "only for module or function call", "μόνο σε κλήση για τμήμα ή συνάρτηση" IsLabelBig = 0 Exit Function End If c$ = "_" + str$(var2used) If rr& = 6 Then If Not IsStr1(bstack, (r$), s$) Then GoTo cont123 If bstack.lastobj Is Nothing Then rr& = globalvarGroup(c$, s$) Else Set p = bstack.lastobj Set bstack.lastobj = Nothing rr& = globalvarGroup(c$, p) End If Else If Not IsNumber(bstack, (r$), p) Then GoTo cont123 End If If bstack.lastobj Is Nothing Then rr& = globalvarGroup(c$, p, useType:=Not varhash.index < 0) Else Set p = bstack.lastobj Set bstack.lastobj = Nothing rr& = globalvarGroup(c$, p) End If End If ' to tempcopy FeedCopyInOut bstack, r$, rr&, "" ' parent If here$ <> "" Then r$ = here$ + "." + c$ Else r$ = c$ rr& = 2 GoTo skiploop ElseIf Left$(r$, 5) = "ΑΥΤΟ." Or Left$(r$, 5) = "THIS." Then If Len(bstack.UseGroupname) > 0 Then c$ = bstack.UseGroupname + Mid$(r$, 6) Else c$ = StripThis2(here$) If c$ <> "" Then c$ = c$ + "." + Mid$(r$, 6) Else c$ = here$ + "." + r$ End If rrr$ = c$ IsLabelBig = -50 Exit Function ElseIf varhash.Find(r$, cc) Then rrr$ = r$ IsLabelBig = -50 Exit Function Else If r$ = "THIS" Or r$ = "ΑΥΤΟ" Then rrr$ = r$ IsLabelBig = -100 Exit Function Else c$ = ChrW(-65) + myUcase(c$, True) If varhash.Find2(bstack.UseGroupname + c$, i) Then GoTo usethat End If If GetSub(r$ + ")", rr&) Then r$ = "{" + sbf(rr&).sb + "} " + sbf(rr&).sbgroup rr& = 2 GoTo skiploop Else If Not bstack.NoError Then If r$ <> "" Then MyErMacro a$, "can't pass reference to " + r$, "δεν μπορώ να βάλω αναφορά στο " + r$ End If SyntaxError End If GoTo skiploop End If End If End If Else If FastSymbol(a$, ")") Then rr& = 0 If Left$(r$, 5) = "ΑΥΤΟ." Or Left$(r$, 5) = "THIS." Then If varhash.ExistKey(bstack.UseGroupname + Mid$(r$, 6)) Then rrr$ = bstack.UseGroupname + Mid$(r$, 6, Len(r$) - 5) IsLabelBig = -50 Exit Function Else If varhash.ExistKey(bstack.UseGroupname + ChrW(-65) + Mid$(r$, 6)) Then rrr$ = bstack.UseGroupname + ChrW(-65) + Mid$(r$, 6, Len(r$) - 5) IsLabelBig = -50 Exit Function End If rr& = 2 End If ElseIf varhash.ExistKey(here$ + "." + r$) Then rrr$ = here$ + "." + r$ IsLabelBig = -50 Exit Function ElseIf varhash.ExistKey(r$) Then rrr$ = r$ IsLabelBig = -50 Exit Function Else rr& = 3 End If c$ = vbNullString If rr& > 0 Then If rr& = 2 Then If Len(bstack.UseGroupname) > 0 Then c$ = bstack.UseGroupname + ChrW(-65) + Mid$(r$, 6) r$ = bstack.UseGroupname + Mid$(r$, 6) End If End If checkc: rr& = 1 If GetSub(r$ + ")", rr&) Then If rr& = -1 Then GoTo checkc1 ElseIf sbf(rr&).Extern > 0 Then r$ = "{CALL EXTERN " & (sbf(rr&).Extern) & "'" & ChrW(&H1FFD) & "}" & sbf(rr&).sbgroup Else r$ = "{" + sbf(rr&).sb + "}" + sbf(rr&).sbgroup End If rr& = 2 GoTo skiploop Else If Len(c$) > 0 Then r$ = c$ GoTo checkc End If checkc1: If Not bstack.NoError Then MyErMacro a$, "can't pass reference", "δεν μπορώ να βάλω αναφορά" End If End If rr& = 0 r$ = vbNullString GoTo skiploop Else a1$ = r$ If GetOneAsString(bstack, a$, r$, rr&) Then If neoGetArray(bstack, a1$, pppp) Then If Not pppp.arr Then GoTo cont123 c$ = varhash.lastkey If Not NeoGetArrayItem(pppp, bstack, a1$, w2, Mid$(r$, Len(a1$) + 1)) Then GoTo cont123 If pppp.ItemType(w2) = mGroup Then If Len(pppp.item(w2).LastOpen) > 0 Then r$ = pppp.item(w2).LastOpen rr& = 2 GoTo skiploop End If End If r$ = Funcweak(bstack, c$ + Mid$(r$, Len(a1$) + 1)) a1$ = c$ If Not bstack.modfuncall Then GoTo abnormal_exit c$ = "_" + str$(var2used) If pppp.MyIsObject(pppp.item(w2)) Then If pppp.ItemType(w2) = mGroup Then If pppp.item(w2).IamApointer Then If pppp.item(w2).LastOpen <> vbNullString Then rr& = 1 r$ = pppp.item(w2).LastOpen GoTo again2134 Else rr& = globalvarGroup(c$, P1) Set var(rr&) = pppp.item(w2) End If Else r$ = "#" + r$ rr& = 2 GoTo skiploop End If Else rr& = globalvarGroup(c$, P1) Set var(rr&) = pppp.item(w2) End If Else rr& = globalvarGroup(c$, pppp.item(w2)) End If FeedCopyInOut bstack, r$, rr&, a1$ If here$ <> "" Then r$ = here$ + "." + c$ Else r$ = c$ rr& = 2 GoTo skiploop End If End If End If End If cont123: r$ = vbNullString rr& = 0 GoTo skiploop End If End If Do While Len(a$) > 0 c$ = Left$(a$, 1) 'ANYCHAR HERE ascwc = AscW(c$) Select Case ascwc Case 0 To 9 Select Case ascwc Case 8 ' If Len(r$) > 0 Then Exit Do ' get a name from bstack tempstr a$ = bstack.tmpstr + Mid$(a$, 2) fixlen = True bstack.tmpstr = vbNullString nocommand = Left$(a$, 1) <> "@" Case 2 To 7 a$ = Mid$(a$, 2) Case 1 isstrparam = True GoTo conthere1 Case 0 ' for group pointers conthere1: If LenB(r$) = 0 Then If Not bstack.lastpointer Is Nothing Then With bstack.lastpointer If .lasthere = vbNullString Then If .GroupName <> "" Then If Right$(.GroupName, 1) = "." Then If isstrparam Then r$ = Left$(.GroupName, Len(.GroupName) - 1) + "$" rr& = 3 Else r$ = Left$(.GroupName, Len(.GroupName) - 1) rr& = 1 End If Else If isstrparam Then r$ = .GroupName + "$" rr& = 3 Else r$ = .GroupName rr& = 1 End If End If Else ' why ? Exit Function End If Else If .GroupName <> "" Then If .lasthere <> here$ Then If isstrparam Then r$ = .lasthere + "." + .GroupName + "$" rr& = 3 Else r$ = .lasthere + "." + .GroupName rr& = 1 End If Else If isstrparam Then r$ = .GroupName + "$" rr& = 3 Else r$ = .GroupName rr& = 1 End If End If Else If isstrparam Then r$ = .lasthere + "$" rr& = 3 Else r$ = .lasthere rr& = 1 End If End If End If End With Set bstack.lastpointer = Nothing If Mid$(a$, 2, 1) = "." Then a$ = Mid$(a$, 2) Else If Right$(r$, 1) = "." Then r$ = Left$(r$, Len(r$) - 1) End If If Mid$(a$, 2, 2) = "$'" Then rr& = 3 a$ = Mid$(a$, 2) ElseIf Mid$(a$, 2, 1) = "'" Then a$ = Mid$(a$, 2) Else Mid$(a$, 1, 1) = "(" ' parameter for value for pointers for groups using in Eval() and Eval$() End If End If nocommand = True Else Mid$(a$, 1, 2) = "=>" Exit Function End If Else a$ = Mid$(a$, 2) End If Case Else Exit Do End Select 'elseIf ascwc < 256 And ascwc > 0 Then Case 10 To 256 Select Case ascwc Case 64 '"@" If r$ = vbNullString Then a$ = Mid$(a$, 2) iscommand = True ElseIf Mid$(a$, 2, 1) <> "(" And Len(r$) > 0 Then r$ = r$ + "." a$ = Mid$(a$, 2) Else IsLabelBig = 0: Exit Function End If Case 63 '"?" If r$ = vbNullString Then rrr$ = "?" IsLabelBig = 1 Exit Function End If a$ = Mid$(a$, 2) ' why this Case 46 '"." If one Then Exit Do ElseIf Len(r$) > 0 Then r$ = r$ + Left$(a$, 1) a$ = Mid$(a$, 2) ElseIf Not Mid$(a$, 2, 1) Like "[0-9]" Then If Len(r$) > 0 Then r$ = r$ + Left$(a$, 1) rr& = 1 Else dot& = dot& + 1 End If a$ = Mid$(a$, 2) Else If r$ = vbNullString And dot& > 0 Then nocommand = True rrr$ = String$(dot& + 1, ".") ' i want this only in right position for "dir .. " r$ = rrr$ a$ = Mid$(a$, 2) IsLabelBig = 1 Else IsLabelBig = 0 End If Exit Function End If Case 94, 123 To 126, 160 '"{" To "~", "^" Exit Do Case 48 To 57, 95 '"0" To "9", "_" ' old ,"\" If one Then Exit Do ElseIf Len(r$) > 0 Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else If dot& > 0 Then a$ = "." + a$: dot& = 0 Exit Do End If Case 91 a$ = Mid$(a$, 2) If Len(r$) > 0 Then If Len(r$) = 1 Then If r$ <> "[" Then rr& = 8 nocommand = True Exit Do End If ElseIf Right$(r$, 1) <> "." Then If Right$(r$, 1) <> ChrW(&HFFBF) Then If Left$(r$, 1) <> "[" Then rr& = 8 nocommand = True Exit Do End If End If End If br = br + 1 r$ = r$ + "[" Else r$ = "[" br = 1 rr& = 1 'is an identifier End If Case 93 If Len(r$) = 0 Then Exit Do If br > 0 Then br = br - 1 r$ = r$ + "]" a$ = Mid$(a$, 2) Else Exit Do End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 36 ' "$" If one Then Exit Do If Len(r$) > 0 Then one = True rr& = 3 ' is string variable r$ = r$ + Left$(a$, 1) a$ = Mid$(a$, 2) Else Exit Do End If Case 37 ' "%" If one Then Exit Do If Len(r$) > 0 Then one = True rr& = 4 ' is long variable r$ = r$ + Left$(a$, 1) nocommand = True a$ = Mid$(a$, 2) Else Exit Do End If Case 58 '":" If one Then Exit Do If Mid$(a$, 2, 1) <> "\" Then Exit Do If InStr(r$, ":") > 1 Then Exit Do r$ = r$ + Left$(a$, 2) a$ = Mid$(a$, 3) Case 40 ' "(" If Len(r$) > 0 Then If Mid$(a$, 2, 2) = ")@" Then r$ = r$ + "()." a$ = Mid$(a$, 4) ElseIf Mid$(a$, 2, 2) = ")." Then ' And rr& = 1 Then r$ = r$ + "()." rr& = 0 one = False a$ = Mid$(a$, 4) GoTo CONT1234 Else Select Case rr& Case 1 rr& = 5 ' float array or function Case 3 rr& = 6 'string array or function Case 4 rr& = 7 ' long array Case Else Exit Do End Select r$ = r$ + Left$(a$, 1) a$ = Mid$(a$, 2) Exit Do End If Else Exit Do End If Case Else Exit Do End Select Case Else If one Then Exit Do Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End Select CONT1234: Loop skiploop: If skipcase Then rrr$ = r$ Else rrr$ = myUcase(r$, gr) End If If dot& Then havedot: nocommand = True If Len(r$) > 0 Then rr& = bstack.GetDotNew(rrr$, dot&) * rr& nocommand = rr& Else If dot& > 1 Then rrr$ = String$(dot&, ".") + rrr$: If rr& = 0 Then rr& = 1 Else '' PUT THE DOT BACK If dot& = 1 Then a$ = "." + a$ End If End If ElseIf Len(rrr$) > 5 Then If Left$(rrr$, 1) = "Α" Then If Left$(rrr$, 5) = "ΑΥΤΟ." Then If Len(bstack.UseGroupname) > 0 Then rrr$ = bstack.UseGroupname + Mid$(rrr$, 6) Else rrr$ = Mid$(rrr$, 6) dot& = 1 GoTo havedot End If End If ElseIf Left$(rrr$, 1) = "T" Then If Left$(rrr$, 5) = "THIS." Then If Len(bstack.UseGroupname) > 0 Then rrr$ = bstack.UseGroupname + Mid$(rrr$, 6) Else rrr$ = Mid$(rrr$, 6) dot& = 1 GoTo havedot End If End If End If End If If StrPointer Then If Abs(rr&) = 3 Then cc = LastErNum1 If IsStr1(bstack, (rrr$), rrr$) Then fixlen = True a$ = rrr$ + a$ StrPointer = False IsLabelBig = Abs(IsLabelBig(bstack, a$, rrr$, , r$)) * Sgn(rr&) End If LastErNum1 = cc nocommand = True Exit Function ElseIf Abs(rr&) = 6 Then fixlen = True a$ = rrr$ + a$ cc = LastErNum1 If IsStr1(bstack, a$, rrr$) Then a$ = rrr$ + a$ IsLabelBig = Abs(IsLabelBig(bstack, a$, rrr$, , r$)) * Sgn(rr&) LastErNum1 = cc Else LastErNum1 = cc cc = InStr(rrr$, "(") If cc > 0 Then a$ = Mid$(rrr$, cc + 1) + a$ rrr$ = Left$(rrr$, cc) IsLabelBig = 4 * Sgn(rr&) Else IsLabelBig = Sgn(rr&) End If End If StrPointer = False nocommand = True Exit Function Else IsLabelBig = rr& End If Else IsLabelBig = rr& End If nocommand = IsLabelBig And (Len(r$) = 1 Or nocommand) End Function Function IsLabelFileName(bstack As basetask, a$, r$) As Long Dim rr&, one As Boolean, dot As Boolean, c$, gr As Boolean, cc As Long, p, notwopass As Boolean r$ = vbNullString If a$ = vbNullString Then IsLabelFileName = 0: Exit Function 'ok a$ = NLtrim$(a$) Do While Len(a$) > 0 c$ = Left$(a$, 1) 'ANYCHAR HERE If AscW(c$) < 256 Then Select Case AscW(c$) Case 0 To 7 a$ = Mid$(a$, 2) Case 64 '"@" If r$ = vbNullString Then a$ = Mid$(a$, 2) ElseIf Mid$(a$, 2, 1) <> "(" And r$ <> "" Then r$ = r$ + "." a$ = Mid$(a$, 2) Else IsLabelFileName = 0: Exit Function End If Case 63 '"?" If r$ = vbNullString Then r$ = "?" IsLabelFileName = 1 Exit Function End If a$ = Mid$(a$, 2) Case 58 ' ":" If one Then Exit Do ElseIf r$ <> "" Then If Len(a$) > 1 Then If Mid$(a$, 2, 1) <> "\" Then Exit Do ElseIf Mid$(a$, 2, 2) = vbCrLf Then Exit Do End If End If If InStr(r$, ":") > 0 Then IsLabelFileName = 0 Exit Function Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 End If Else IsLabelFileName = 0 Exit Function End If Case 46 ' "." If one Then Exit Do Else If r$ = vbNullString Then dot = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 94, 123 To 126, 160 '"{" To "~", "^" Exit Do Case 92 '"\" If one Then Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else Exit Do End If Case 48 To 57, 95 ' "0" To "9", "_" If one Then Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 91 If r$ = vbNullString Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else GoTo ALFA End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 38 '"&" SyntaxError rr& = 0 If Len(a$) > 0 Then Mid$(a$, 1, 1) = ":" Else a$ = ":" Case 36 '"$" If one Then Exit Do If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 37 '"%" If one Then Exit Do If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 40 '"(" If r$ <> "" Then If Mid$(a$, 2, 2) = ")@" Then r$ = r$ + "()." a$ = Mid$(a$, 4) Else notwopass = True dot = False Select Case rr& Case 3 rr& = 1 '5 ' float array or function bstack.tmpstr = r$ + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If Not IsStrExp(bstack, a$, r$, False) Then MissString rr& = 0 End If Exit Do Case 1 ALFA: rr& = 1 bstack.tmpstr = r$ + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If IsExp(bstack, a$, p, flatobject:=True, nostring:=False) Then If myVarType(p, vbString) Then SwapString2Variant r$, p Else MissString rr& = 0 End If Exit Do End If Case 4 ''rr& = 7 long array ' this is an error Case Else Exit Do End Select ' R$ = R$ + c$ ' a$ = Mid$(a$, 2) Exit Do End If Else Exit Do End If Case Else Exit Do End Select Else If one Then Exit Do Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End If Loop If rr& = 1 Then If Not notwopass Then If dot Then If Right$(r$, 1) <> "." Then GoTo 1212 End If ElseIf GetVar(bstack, myUcase(r$, True), rr&) Then 1212: bstack.tmpstr = r$ + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If IsExp(bstack, a$, p, flatobject:=True, nostring:=False) Then If myVarType(p, vbString) Then rr& = 1 SwapString2Variant r$, p Else MissString rr& = 0 End If End If End If End If ElseIf rr& = 3 Then bstack.tmpstr = r$ + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If IsStrExp(bstack, a$, r$, False) Then rr& = 1 Else MissString rr& = 0 End If End If IsLabelFileName = rr& End Function Function IsLabelNoUcase(bstack As basetask, a$, rrr$) As Long Dim buf$, fixme As Boolean, q1$ If Len(a$) < 129 Then IsLabelNoUcase = innerIsLabel(bstack, a$, rrr$, , True): Exit Function buf$ = Left$(a$, 128) q1$ = bstack.tmpstr IsLabelNoUcase = innerIsLabel(bstack, buf$, rrr$, , True, , fixme) If Len(buf$) = 0 Then If fixme Then bstack.tmpstr = q1$ IsLabelNoUcase = innerIsLabel(bstack, a$, rrr$, , True) Else If fixme Then Select Case Len(buf$) Case Is < 128 Mid$(a$, 129 - Len(buf$), Len(buf$)) = buf$ a$ = Mid$(a$, 129 - Len(buf$)) Case Is > 128 a$ = buf$ + Mid$(a$, 129) Case Else Mid$(a$, 1, 128) = buf$ End Select Else a$ = Mid$(a$, 129 - Len(buf$)) End If End If End Function Function IsLabel(bstack As basetask, a$, rrr$, Optional skipdot As Boolean) As Long Dim buf$, fixme As Boolean, q1$ If Len(a$) < 129 Then IsLabel = innerIsLabel(bstack, a$, rrr$, , , skipdot): Exit Function buf$ = Left$(a$, 128) q1$ = bstack.tmpstr IsLabel = innerIsLabel(bstack, buf$, rrr$, , , skipdot, fixme) If Len(buf$) = 0 Then If fixme Then bstack.tmpstr = q1$ IsLabel = innerIsLabel(bstack, a$, rrr$, , , skipdot) Else If fixme Then Select Case Len(buf$) Case Is < 128 Mid$(a$, 129 - Len(buf$), Len(buf$)) = buf$ a$ = Mid$(a$, 129 - Len(buf$)) Case Is > 128 a$ = buf$ + Mid$(a$, 129) Case Else Mid$(a$, 1, 128) = buf$ End Select Else a$ = Mid$(a$, 129 - Len(buf$)) End If End If End Function ' Function innerIsLabel(bstack As basetask, a$, rrr$, Optional nospace As Boolean = False, Optional skipcase As Boolean = False, Optional skipdot As Boolean, Optional fixlen As Boolean) As Long Dim rr&, one As Boolean, br As Integer, gr As Boolean, c$, dot&, r$, cc As Long 'r$ = VbNullString If a$ = vbNullString Then innerIsLabel = 0: Exit Function ' ok If Not nospace Then a$ = NLtrim$(a$) Else If AscW(a$) = 32 Then Exit Function Do While Len(a$) > 0 c$ = Left$(a$, 1) 'ANYCHAR HERE If AscW(c$) < 256 Then Select Case AscW(c$) Case 64 '"@" If r$ = vbNullString Then a$ = Mid$(a$, 2) ElseIf Mid$(a$, 2, 1) <> "(" And r$ <> "" Then r$ = r$ + "." a$ = Mid$(a$, 2) Else innerIsLabel = 0: Exit Function End If Case 63 '"?" If r$ = vbNullString Then rrr$ = "?" innerIsLabel = 1 Exit Function End If a$ = Mid$(a$, 2) Case 58 '":" If one Then Exit Do ElseIf r$ <> "" Then If Len(a$) > 1 Then If Mid$(a$, 2, 1) <> "\" Then Exit Do ElseIf Mid$(a$, 2, 2) = vbCrLf Then Exit Do End If End If If InStr(r$, ":") > 0 Then innerIsLabel = 0 Exit Function Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 End If Else innerIsLabel = 0 Exit Function End If Case 46 '"." If one Then Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) ElseIf Not Mid$(a$, 2, 1) Like "[0-9]" Then If r$ <> "" Then r$ = r$ + c$ rr& = 1 Else dot& = dot& + 1 End If a$ = Mid$(a$, 2) Else If r$ = vbNullString And dot& > 0 Then rrr$ = String$(dot& + 1, ".") ' i want this only in right position for "dir .. " r$ = rrr$ a$ = Mid$(a$, 2) innerIsLabel = 1 Else innerIsLabel = 0 End If Exit Function End If Case 94, 123 To 126, 160 '"{" To "~", "^" Exit Do Case 91 a$ = Mid$(a$, 2) If Len(r$) > 0 Then If Len(r$) = 1 Then If r$ <> "[" Then rr& = 8 Exit Do End If ElseIf Right$(r$, 1) <> "." Then If Right$(r$, 1) <> ChrW(&HFFBF) Then If Left$(r$, 1) <> "[" Then rr& = 8 Exit Do End If End If End If br = br + 1 r$ = r$ + "[" Else r$ = "[" br = 1 rr& = 1 'is an identifier End If Case 92 '"\" If one Then Exit Do ElseIf r$ <> "" Or dot& Then r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 93 If Len(r$) = 0 Then Exit Do If br > 0 Then br = br - 1 r$ = r$ + "]" a$ = Mid$(a$, 2) Else Exit Do End If Case 48 To 57, 95 '"0" To "9", "_" ' old ,"\" If one Then Exit Do If r$ <> vbNullString Then r$ = r$ + c$ a$ = Mid$(a$, 2) Else If dot& > 0 Then a$ = "." + a$: dot& = 0 Exit Do End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 Case 38 ' "&" If one Then Exit Do If r$ <> "" Then 'ERROR rr& = 0 '' r$ = VbNullString rrr$ = vbNullString innerIsLabel = 0 Exit Function Else a$ = Mid$(a$, 2) rr& = Abs(innerIsLabel(bstack, a$, r$, True)) skipcase = True If rr& < 5 Then Dim i As Long If GetlocalVar(r$, i) Then a$ = Chr(34) + here$ + "." + r$ + Chr(34) + a$ ElseIf Left$(r$, 5) = "ΑΥΤΟ." Or Left$(r$, 5) = "THIS." Then If Len(bstack.UseGroupname) > 0 Then c$ = bstack.UseGroupname + Mid$(r$, 6) Else c$ = StripThis2(here$) If c$ <> "" Then c$ = c$ + "." + Mid$(r$, 6) Else c$ = here$ + "." + r$ End If a$ = Chr(34) + c$ + Chr(34) + a$ ElseIf varhash.Find(r$, cc) Then a$ = Chr(34) + r$ + Chr(34) + a$ If r$ = "THIS" Or r$ = "ΑΥΤΟ" Then rrr$ = r$ innerIsLabel = -100 Exit Function Else If GetSub(r$ + ")", rr&) Then r$ = "{" + sbf(rr&).sb + "} " + sbf(rr&).sbgroup rr& = 2 Exit Do Else If cc > 0 Then ElseIf Not bstack.NoError Then MyErMacro a$, "can't pass reference", "δεν μπορώ να βάλω αναφορά" End If End If End If End If Else If FastSymbol(a$, ")") Then rr& = 0 If Left$(r$, 5) = "ΑΥΤΟ." Or Left$(r$, 5) = "THIS." Then If varhash.ExistKey(bstack.UseGroupname + Mid$(r$, 6)) > 0 Then a$ = Chr(34) + bstack.UseGroupname & Mid$(r$, 6, Len(r$) - 6) + Chr(34) + a$ Else rr& = 2 End If ElseIf varhash.ExistKey(here$ & "." & r$) Then a$ = Chr(34) + here$ & "." & r$ + Chr(34) + a$ ElseIf varhash.ExistKey(r$) Then a$ = Chr(34) + r$ + Chr(34) + a$ Else rr& = 3 End If If rr& > 0 Then If rr& = 2 Then If Len(bstack.UseGroupname) > 0 Then r$ = bstack.UseGroupname + Mid$(r$, 6) End If End If rr& = 1 If GetSub(r$ + ")", rr&) Then r$ = "{" + sbf(rr&).sb + "}" + sbf(rr&).sbgroup rr& = 2 Exit Do Else If Not bstack.NoError Then MyErMacro a$, "can't pass reference", "δεν μπορώ να βάλω αναφορά" End If End If rr& = 0 r$ = vbNullString Exit Do End If End If r$ = vbNullString rr& = 0 Exit Do End If Case 36 ' "$" If one Then Exit Do If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ & c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 37 ' "%" If one Then Exit Do If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ & c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 40 ' "(" If r$ <> "" Then If Mid$(a$, 2, 2) = ")@" Then r$ = r$ & "()." a$ = Mid$(a$, 4) ElseIf Mid$(a$, 2, 2) = ")." Then ' And rr& = 1 Then r$ = r$ & "()." rr& = 0 one = False a$ = Mid$(a$, 4) GoTo CONT1234 Else Select Case rr& Case 1 rr& = 5 ' float array or function Case 3 rr& = 6 'string array or function Case 4 rr& = 7 ' long array Case Else Exit Do End Select r$ = r$ & c$ a$ = Mid$(a$, 2) Exit Do End If Else Exit Do End If Case 8 ' If Len(r$) > 0 Then Exit Do a$ = bstack.tmpstr + Mid$(a$, 2) fixlen = True bstack.tmpstr = vbNullString Case Else Exit Do End Select Else If one Then Exit Do Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End If CONT1234: Loop If skipcase Then rrr$ = r$ Else rrr$ = myUcase(r$, gr) End If If dot& Then If r$ <> "" Then If skipdot And dot& = 1 Then rrr$ = "THIS." + rrr$ Else rr& = bstack.GetDotNew(rrr$, dot&) * rr& End If Else If dot& > 1 Then rrr$ = String$(dot&, ".") + rrr$: If rr& = 0 Then rr& = 1 End If End If innerIsLabel = rr& End Function Function IsLabelDIM(bstack As basetask, a$, r$) As Long Dim rr&, one As Boolean, c$, dot&, gr As Boolean, skipcase As Boolean, cc As Long r$ = vbNullString If a$ = vbNullString Then IsLabelDIM = 0: Exit Function ' ok a$ = NLtrim$(a$) Do While Len(a$) > 0 c$ = Left$(a$, 1) 'ANYCHAR HERE If AscW(c$) < 256 Then Select Case AscW(c$) Case 64 '"@" If r$ = vbNullString Then a$ = Mid$(a$, 2) ElseIf Mid$(a$, 2, 1) <> "(" And r$ <> "" Then r$ = r$ & "." a$ = Mid$(a$, 2) Else IsLabelDIM = 0: Exit Function End If Case 63 '"?" If r$ = vbNullString Then r$ = "?" IsLabelDIM = 1 Exit Function End If a$ = Mid$(a$, 2) Case 58 '":" If one Then Exit Do ElseIf r$ <> "" Then If Len(a$) > 1 Then If Mid$(a$, 2, 1) <> "\" Then Exit Do ElseIf Mid$(a$, 2, 2) = vbCrLf Then Exit Do End If End If If InStr(r$, ":") > 0 Then IsLabelDIM = 0 Exit Function Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 End If Else IsLabelDIM = 0 Exit Function End If Case 46 '"." If one Then Exit Do ElseIf r$ <> "" Then If dot& = 0 And Len(r$) = 4 Then c$ = myUcase(r$, True) If c$ = "THIS" Or c$ = "AYTO" Then r$ = vbNullString dot& = 1 Else r$ = r$ + "." End If Else r$ = r$ + "." End If a$ = Mid$(a$, 2) '' ElseIf Not Mid$(a$, 2, 1) Like "[0-9]" Then If r$ <> "" Then r$ = r$ + c$ rr& = 1 Else dot& = dot& + 1 End If a$ = Mid$(a$, 2) Else If r$ = vbNullString And dot& > 0 Then r$ = String$(dot& + 1, ".") a$ = Mid$(a$, 2) IsLabelDIM = 1 Else IsLabelDIM = 0 End If Exit Function End If Case 94, 123 To 126, 160 '"{" To "~", "^" Exit Do Case 92 '"\" If one Then Exit Do ElseIf r$ <> "" Or dot& Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else Exit Do End If Case 48 To 57, 95 '"0" To "9", "_" ' old ,"\" If one Then Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else If dot& > 0 Then a$ = "." + a$: dot& = 0 Exit Do End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 38 ' "&" If one Then Exit Do If r$ <> "" Then rr& = 0 r$ = vbNullString Exit Function Else a$ = Mid$(a$, 2) rr& = Abs(IsLabelDIM(bstack, a$, r$)) skipcase = True If rr& < 5 Then Dim i As Long If GetlocalVar(r$, i) Then a$ = Chr(34) + here$ & "." + r$ + Chr(34) + a$ ElseIf Left$(r$, 5) = "ΑΥΤΟ." Or Left$(r$, 5) = "THIS." Then If Len(bstack.UseGroupname) > 0 Then c$ = bstack.UseGroupname + Mid$(r$, 6) Else c$ = StripThis2(here$) If c$ <> "" Then c$ = c$ + "." + Mid$(r$, 6) Else c$ = here$ + "." + r$ End If a$ = Chr(34) + c$ + Chr(34) + a$ ElseIf varhash.Find(r$, cc) Then a$ = Chr(34) + r$ & Chr(34) + a$ Else '' r$ = myUcase(r$, gr) If r$ = "THIS" Or r$ = "ΑΥΤΟ" Then IsLabelDIM = -100 Exit Function Else If GetSub(r$ + ")", rr&) Then r$ = "{" + sbf(rr&).sb + "} " + sbf(rr&).sbgroup rr& = 2 Exit Do Else If Not bstack.NoError Then MyEr "can't pass reference", "δεν μπορώ να βάλω αναφορά" End If End If End If Else If FastSymbol(a$, ")") Then '' r$ = myUcase(r$, gr) rr& = 0 If Left$(r$, 5) = "ΑΥΤΟ." Or Left$(r$, 5) = "THIS." Then If varhash.ExistKey(bstack.UseGroupname & Mid$(r$, 6)) Then a$ = Chr(34) + bstack.UseGroupname & Mid$(r$, 6, Len(r$) - 6) + Chr(34) + a$ Else rr& = 1 End If ElseIf varhash.ExistKey(here$ & "." & r$) Then a$ = Chr(34) + here$ + "." + r$ + Chr(34) + a$ ElseIf varhash.ExistKey(r$) Then a$ = Chr(34) + r$ + Chr(34) + a$ Else rr& = 1 End If If rr& = 1 Then If Len(bstack.UseGroupname) > 0 Then r$ = bstack.UseGroupname + Mid$(r$, 6) Else End If If GetSub(r$ + ")", rr&) Then r$ = "{" + sbf(rr&).sb + "}" + sbf(rr&).sbgroup rr& = 2 Exit Do Else If Not bstack.NoError Then MyEr "can't pass reference", "δεν μπορώ να βάλω αναφορά" End If End If rr& = 0 r$ = vbNullString Exit Do End If End If r$ = vbNullString rr& = 0 Exit Do End If Case 36 ' "$" If one Then Exit Do If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 37 ' "%" If one Then Exit Do If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 40 ' "(" If r$ <> "" Then If Mid$(a$, 2, 2) = ")@" Then r$ = r$ + "()." a$ = Mid$(a$, 4) ElseIf Mid$(a$, 2, 2) = ")." Then ' And rr& = 1 Then r$ = r$ + "()." rr& = 0 one = False a$ = Mid$(a$, 4) GoTo CONT1234 Else Select Case rr& Case 1 rr& = 5 ' float array or function Case 3 rr& = 6 'string array or function Case 4 rr& = 7 ' long array Case Else Exit Do End Select r$ = r$ + c$ a$ = Mid$(a$, 2) Exit Do End If Else Exit Do End If Case Else Exit Do End Select Else If one Then Exit Do Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End If CONT1234: Loop If Not skipcase Then r$ = myUcase(r$, gr) If dot& Then If r$ <> "" Then ' rr& = bstack.GetDotNew(R$, dot&) * rr& If dot& = 1 Then 'R$ = "THIS." + R$ 'rr& = IsLabel(bstack, (R$), R$) 'rr& = -rr& rr& = bstack.GetDotNew(r$, dot&) * rr& Else rr& = bstack.GetDotNew(r$, dot&) * rr& End If Else If dot& > 1 Then r$ = String$(dot&, ".") + r$: If rr& = 0 Then rr& = 1 End If End If IsLabelDIM = rr& End Function Function IsLabelSYMB3(a$, r$) As Boolean ' for RevisionPrint Dim rr As Boolean, c$, LB As Long, mb As Long, LLB As Long a$ = NLtrim$(a$) LLB = Len(a$) r$ = vbNullString If LLB = 0 Then IsLabelSYMB3 = 0: Exit Function mb = 0 'INDICATE LEFT SPACES LB = 1 Do While LB <= LLB c$ = Mid$(a$, LB, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 32, 160, 9 If LB - mb > 1 Then LB = LB - 1: Exit Do Else mb = LB End If Case 36, 37, 40, 46, 48 To 57, 95 ' "$", "%", "(", "." IsLabelSYMB3 = 0 Exit Function 'Case 46 '"." ' If LB > mb Then ' rr& = 1 ' Else ' IsLabelSYMB3 = 0 ' Exit Function ' End If Case 65 To 90, 97 To 122 ' "A" To "Z", "a" To "z" rr = True Case Else LB = LB - 1 Exit Do End Select Else rr = True End If LB = LB + 1 Loop r$ = Mid$(a$, mb + 1, LB - mb) IsLabelSYMB3 = rr If LB > 0 Then a$ = Mid$(a$, LB + 1) End Function Function IsLabelSYMB33(a$, r$, Chars As Long) As Boolean ' ok Dim rr&, c$, LB As Long, mb As Long, LLB As Long LLB = Len(a$) r$ = vbNullString If LLB = 0 Then IsLabelSYMB33 = 0: Exit Function mb = 0 LB = 1 Do While LB <= LLB c$ = Mid$(a$, LB, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 32, 160, 9 If LB - mb > 1 Then LB = LB - 1 Exit Do Else mb = LB End If Case 46 '"." If LB > mb Then rr& = 1 Else IsLabelSYMB33 = 0 Exit Function End If Case 65 To 90, 97 To 122 ' "A" To "Z", "a" To "z" rr& = 1 'is an identifier or floating point variable Case Else LB = LB - 1 Exit Do End Select Else rr& = 1 'is an identifier or floating point variable End If LB = LB + 1 Loop r$ = Mid$(a$, mb + 1, LB - mb) IsLabelSYMB33 = rr& If rr& <> 0 Then Chars = LB + 1 End If End Function Function IsLabelSYMB33N(a$, r$, Chars As Long) As Boolean ' ok Dim rr&, c$, LB As Long, mb As Long, LLB As Long LLB = Len(a$) r$ = vbNullString If LLB = 0 Then IsLabelSYMB33N = 0: Exit Function mb = 0 LB = 1 Do While LB <= LLB c$ = Mid$(a$, LB, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 32, 160, 9 If LB - mb > 1 Then LB = LB - 1 Exit Do Else mb = LB End If Case 46 '"." If LB > mb Then rr& = 1 Else IsLabelSYMB33N = 0 Exit Function End If Case 65 To 90, 97 To 122 ' "A" To "Z", "a" To "z" rr& = 1 'is an identifier or floating point variable Case 48 To 57 If rr& <> 1 Then LB = LB - 1 Exit Do End If Case Else LB = LB - 1 Exit Do End Select Else rr& = 1 'is an identifier or floating point variable End If LB = LB + 1 Loop r$ = Mid$(a$, mb + 1, LB - mb) IsLabelSYMB33N = rr& If rr& <> 0 Then Chars = LB + 1 End If End Function Function IsLabelObj(a$, rrr$) As Long Dim buf$, gr As Boolean If Len(a$) < 129 Then IsLabelObj = IsLabelF2(a$, rrr$, gr): Exit Function buf$ = Left$(a$, 128) IsLabelObj = IsLabelF2(buf$, rrr$, gr) If buf$ = vbNullString Then IsLabelObj = IsLabelF2(a$, rrr$, gr) Else a$ = Mid$(a$, 129 - Len(buf$)) End If If gr Then rrr$ = myUcase(rrr$, True) Else rrr$ = UCase(rrr$) End Function Function IsLabelF2(a$, r$, gr As Boolean) As Boolean 'ok Dim rr&, c$ r$ = vbNullString If a$ = vbNullString Then Exit Function a$ = NLtrim$(a$) Do While Len(a$) > 0 c$ = Left$(a$, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 35, 46, 64, 92, 94, 123 To 126, 160 '"\","^", "{" To "~" Exit Do Case 48 To 57, 95 '"0" To "9", "_" If r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) IsLabelF2 = True Else Exit Do End If Case Is < 0, Is > 64 ' >=A and negative r$ = r$ + c$ a$ = Mid$(a$, 2) IsLabelF2 = True Case Else Exit Do End Select Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) IsLabelF2 = True End If Loop End Function Function IsLabelF(a$, rrr$) As Long Dim buf$ If Len(a$) < 129 Then IsLabelF = IsLabelF1(a$, rrr$): Exit Function buf$ = Left$(a$, 128) IsLabelF = IsLabelF1(buf$, rrr$) If buf$ = vbNullString Then IsLabelF = IsLabelF1(a$, rrr$) Else a$ = Mid$(a$, 129 - Len(buf$)) End If End Function Function IsLabelF1(a$, r$) As Long 'ok ' for left side...no & Dim rr&, one As Boolean, c$, gr As Boolean r$ = vbNullString If a$ = vbNullString Then IsLabelF1 = 0: Exit Function a$ = NLtrim$(a$) Do While Len(a$) > 0 c$ = Left$(a$, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 46 '"." If one Then Exit Do ElseIf r$ <> "" And Len(a$) > 1 Then If Mid$(a$, 2, 2) = ". " Or Mid$(a$, 2, 1) = " " Then Exit Do r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 Else IsLabelF1 = 0 Exit Function End If Case 92, 94, 123 To 126, 160 '"\","^", "{" To "~" Exit Do Case 48 To 57, 95 '"0" To "9", "_" If one Then Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else Exit Do End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 36 ' "$" If one Then Exit Do If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 37 ' "%" If one Then Exit Do If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case Else Exit Do End Select Else If one Then Exit Do Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End If Loop r$ = myUcase(r$, gr) IsLabelF1 = rr& End Function Function IsLabelA(where$, a$, r$) As Long Dim n$ If Len(a$) < 65 Then IsLabelA = IsLabelA1(where$, a$, r$) Else n$ = Left$(a$, 64) IsLabelA = IsLabelA1(where$, n$, r$) If Len(n$) = 0 Then IsLabelA = IsLabelA1(where$, a$, r$) Else a$ = Mid$(a$, 65 - Len(n$)) End If End If End Function Function IsLabelA1(where$, a$, r$) As Long 'ok ' for left side...no & Dim rr&, one As Boolean, c$, gr As Boolean r$ = vbNullString If a$ = vbNullString Then IsLabelA1 = 0: Exit Function a$ = NLtrim$(a$) Do While Len(a$) > 0 c$ = Left$(a$, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 64 '"@" If Mid$(a$, 2, 1) <> "(" And r$ <> "" Then where$ = r$ r$ = vbNullString a$ = Mid$(a$, 2) Else IsLabelA1 = 0: Exit Function End If Case 63 '"?" If r$ = vbNullString Then r$ = "?" a$ = Mid$(a$, 2) IsLabelA1 = 1 Exit Function Else IsLabelA1 = 1 Exit Function End If Case 46 '"." If one Then Exit Do Exit Do ElseIf r$ <> "" And Len(a$) > 1 Then If Mid$(a$, 2, 2) = ". " Or Mid$(a$, 2, 1) = " " Then Exit Do r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 Else IsLabelA1 = 0 Exit Function End If Case 38 ' "&" If r$ = vbNullString Then rr& = 2: a$ = Mid$(a$, 2) Exit Do Case 92, 94, 123 To 126, 160 '"\","^", "{" To "~" Exit Do Case 48 To 57, 95 '"0" To "9", "_" If one Then Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else Exit Do End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 36 ' "$" If one Then Exit Do If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 37 ' "%" If one Then Exit Do If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 40 ' "(" If r$ <> "" Then If Mid$(a$, 2, 2) = ")@" Then r$ = r$ + "()." a$ = Mid$(a$, 4) Else Select Case rr& Case 1 rr& = 5 ' float array or function Case 3 rr& = 6 'string array or function Case 4 rr& = 7 ' long array Case Else Exit Do End Select r$ = r$ + c$ a$ = Mid$(a$, 2) Exit Do End If Else Exit Do End If Case Else Exit Do End Select Else If one Then Exit Do Else gr = True r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End If Loop r$ = myUcase(r$, gr) IsLabelA1 = rr& End Function Function IsLabelDot(where$, a$, r$, Optional dotnum&) As Long 'ok ' for left side...no & Dim rr&, one As Boolean, br As Integer, c$, firstdot$, gr As Boolean r$ = vbNullString If a$ = vbNullString Then IsLabelDot = 0: Exit Function a$ = NLtrim$(a$) Do While Len(a$) > 0 c$ = Left$(a$, 1) If AscW(c$) < 256 Then Select Case AscW(c$) Case 64 '"@" If Mid$(a$, 2, 1) <> "(" And r$ <> "" Then where$ = r$ r$ = vbNullString a$ = Mid$(a$, 2) Else IsLabelDot = 0: a$ = firstdot$ + a$: Exit Function End If Case 63 '"?" If r$ = vbNullString And firstdot$ = vbNullString Then r$ = "?" a$ = Mid$(a$, 2) IsLabelDot = 1 Exit Function ElseIf firstdot$ = vbNullString Then IsLabelDot = 1 Exit Function Else IsLabelDot = 0 Exit Function End If Case 46 '"." If one Then Exit Do Exit Do ElseIf r$ <> "" And Len(a$) > 1 Then If Mid$(a$, 2, 2) = ". " Or Mid$(a$, 2, 1) = " " Then Exit Do r$ = r$ + Left$(a$, 1) a$ = Mid$(a$, 2) rr& = 1 Else firstdot$ = firstdot$ + "." a$ = Mid$(a$, 2) End If Case 92, 94, 123 To 126, 160 '"\","^", "{" To "~" Exit Do Case 48 To 57, 95 '"0" To "9", "_" If one Then If firstdot$ <> "" Then a$ = firstdot$ + a$ Exit Do ElseIf r$ <> "" Then r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else Exit Do End If Case 91 a$ = Mid$(a$, 2) If Len(r$) > 0 Then If Len(r$) = 1 Then If r$ <> "[" Then rr& = 8 Exit Do End If ElseIf Right$(r$, 1) <> "." Then If Right$(r$, 1) <> ChrW(&HFFBF) Then If Left$(r$, 1) <> "[" Then rr& = 8 Exit Do End If End If End If br = br + 1 r$ = r$ + "[" Else r$ = "[" rr& = 1 'is an identifier End If Case 93 If Len(r$) = 0 Then Exit Do If br > 0 Then br = br - 1 r$ = r$ + "]" a$ = Mid$(a$, 2) Else Exit Do End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit Do ElseIf Len(r$) = 0 Then If firstdot$ = "." Then r$ = "THIS." + c$ firstdot$ = vbNullString Else r$ = r$ + c$ End If a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable Else r$ = r$ + c$ a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If Case 36 ' "$" If one Then Exit Do If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 37 ' "%" If one Then Exit Do If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ + c$ a$ = Mid$(a$, 2) Else Exit Do End If Case 40 ' "(" If r$ <> "" Then If Mid$(a$, 2, 2) = ")@" Then r$ = r$ + "()." a$ = Mid$(a$, 4) ElseIf Mid$(a$, 2, 2) = ")." Then ' And rr& = 1 Then r$ = r$ + "()." rr& = 0 one = False a$ = Mid$(a$, 4) GoTo CONT1234 Else Select Case rr& Case 1 rr& = 5 ' float array or function Case 3 rr& = 6 'string array or function Case 4 rr& = 7 ' long array Case Else Exit Do End Select r$ = r$ + c$ a$ = Mid$(a$, 2) Exit Do End If Else Exit Do End If Case Else Exit Do End Select Else If one Then Exit Do Else gr = True If firstdot$ = "." Then r$ = "ΑΥΤΟ." + c$ firstdot$ = vbNullString Else r$ = r$ + c$ End If a$ = Mid$(a$, 2) rr& = 1 'is an identifier or floating point variable End If End If CONT1234: Loop If Len(firstdot$) = 0 Then r$ = myUcase(r$, gr) ElseIf dotnum& = -1 Then r$ = myUcase(r$, gr) dotnum& = Len(firstdot$) Else r$ = firstdot$ + myUcase(r$, gr) End If IsLabelDot = rr& End Function Function IsStrExp(basestack As basetask, aa$, rr$, Optional check As Boolean = True) As Boolean Dim ac$, fault As Boolean, p, noconvert As Boolean noconvert = Not check If Len(aa$) = 0 Then Exit Function If check Then If Not AscW(aa$) = 8 Then If Not aheadstatusStr(aa$) Then Exit Function End If End If If LastErNum = -2 Then LastErNum = 0 ': LastErNum1 = 0 again: fault = False IsStrExp = False If IsString(basestack, aa$, rr$, noconvert) Then Do fault = False IsStrExp = True If Len(ac$) > 0 Then ac$ = ac$ + rr$ Else SwapStrings ac$, rr$ End If If Not MaybeIsSymbol(aa$, "+") Then Exit Do FastSymbol aa$, "+" noconvert = False Set basestack.lastobj = Nothing fault = True GoTo 129983 If FastSymbol(aa$, "(") Then If IsExpA(basestack, aa$, p, (0)) Then If Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is BigInteger Then p = basestack.lastobj.ToString End If Set basestack.lastobj = Nothing End If If Not FastSymbol(aa$, ")") Then Exit Do GoTo cont003003 End If End If 129983 If Not IsString(basestack, aa$, rr$, noconvert) Then If Not IsNumber(basestack, aa$, p, True) Then MissString Exit Function Else cont003003: Assign rr$, p End If End If Loop If fault Then If LastErNum = -2 Then Exit Function If FastSymbol(aa$, "<<", , 2) Then basestack.soros.DataStr ac$ ac$ = vbNullString GoTo again End If End If If Not IsStrExp Then Set basestack.lastobj = Nothing SwapStrings rr$, ac$ 'rr$ = ac$ End Function Function ReadVarDouble(bstack As basetask, what$) As Variant Dim vvv As Variant bstack.ReadVar what$, vvv If MyIsObject(vvv) Then Set bstack.lastobj = vvv Else ReadVarDouble = vvv End If End Function Function ReadVarInt(bstack As basetask, what$) As Variant Dim vvv As Variant bstack.ReadVar what$, vvv ReadVarInt = Int(vvv) End Function Function ReadVarStr(bstack As basetask, what$) As String Dim vvv As Variant bstack.ReadVar what$, vvv ReadVarStr = vvv End Function Function IsString(bstackstr As basetask, a$, r$, Optional noconvert As Boolean = False) As Boolean r$ = vbNullString Dim i As Long, q i = MyTrimL(a$) ' MyTrimL(" ") return 3 no 0. but never happen to be " " If Len(a$) < i Then Exit Function End If q = AscW(Mid$(a$, i, 1)) Select Case q Case 92, 47, 39, 58 Exit Function Case 123 r$ = blockString(a$, 125, i + 1) IsString = FastSymbol(a$, "}") If Not IsString Then GoTo err1111 Exit Function Case 34 r$ = blockString(a$, 34, i + 1) IsString = FastSymbol(a$, Chr$(34)) If Not IsString Then GoTo err1111 If r$ = vbNullString Then Dim rr$ Do While a$ <> "" Oldway a$, rr$ r$ = r$ + rr$ If Len(a$) > 0 Then If AscW(a$) = 34 Then a$ = Mid$(a$, 2) r$ = r$ + Chr$(34) + blockString(a$, 34) IsString = FastSymbol(a$, Chr$(34)) Else Exit Do End If Else Exit Do End If Loop End If If Not IsString Then GoTo err1111 Exit Function Case 40 q = "" FastSymbol a$, "(" If GetArr(bstackstr, a$, q, r$, 0, True) Then If myVarType(q, vbString) Then SwapString2Variant r$, q: IsString = True ElseIf bstackstr.lastobj Is Nothing Then r$ = fixthis(q) Else If TypeOf bstackstr.lastobj Is BigInteger Then r$ = bstackstr.lastobj.ToString Else r$ = "*Object" End If End If IsString = True End If Case 1, 2 IsString = ISSTRINGA(a$, r$) Case Else IsString = IsStr1(bstackstr, a$, r$, noconvert) End Select Exit Function err1111: MyErMacroStr a$, "No closed string, open with " + ChrW(q), "Ανοιχτό αλφαριθμητικό, με " + ChrW(q) End Function Private Sub Oldway(a$, r$) Dim W As Long W = 1 If Mid$(a$, W, 2) = Chr(34) + Chr$(34) Then Do r$ = r$ + Chr$(34) W = W + 2 Loop Until Not Mid$(a$, W, 2) = Chr(34) + Chr$(34) a$ = NLtrim$(Mid$(a$, W)) End If End Sub Function IsStr1(bstackstr As basetask, a$, r$, Optional onlyString As Boolean = True) As Boolean Dim nbstack As basetask, n$ Dim p As Variant, pp As Variant, pppp As mArray, ppppl As iBoxArray, usehandler As mHandler, rA As refArray Dim q$, W As Long, w1 As Long, w2 As Long, s$, par As Boolean, usebackup As Boolean Dim q1$, q2$, w3 As Long, dn As Long, dd As Long, bs As basetask, sg1 As Boolean Dim anything As Object, gr As Boolean Dim aaa As lambda againpointer: Set bstackstr.lastobj = Nothing w2 = Len(a$) If w2 < 129 Then w1 = IsLabelBig(bstackstr, a$, q$, par, q2$, , , usebackup, , gr) Else n$ = Left$(a$, 128) q1$ = bstackstr.tmpstr w1 = IsLabelBig(bstackstr, n$, q$, par, q2$, , , usebackup, sg1, gr) If Len(n$) = 0 Then If sg1 Then bstackstr.tmpstr = q1$ w1 = IsLabelBig(bstackstr, a$, q$, par, q2$, , , usebackup, gr) Else If sg1 Then sg1 = False Select Case Len(n$) Case Is < 128 Mid$(a$, 129 - Len(n$), Len(n$)) = n$ a$ = Mid$(a$, 129 - Len(n$)) Case Is > 128 a$ = n$ + Mid$(a$, 129) Case Else Mid$(a$, 1, 128) = n$ End Select Else a$ = Mid$(a$, 129 - Len(n$)) End If End If End If ''''''''If NoOptimum Then If w1 > 0 Then par = False If w1 <= 0 Or par Then If usebackup Then If w1 > 4 Then GoTo conthere If w1 = 0 Then Exit Function If w1 = -50 Then r$ = q$ IsStr1 = True Exit Function End If If w1 = -100 Then w1 = 0 r$ = vbNullString If bstackstr.GetDotNew(r$, 1, True) Then If r$ = "THIS." Then r$ = Left$(bstackstr.UseGroupname, Len(bstackstr.UseGroupname) - 1) ElseIf Len(bstackstr.UseGroupname) > 0 Then If bstackstr.tpointer > 0 Then If var(bstackstr.tpointer).GroupName = r$ Then r$ = var(bstackstr.tpointer).Patch Else GoTo cont2345 End If Else cont2345: If Len(r$) = 0 Then IsStr1 = False: Exit Function If r$ = bstackstr.UseGroupname Then r$ = Left$(r$, Len(r$) - 1) ElseIf InStr(r$, ".") = 0 Then r$ = Left$(r$, Len(r$) - 1) If here$ <> "" Then r$ = here$ + "." + r$ Else r$ = Left$(r$, Len(r$) - 1) End If End If Else If Len(r$) = 1 Then Set bs = bstackstr.Parent Do While Not (bs Is Nothing) If bs.GetDotNew(r$, 1) Then If Len(r$) = 1 Then Set bs = bs.Parent Else r$ = here$ + "." + Left$(r$, Len(r$) - 1) Set bs = Nothing Exit Do End If Else r$ = vbNullString Exit Do End If Loop Else If Len(r$) = 0 Then ElseIf Left$(r$, 1) = "*" Then r$ = Mid$(r$, 2, Len(r$) - 2) ElseIf Len(here$) > 0 Then If Len(here$) < Len(r$) Then If Left$(r$, Len(here$) + 1) = here$ + "." Then r$ = Left$(r$, Len(r$) - 1) Else r$ = here$ + "." + Left$(r$, Len(r$) - 1) End If Else r$ = here$ + "." + Left$(r$, Len(r$) - 1) End If Else r$ = Left$(r$, Len(r$) - 1) End If End If End If IsStr1 = True Exit Function ElseIf Len(bstackstr.UseGroupname) > 0 Then r$ = Left$(bstackstr.UseGroupname, Len(bstackstr.UseGroupname) - 1) IsStr1 = True Exit Function End If r$ = vbNullString End If w1 = Abs(w1) Select Case w1 Case 2 SwapStrings r$, q$ IsStr1 = True Exit Function Case 3 GoTo itisavar Case 5 GoTo rvalObjectstring Case 6 GoTo itisarrayorfunction Case 8 If GetVar(bstackstr, q$, w1) Then If MyIsObject(var(w1)) Then If Typename(var(w1)) = "RefArray" Then FastSymbol1 a$, "[" Set rA = var(w1) r$ = BlockParamSq(a$) If r$ = "" Then SyntaxError Exit Function End If Mid$(a$, 1, Len(r$)) = space$(Len(r$)) If IsExp(bstackstr, r$, p, flatobject:=True, nostring:=True) Then p = Abs(Int(p)) If rA.MarkTwoDimension Then If FastSymbol(a$, "][", True, 2) Then r$ = BlockParamSq(a$) If r$ = "" Then SyntaxError Exit Function End If Mid$(a$, 1, Len(r$)) = space$(Len(r$)) If IsExp(bstackstr, r$, pp, flatobject:=True, nostring:=True) Then pp = Abs(Int(pp)) If rA.Count <= p Then OutOfLimit ElseIf rA.Count(p) <= pp Then OutOfLimit Else Select Case rA.vtType(p, pp) Case 9 Set p = rA(p, pp) If p Is Nothing Then r$ = "" IsStr1 = True ElseIf TypeOf p Is BigInteger Then r$ = p.ToString IsStr1 = True Else Set bstackstr.lastobj = p r$ = "" If FastSymbol(a$, "]") Then GoTo Final Else SyntaxError End If End If Case 8 r$ = rA(p, pp) IsStr1 = True Case Else r$ = fixthis(rA(p, pp)) IsStr1 = True End Select End If Exit Function Else MissNumExpr End If End If Else If rA.Count((0)) <= p Then OutOfLimit Exit Function Else Select Case rA.vtType(0, p) Case 9 Set p = rA(0, p) If p Is Nothing Then r$ = vbNullString Set bstackstr.lastobj = Nothing Else If TypeOf p Is BigInteger Then SwapString2Variant r$, p.ToString Set bstackstr.lastobj = Nothing Else r$ = vbNullString Set bstackstr.lastobj = p End If End If Case vbString r$ = rA(0, p) Case vbUserDefinedType If FastOperator(a$, "]|", (1), (2)) Then w2 = IsLabel(bstackstr, a$, s$) If w2 > 0 Then pp = rA(0, p, s$) there12345: Select Case MemInt(VarPtr(pp)) Case vbString SwapString2Variant r$, pp Case 9 Set bstackstr.lastobj = pp Case Else If onlyString Then MissString: IsStr1 = False: Exit Function r$ = fixthis(pp) End Select End If IsStr1 = True Exit Function Else r$ = fixthis(rA(0, p)) End If Case Else If onlyString Then MissString: IsStr1 = False: Exit Function r$ = fixthis(rA(0, p)) End Select IsStr1 = FastSymbol(a$, "]") Exit Function End If If FastSymbol(a$, "]") Then GoTo Final Else SyntaxError End If End If Else MissNumExpr End If Else If TypeOf var(w1) Is mHandler Then If var(w1).t1 = 2 Then If IsExp(bstackstr, a$, pp, , True, , True) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, , True, , True) Then If Not FastSymbol(a$, "]") Then IsStr1 = False: SyntaxError: Exit Function GoTo contMem2Str Else missNumber IsStr1 = False Exit Function End If End If If Not FastSymbol(a$, "]") Then IsStr1 = False: SyntaxError: Exit Function If lookOne(a$, "|") Then GoTo CONThereUDT ' get all as string p = 0 contMem2Str: Set usehandler = var(w1) r$ = usehandler.objref.CopyItemString(pp, p, par) IsStr1 = par Exit Function End If End If End If WrongObject End If Else MissingObj End If Else UnknownVariable q$ End If IsStr1 = False Exit Function Case Else checkpointer: If w1 = 1 Then If lookOne(a$, "+") Then onlyString = False If GetVar(bstackstr, q$, w1) Then If MyIsObject(var(w1)) Then If TypeOf var(w1) Is Group Then If var(w1).HasValue Then If var(w1).HasValue And Not IsOperator(a$, "::", 2) Then q1$ = q$ + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" W = w1 If GetSub(q1$, w1) Then GoTo foundprivate End If ElseIf var(w1).IamApointer Then Set bstackstr.lastpointer = var(w1) If var(w1).link.IamFloatGroup Then Set ppppl = BoxGroupVar(var(w1)) Mid$(a$, 1, 2) = "." + Chr(3) IsStr1 = SpeedGroup(bstackstr, ppppl, "VAL$", "", a$, (0)) = 1 r$ = bstackstr.LastValue Exit Function Else Mid$(a$, 1, 2) = Chr(0) + "." GoTo againpointer End If ElseIf lookOne(a$, "#") Then q$ = q$ + "$" W = w1 GoTo Checkit End If ElseIf TypeOf var(w1) Is mHandler Then If FastSymbol(a$, "#") Then comehere: p = vbNullString IsStr1 = fMatrix(bstackstr, a$, var(w1), p) If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else r$ = vbNullString Exit Function Else pp = 0& CONThereUDT: Set usehandler = var(w1) If Not usehandler.objref Is Nothing Then conthereHandler: If TypeOf usehandler.objref Is Enumeration Then If myVarType(usehandler.index_cursor, vbString) Then r$ = usehandler.index_cursor IsStr1 = True Exit Function Else If MyIsNumeric(usehandler.index_cursor) Then If onlyString Then MissString: IsStr1 = False: Exit Function If CheckInt64(usehandler.index_cursor) Then r$ = CStr(usehandler.index_cursor) ElseIf myVarType(var(w1), vbBoolean) Then If ShowBooleanAsString Then r$ = format$(var(w1), DefBooleanString) Else r$ = CStr(var(w1) * 1) End If Else r$ = fixthis(usehandler.index_cursor) End If IsStr1 = True End If Exit Function End If Else p = 0 If TakeOffset(bstackstr, usehandler, a$, p, pp) Then GoTo CONT1234s End If IsStr1 = False Exit Function End If End If End If ElseIf TypeOf var(w1) Is PropReference Then p = var(w1).Value GoTo CONT1234s ElseIf TypeOf var(w1) Is Constant Then 'var(w1).flag=true is a lambda function '''''''''''''''''''''''''''''''''''Stop'''''''''''''''''''''''' If Not var(w1).flag Then p = var(w1).Value CONT1234s: If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else If onlyString Then MissString: IsStr1 = False: Exit Function If MemInt(VarPtr(p)) = 20 Then r$ = CStr(p) ElseIf myVarType(p, vbBoolean) Then If ShowBooleanAsString Then r$ = format$(p, DefBooleanString) Else r$ = CStr(p * 1) End If Else r$ = fixthis(p) End If End If IsStr1 = True Exit Function End If ElseIf TypeOf var(w1) Is BigInteger Then r$ = var(w1).ToString IsStr1 = True Exit Function End If Else If myVarType(var(w1), vbString) Then r$ = var(w1) IsStr1 = True Exit Function ElseIf Not myVarType(var(w1), vbObject) Then If onlyString Then MissString: IsStr1 = False: Exit Function If CheckInt64(var(w1)) Then r$ = CStr(var(w1)) ElseIf myVarType(var(w1), vbBoolean) Then r$ = format$(var(w1), DefBooleanString) Else r$ = fixthis(var(w1)) End If IsStr1 = True End If Exit Function End If ElseIf q$ = "ARRAY" Then arrentry: If bstackstr.soros.Total = 0 Then EmptyStack a$ IsStr1 = False: Exit Function ElseIf bstackstr.soros.StackItemTypeObjectType(1) = "*[tuple]" Then Set bstackstr.lastobj = bstackstr.soros.PopObj GoTo Final ElseIf bstackstr.soros.StackItemTypeObjectType(1) = "*[mArray]" Then Set bstackstr.lastobj = bstackstr.soros.PopObj GoTo Final Else StackTopNotArray a$ IsStr1 = False End If Exit Function ElseIf q$ = "ΠΙΝΑΚΑΣ" Then GoTo arrentry ElseIf IsNumberNew(bstackstr, (q$), p, True) Then GoTo getsomethinghere End If End If IsStr1 = False Exit Function End Select End If conthere: Select Case w1 Case 1 If lookOne(a$, "+") Then onlyString = False GoTo checkpointer Case 3 IsStr1 = False If usebackup Then If Not stridbackup.Find(q$, w1) Then GoTo itisavar Else If Not strid.Find(q$, w1, bstackstr.strnum) Then GoTo itisavar If w1 < 0 Then GoTo itisavar End If findsecond: IsStr1 = strLiterals(w1, bstackstr, a$, r$) Exit Function itisavar: If GetVar(bstackstr, q$, W) Then If MyIsObject(var(W)) Then If TypeOf var(W) Is lambda Then r$ = vbNullString var(W).CopyTo aaa, var() Set bstackstr.lastobj = aaa Set aaa = Nothing ElseIf TypeOf var(W) Is PropReference Then On Error Resume Next r$ = var(W).Value If var(W).LastHasObject Then Set bstackstr.lastobj = var(W).lastobj var(W).clearlastobject End If If Err Then r$ = vbNullString ElseIf TypeOf var(W) Is Group Then Checkit: If var(W).HasValue And Not IsOperator(a$, "::", 2) Then If Len(var(W).Patch) > 0 Then q1$ = var(W).Patch + "." + ChrW(&H1FFF) + "$()" Else q1$ = Left$(q$, Len(q$) - 1) + "." + ChrW(&H1FFF) + "$()" End If If GetSub(q1$, w1) Then foundprivate: Set nbstack = New basetask Set nbstack.Parent = bstackstr If bstackstr.IamThread Then Set nbstack.Process = bstackstr.Process Set nbstack.Owner = bstackstr.Owner nbstack.OriginalCode = w1 nbstack.UseGroupname = sbf(w1).sbgroup nbstack.tpointer = sbf(w1).tpointer nbstack.SetV If GoFunc(nbstack, q1$, ")", r$) Then If Not nbstack.StaticCollection Is Nothing Then bstackstr.Parent.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If If Mid$(a$, 1, 2) = "=>" Then If Not nbstack.lastobj Is Nothing Then If TypeOf nbstack.lastobj Is Group Then If nbstack.lastobj.IamApointer Then Set ppppl = BoxGroupVar(nbstack.lastobj) Set nbstack = Nothing W = 0 Mid$(a$, 1, 2) = "." + ChrW(3) End If GoTo groupstrvalue End If End If End If Set nbstack = Nothing IsStr1 = True If FastSymbol(a$, "#") Then p = vbNullString Set pp = bstackstr.lastobj Set bstackstr.lastobj = Nothing IsStr1 = fMatrix(bstackstr, a$, pp, p) If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else r$ = vbNullString Exit Function End If Else IsStr1 = False End If Else w3 = rinstr(q$, ".", Len(var(W).GroupName) + 1) s$ = Left$(q$, Len(q$) - 1) q1$ = Left$(s$, w3) + ChrW(&HFFBF) + Mid$(s$, w3 + 1) + "." + ChrW(&H1FFF) + "$()" If GetSub(q1$, w1) Then GoTo foundprivate InternalError IsStr1 = False End If Else r$ = vbNullString Set bstackstr.lastobj = CopyGroupObj(var(W)) End If ElseIf TypeOf var(W) Is Document Then r$ = var(W) ElseIf TypeOf var(W) Is Constant Then If var(W).flag Then If VarTypeName(var(W).Value) = "lambda" Then CopyLambda var(W).Value, bstackstr End If Else GoTo there12001 End If Else there12001: On Error Resume Next r$ = var(W).Value If Err > 0 Then Err.Clear r$ = var(W) If Err > 0 Then badread End If End If On Error GoTo 0 End If Else If myIsNull(var(W)) Then VarNull IsStr1 = False Exit Function Else r$ = var(W) End If End If IsStr1 = True Else If W = -1 Then r$ = ReadVarStr(bstackstr, q$) IsStr1 = True Exit Function End If IsStr1 = False ' MAKE LENGTH EQUAL... If stridbackup.Find(q$, w1) Then GoTo findsecond If w2 >= Len(a$) Then a$ = Left$(q$ + space$(Len(q$)), w2 - Len(a$)) + a$ If FindNameForGroup(bstackstr, q$) Then MyErMacroStr a$, "Unknown property " + q$, "Άγνωστη ιδιότητα " + q$ Else UnknownVariable1 a$, q$ End If End If Exit Function Case 5 ' check again rvalObjectstring: If Left$(aheadstatusFast(q$ + CopyUntilEndOfLine(a$)), 1) = "S" Then enter2: If neoGetArray(bstackstr, q$, ppppl) Then If ppppl.arr Then If FastSymbol(a$, ")") Then If MaybeIsSymbol(a$, "#") Then Set bstackstr.lastobj = ppppl: GoTo Final End If End If enterthis: If NeoGetArrayItem(ppppl, bstackstr, q$, W, a$, , , True, True) Then If Not ppppl.arr And FastSymbol(a$, ")") Then ' need an object If IsNumber(bstackstr, q$ + ")", p) Then If Not bstackstr.lastobj Is Nothing Then Set ppppl.GroupRef = bstackstr.lastobj Set bstackstr.lastobj = Nothing W = -2 If FastSymbol(a$, "(") Then If NeoGetArrayItem(ppppl, bstackstr, q$, W, a$, , , True) Then End If End If End If End If Else enteragain: If ppppl.ItemType(W) = mGroup Then If ppppl.item(W).IamFloatGroup Then If ppppl.item(W).IamApointer Then If Mid$(a$, 1, 2) = "=>" Then Mid$(a$, 1, 2) = "." + ChrW(3) End If GoTo groupstrvalue End If If ppppl.GroupRef Is Nothing Then GoTo groupstrvalue Else If Len(q$) > Len(ppppl.GroupRef.GroupName) Then q1$ = Left$(q$, Len(q$) - 1) + "." + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" Else q1$ = ppppl.GroupRef.GroupName + ChrW(&H1FFF) + ChrW(&H1FFD) + "()" End If End If q$ = BlockParam(a$) a$ = Mid$(a$, Len(q$) + 2) If GetSub(q1$, w1) Then Set nbstack = New basetask Set nbstack.Parent = bstackstr If bstackstr.IamThread Then Set nbstack.Process = bstackstr.Process Set nbstack.Owner = bstackstr.Owner nbstack.OriginalCode = w1 nbstack.UseGroupname = sbf(w1).sbgroup nbstack.tpointer = sbf(w1).tpointer nbstack.SetV If GoFunc(nbstack, q1$, q$ + ")", r$) Then If Not nbstack.StaticCollection Is Nothing Then bstackstr.Parent.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If 'Set bstackstr.lastobj = nBstack.lastobj If IsOperator(a$, "(") Then Set ppppl = New ppppLight Set ppppl.GroupRef = bstackstr.lastobj Set bstackstr.lastobj = Nothing ppppl.arr = False W = -2 Set nbstack = Nothing GoTo contrightstrpar ElseIf Left$(a$, 1) = "." Then cont1002001: Set ppppl = New ppppLight Set ppppl.GroupRef = bstackstr.lastobj Set bstackstr.lastobj = Nothing ppppl.arr = False W = -2 Set nbstack = Nothing GoTo groupstrvalue End If End If Set nbstack = Nothing IsStr1 = True Else IsStr1 = False End If ElseIf ppppl.ItemType(W) = mHdlr Then If FastSymbol(a$, "#") Then p = vbNullString IsStr1 = fMatrix(bstackstr, a$, ppppl.item(W), p) If Left$(a$, 1) = "." And Not bstackstr.lastobj Is Nothing Then If TypeOf bstackstr.lastobj Is Group Then GoTo cont1002001 End If End If If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else r$ = vbNullString Exit Function Else Set anything = ppppl.item(W) Set usehandler = anything If usehandler.t1 = 3 Then Set ppppl = usehandler.objref Set usehandler = Nothing GoTo enterthis End If Set usehandler = Nothing End If ElseIf IsobjAndArray(ppppl.item(W)) And InStr(q$, "$") = 0 Then If FastSymbol(a$, "#") Then p = vbNullString Set usehandler = New mHandler Set usehandler.objref = ppppl.item(W) IsStr1 = fMatrix(bstackstr, a$, usehandler, p) jump1: If Left$(a$, 1) = "." And Not bstackstr.lastobj Is Nothing Then If TypeOf bstackstr.lastobj Is Group Then GoTo cont1002001 End If End If If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else r$ = vbNullString Exit Function Else Set bstackstr.lastobj = ppppl.item(W) IsStr1 = True End If ElseIf Typename(ppppl.GroupRef) = mProp Then p = ppppl.GroupRef.Value If ppppl.GroupRef.LastHasObject Then Set bstackstr.lastobj = ppppl.GroupRef.lastobj ppppl.GroupRef.clearlastobject End If If Not bstackstr.lastobj Is Nothing Then p = vbNullString If lookOne(a$, ".") Then GoTo cont1002001 ElseIf Left$(a$, 2) = "=>" Then Mid$(a$, 1, 2) = "." + Chr(3) GoTo cont1002001 ElseIf FastSymbol(a$, "#") Then If TypeOf bstackstr.lastobj Is mHandler Then Set usehandler = bstackstr.lastobj Set bstackstr.lastobj = Nothing IsStr1 = fMatrix(bstackstr, a$, usehandler, p) GoTo jump1 End If ElseIf bstackstr.lastobj Is Nothing Then GoTo CONT1234s 'R$ = "" 'Exit Function End If ElseIf Not ppppl.IsObjAt(W, p) Then getsomethinghere: If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else If CheckInt64(p) Then If onlyString Then MissString: IsStr1 = False: Exit Function r$ = CStr(p) ElseIf myVarType(p, vbBoolean) Then If onlyString Then MissString: IsStr1 = False: Exit Function If ShowBooleanAsString Then r$ = format$(p, DefBooleanString) Else r$ = CStr(p * 1) End If ElseIf myVarType(p, vbUserDefinedType) Then If FastOperator(a$, "|", (1)) Then w2 = IsLabel(bstackstr, a$, s$) If w2 > 0 Then pp = GetUDTValue(p, s$) GoTo there12345 End If End If If onlyString Then MissString: IsStr1 = False: Exit Function Else If onlyString Then MissString: IsStr1 = False: Exit Function r$ = fixthis(p) End If End If IsStr1 = True Else IsStr1 = False End If Exit Function End If groupstrvalue: If ppppl.ItemType(W) = mGroup Then IsStr1 = SpeedGroup(bstackstr, ppppl, "VAL$", q$, a$, W) = 1 r$ = bstackstr.LastValue Exit Function End If Else If Not ppppl Is Nothing Then If Not anything Is Nothing Then If myVarType(ppppl.item(W), vbObject) Then If anything Is ppppl.item(W) Then Exit Function Else If ppppl.arr Then If FastSymbol(a$, ")") Then Set bstackstr.lastobj = ppppl: GoTo Final Exit Function End If End If Set anything = ppppl.item(W) If CheckLastHandler(anything) Then Set usehandler = anything If usehandler.t1 = 3 Then If TypeOf usehandler.objref Is iBoxArray Then Set ppppl = usehandler.objref Set usehandler = Nothing Else Exit Function End If Else Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = anything End If Set usehandler = Nothing If NeoGetArrayItem(ppppl, bstackstr, q$, W, a$) Then GoTo enteragain Else If Not ppppl Is Nothing Then If W < 0 Then Set usehandler = ppppl.item(W) If Typename(usehandler.objref) = myArray Then Set ppppl = usehandler.objref End If Set usehandler = Nothing GoTo enterthis End If End If End If End If End If End If Else If usebackup Then If Not strfunidbackup.Find(q$, w1) Then GoTo isasub ' Exit Function Else If Not strfunid.Find(q$, w1, bstackstr.strnum) Then q1$ = q$ + ")" If GetSub(q1$, w1) Then Set nbstack = New basetask Set nbstack.Parent = bstackstr Set nbstack.Owner = bstackstr.Owner nbstack.UseGroupname = sbf(w1).sbgroup nbstack.tpointer = sbf(w1).tpointer nbstack.OriginalCode = w1 nbstack.SetV If GoFunc(nbstack, q1$, a$, s$, , , True) Then If Not nbstack.StaticCollection Is Nothing Then bstackstr.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If Set bstackstr.lastobj = nbstack.lastobj Set nbstack = Nothing SwapStrings r$, s$ s$ = vbNullString If bstackstr.lastobj Is Nothing Then IsStr1 = True Exit Function End If GoTo Final Else IsStr1 = False End If Else If subHash.Find(here$ + "." + q$ + ")", w1) Then GoTo isasub Else GoTo cont112233 End If End If Exit Function End If If w1 < 0 Then Exit Function End If On w1 GoTo F1, f2, f3, f4, f5, f6, f7 Exit Function F1: ' "STACKITEM(", "ΤΙΜΗΣΩΡΟΥ(" IsStr1 = StackItem(bstackstr, a$, p) GoTo Final f2: ' "ARRAY(", "ΠΙΝΑΚΑΣ(" IsStr1 = IsArrayFun(bstackstr, a$, p) GoTo Final f3: ' "CONS(", "ΕΝΩΣΗ(" IsStr1 = IsCons(bstackstr, a$, p) GoTo Final f4: ' "CAR(", "ΠΡΩΤΟ(" IsStr1 = IsCar(bstackstr, a$, p) GoTo Final f5: ' "CDR(", "ΕΠΟΜΕΝΑ(" IsStr1 = IsCdr(bstackstr, a$, p) GoTo Final f6: ' "VAL(", "ΤΙΜΗ(", "ΑΞΙΑ(" IsStr1 = IsVal(bstackstr, a$, p, Left$(q$, 1) = "V") GoTo Final f7: ' "EVAL(", "ΕΚΦΡ(", "ΕΚΦΡΑΣΗ(" IsStr1 = IsEval(q$, bstackstr, a$, p) Final: If FastSymbol(a$, "#") Then p = vbNullString Set pp = bstackstr.lastobj Set bstackstr.lastobj = Nothing IsStr1 = fMatrix(bstackstr, a$, pp, p) If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else r$ = vbNullString Exit Function ElseIf Left$(a$, 2) = "=>" Then If TypeOf bstackstr.lastobj Is Group Then Set ppppl = BoxGroupVar(bstackstr.lastobj) Set nbstack = Nothing Set bstackstr.lastobj = Nothing W = 0 Mid$(a$, 1, 2) = "." + ChrW(3) GoTo groupstrvalue End If ElseIf MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p IsStr1 = True Exit Function Else If onlyString Then MissString: IsStr1 = False: Exit Function If CheckInt64(p) Then r$ = CStr(p) ElseIf myVarType(p, vbBoolean) Then If ShowBooleanAsString Then r$ = format$(p, DefBooleanString) Else r$ = CStr(p * 1) End If Else r$ = fixthis(p) End If IsStr1 = True Exit Function End If End If Else ' If neoGetArray(bstackstr, q$, pppp) Then GoTo enter2 'End If IsStr1 = False Exit Function End If Case 6 IsStr1 = False If usebackup Then If Not strfunidbackup.Find(q$, w2) Then GoTo isasub End If Else If Not strfunid.Find(q$, w2, bstackstr.strfunnum) Then GoTo itisarrayorfunction If w2 < 0 Then GoTo itisarrayorfunction End If findthird: IsStr1 = strFunctions(w2, q$, bstackstr, a$, r$) Exit Function itisarrayorfunction: q1$ = q$ If Right$(q1$, 1) <> ")" Then q1$ = q1$ + ")" MakeThisSubNum bstackstr, q1$ If IsSymbol(a$, "*") Then 'is a function allways... If GetlocalSub(q1$, w1) Then GoTo contStrFun ElseIf GetSub(q1$, w1) Then GoTo contStrFun ElseIf GetSub2(bstackstr, q1$, w1) Then GoTo contStrFun Else If Len(bstackstr.UseGroupname) > 0 Then If InStr(q1$, bstackstr.UseGroupname) = 1 Then q1$ = bstackstr.UseGroupname + ChrW(&HFFBF) + Mid$(q1$, Len(bstackstr.UseGroupname) + 1) If GetSub(q1$, w1) Then GoTo contStrFun End If End If GoTo skiperrorStr End If Else If neoGetArray(bstackstr, q$, ppppl, , , True) Then GoTo contStrArr ElseIf GetlocalSub(q1$, w1) Then GoTo contStrFun ElseIf neoGetArray(bstackstr, q$, ppppl, , True) Then GoTo contStrArr ElseIf GetSub2(bstackstr, q1$, w1) Then GoTo contStrFun ElseIf GetSub(q1$, w1) Then GoTo contStrFun Else If Len(bstackstr.UseGroupname) > 0 Then If InStr(q1$, bstackstr.UseGroupname) = 1 Then q1$ = bstackstr.UseGroupname + ChrW(&HFFBF) + Mid$(q1$, Len(bstackstr.UseGroupname) + 1) If GetSub(q1$, w1) Then GoTo contStrFun End If End If GoTo skiperrorStr End If End If If GetSub(q1$, w1) Then contStrFun: If bstackstr.NoFuncError Then r$ = q$ CallNext bstackstr, a$, par, p, r$ If par Then IsStr1 = True Else r$ = vbNullString IsStr1 = False End If ElseIf w1 = -1 Then GoTo isasub Else Set nbstack = New basetask Set nbstack.Parent = bstackstr Set nbstack.Owner = bstackstr.Owner nbstack.UseGroupname = sbf(w1).sbgroup nbstack.tpointer = sbf(w1).tpointer nbstack.OriginalCode = w1 nbstack.SetV If GoFunc(nbstack, q1$, a$, s$, , , True) Then If Not nbstack.StaticCollection Is Nothing Then bstackstr.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If Set bstackstr.lastobj = nbstack.lastobj SwapStrings r$, s$ s$ = vbNullString IsStr1 = True Else IsStr1 = False End If End If Exit Function ElseIf neoGetArray(bstackstr, q$, ppppl) Then contStrArr: If ppppl.arr Then If TypeOf ppppl Is iBoxArray Then If TypeOf ppppl Is mArray Then Set pppp = ppppl If FastSymbol(a$, ")") Then IsStr1 = True p = 0 Set bstackstr.lastobj = pppp Exit Function End If dn = 0 dd = pppp.bDnum - 1 If dd < 0 Then If Typename(pppp.GroupRef) = mProp Then GoTo contreadprop End If End If ElseIf TypeOf ppppl Is tuple Then If FastSymbol(a$, ")") Then IsStr1 = True r$ = "" Set bstackstr.lastobj = ppppl Exit Function End If If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If Not FastSymbol(a$, ")") Then MyEr "missing )", "λείπει )": Exit Function If p >= ppppl.Count Then GoTo toohigh ElseIf p < 0 Then GoTo toolow Else w2 = p IsStr1 = True GoTo cont12345 End If End If End If Else SyntaxError Exit Function End If p = 0 pp = 0 IsStr1 = True w2 = 0 Do While dn <= dd pppp.GetDnum dn, w3, w1 If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If dn < dd Then If Not FastSymbol(a$, ",") Then MyErMacroStr a$, "need index for " + q$ + ")", "χρειάζομαι δείκτη για το πίνακα " + q$ + ")": IsStr1 = False: Exit Do Else If FastSymbol(a$, ",") Then IsStr1 = False MyErMacroStr a$, "too many indexes for array " + q$ + ")", "πολλοί δείκτες για το πίνακα " + q$ + ")" Exit Function End If If Not FastSymbol(a$, ")") Then MissSymbol ")": IsStr1 = False: Exit Function End If If p < -w1 Then toolow: MyErMacroStr a$, "index too low for array " + q$ + ")", "χαμηλός δείκτης στο πίνακα " + q$ + ")": Exit Function End If On Error Resume Next If Not pppp.PushOffset(w2, dn, CLng(Fix(p))) Then toohigh: MyErMacroStr a$, "index too high for array " + q$ + ")", "δείκτης υψηλός για το πίνακα " + q$ + ")" IsStr1 = False: Exit Function End If On Error GoTo 0 Else IsStr1 = False MyErMacroStr a$, "missing index for array " + q$ + ")", "χάθηκε δείκτης για το πίνακα " + q$ + ")" Exit Function End If dn = dn + 1 Loop cont12345: If ppppl.ItemIsObject(w2) Then If FastSymbol(a$, "(") Then If ppppl.ItemType(w2) = "lambda" Then Set anything = ppppl.item(w2) contlambdastr: PushStage bstackstr, False w1 = globalvarGroup("A_" & (Abs(w2)), 0#) Set var(w1) = anything If here$ = vbNullString Then dd = ModuleSubAsap("A_" & (Abs(w2)) & "$()", "", , w1) Else dd = ModuleSubAsap(here$ & "." & bstackstr.GroupName & "A_" & (Abs(w2)) & "$()", "", , w1) End If againlambda: 'a$ = "A_" & (Abs(w2)) & "$(" + a$ bstackstr.tmpstr = "A_" & (Abs(w2)) & "$(" + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) IsStr1 = IsStr1(bstackstr, a$, r$) If Typename(bstackstr.lastobj) = "lambda" Then If Left$(a$, 1) = "(" Then Mid$(a$, 1, 1) = " " Set var(w1) = bstackstr.lastobj Set bstackstr.lastobj = Nothing GoTo againlambda End If End If Set var(w1) = Nothing PopStage bstackstr ElseIf ppppl.ItemType(w2) = mHdlr Then Set bstackstr.lastobj = ppppl.item(w2) Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstackstr.lastobj Set bstackstr.lastobj = Nothing GoTo contStrArr ElseIf ppppl.ItemType(w2) = myArray Then Set ppppl = ppppl.item(w2) GoTo contStrArr ElseIf ppppl.ItemType(w2) = mGroup Then IsStr1 = SpeedGroup(bstackstr, ppppl, "VAL$", q$, a$, w2) = 1 r$ = bstackstr.LastValue Exit Function ElseIf ppppl.ItemType(w2) = mProp Then ' a$(2)(... p = 0 ppppl.SwapItem w2, p Set anything = p ppppl.SwapItem w2, p Set ppppl = New ppppLight Set ppppl.GroupRef = anything Set anything = Nothing ppppl.arr = False GoTo contreadprop ElseIf ppppl.ItemType(w2) = "ppppLight" Then Set ppppl = ppppl.item(w2) GoTo contreadprop End If ElseIf ppppl.ItemType(w2) = mGroup Then IsStr1 = SpeedGroup(bstackstr, ppppl, "VAL$", q$, "", w2) = 1 r$ = bstackstr.LastValue Exit Function ElseIf ppppl.ItemIsObject(w2) Then p = rValue(bstackstr, ppppl.itemObject(w2)) If bstackstr.lastobj Is Nothing Then If TypeOf ppppl.itemObject(w2) Is Document Then r$ = ppppl.item(w2) Else On Error Resume Next r$ = ppppl.item(w2) If Err > 0 Then Err.Clear r$ = CStr(ppppl.item(w2).Value) If Err Then MyEr "Can't fing value in this object", "Δεν μπορώ να βρω τιμή σε αυτό το αντικείμενο" IsStr1 = False Exit Function End If End If End If ElseIf IsObjmHandler(bstackstr.lastobj) Then Set usehandler = bstackstr.lastobj GoTo conthereHandler ElseIf TypeOf bstackstr.lastobj Is BigInteger Then SwapString2Variant r$, bstackstr.lastobj.ToString Set bstackstr.lastobj = Nothing End If IsStr1 = True Exit Function Else r$ = ppppl.item(w2) End If Else If ppppl.IsStringItem(w2) Then r$ = ppppl.item(w2) Else p = ppppl.item(w2) If myVarType(p, vbEmpty) Then r$ = "" Else If CheckInt64(p) Then r$ = CStr(p) ElseIf myVarType(p, vbBoolean) Then If ShowBooleanAsString Then r$ = format$(p, DefBooleanString) Else r$ = CStr(p * 1) End If Else r$ = fixthis(p) End If End If End If End If IsStr1 = True Exit Function Else contrightstrpar: If Typename(ppppl.GroupRef) = mHdlr Then Set usehandler = ppppl.GroupRef If usehandler.t1 <> 1 Then If usehandler.t1 = 3 Then Set ppppl = usehandler.objref Set usehandler = Nothing GoTo contStrArr ElseIf usehandler.t1 = 5 Then GoTo contStructtoo Else SyntaxError IsStr1 = False Exit Function End If End If ' only for Inventory If Not TypeOf usehandler.objref Is FastCollection Then Set ppppl.GroupRef = usehandler.objref Set usehandler = Nothing GoTo contrightstrpar End If ' Set usehandler = pppp.GroupRef contStructtoo: With usehandler.objref If IsExp(bstackstr, a$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then r$ = p: GoTo str00012344 If MemInt(VarPtr(p)) = vbBoolean Then p = CLng(p) If FastSymbol(a$, "!") Then If Abs(p) < .Count Then If p < 0 Then .index = .Count + MyRound(p) Else .index = MyRound(p) End If Else MyErMacroStr a$, "Index out of limits", "Δείκτης εκτός ορίων" IsStr1 = False Exit Function End If Else .Find p End If ElseIf IsStrExp(bstackstr, a$, r$) Then str00012344: .Find r$ End If If .Done Then If .IsObj Then If TypeOf .ValueObj Is lambda Then If FastSymbol(a$, ")(", , 2) Then Set anything = .ValueObj GoTo contlambdastr Else Set bstackstr.lastobj = .ValueObj End If ElseIf TypeOf .ValueObj Is iBoxArray Then Set ppppl = .ValueObj If FastSymbol(a$, ")(", , 2) Then GoTo contStrArr ElseIf TypeOf .ValueObj Is mHandler Then Set ppppl = New ppppLight Set ppppl.GroupRef = .ValueObj If FastSymbol(a$, ")(", , 2) Then GoTo contStrArr ElseIf TypeOf .ValueObj Is Document Then r$ = .ValueObj.textDoc ElseIf TypeOf .ValueObj Is Group Then Set usehandler = ppppl.GroupRef Set anything = usehandler.objref dd = anything.index Set ppppl = New ppppLight: ppppl.PushDim (1): ppppl.PushEnd: ppppl.arr = True Set pppp.item(0) = .ValueObj w2 = 0 IsStr1 = IsStr1 And FastSymbol(a$, ")") ' ???? ' why not = IsStr1 And SpeedGroup(bstackstr, pppp, "VAL$", q$, a$, w2) = 1 IsStr1 = SpeedGroup(bstackstr, ppppl, "VAL$", q$, a$, w2) = 1 r$ = bstackstr.LastValue anything.index = dd Set .ValueObj = ppppl.item(0) Set ppppl.item(0) = Nothing Exit Function ElseIf TypeOf .ValueObj Is PropReference Then .ValueObj.index = p r$ = .ValueObj.Value If .ValueObj.LastHasObject Then Set bstackstr.lastobj = .ValueObj.lastobj .ValueObj.clearlastobject End If IsStr1 = IsStr1 And FastSymbol(a$, ")") Else MyErMacroStr a$, "This kind of object not supported", "Αυτού του είδους το αντικείμενο δεν υποστηρίζεται" End If ElseIf usehandler.t1 <> 5 Then Call .ValueType(2, p, r$) Else r$ = CStr(.Value) End If Else MyErMacroStr a$, "Key Not Found", "Δεν βρέθηκε το κλειδί" End If End With ElseIf Typename(ppppl.GroupRef) = mGroup Then If Len(q$) > Len(ppppl.GroupRef.GroupName) Then If Len(ppppl.CodeName) > 0 Then If AscW(ppppl.CodeName) = 8191 Then q1$ = Left$(q$, Len(q$) - 2) + "." + ChrW(&H1FFF) + "$()" Else q1$ = ppppl.CodeName + "." + ChrW(&H1FFF) + "$()" End If Else q1$ = Left$(q$, Len(q$) - 2) + "." + ChrW(&H1FFF) + "$()" End If Else q1$ = ppppl.GroupRef.GroupName + ChrW(&H1FFF) + "$()" End If If GetSub(q1$, w1) Then Set nbstack = New basetask Set nbstack.Parent = bstackstr If bstackstr.IamThread Then Set nbstack.Process = bstackstr.Process Set nbstack.Owner = bstackstr.Owner nbstack.OriginalCode = w1 nbstack.UseGroupname = sbf(w1).sbgroup nbstack.tpointer = sbf(w1).tpointer nbstack.SetV If GoFunc(nbstack, q1$, a$, r$) Then If Not nbstack.StaticCollection Is Nothing Then bstackstr.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If 'Set bstackstr.lastobj = nBstack.lastobj Set nbstack = Nothing IsStr1 = True Else IsStr1 = False End If Else InternalError IsStr1 = False End If Exit Function Else contreadprop: If Not getindexes(bstackstr, ppppl.GroupRef, a$) Then On Error Resume Next p = CVar(ppppl.GroupRef.Value) If Err.Number > 0 Then ppppl.GroupRef.IndexAgain If Typename(ppppl.GroupRef.Value) = "Null" Then r$ = "" Err.Clear Else InStr = False MyEr Err.Description, Err.Description Err.Clear Exit Function End If Else If ppppl.GroupRef.LastHasObject Then Set bstackstr.lastobj = ppppl.GroupRef.lastobj ppppl.GroupRef.clearlastobject End If If Not bstackstr.lastobj Is Nothing Then If TypeOf bstackstr.lastobj Is BigInteger Then SwapString2Variant r$, bstackstr.lastobj.ToString Else r$ = "*" + Typename$(bstackstr.lastobj) End If ElseIf MemInt(VarPtr(p)) = vbString Then r$ = p Else r$ = fixthis(p) End If Set bstackstr.lastobj = Nothing End If Else Set bstackstr.lastobj = ppppl r$ = vbNullString End If End If IsStr1 = FastSymbol(a$, ")") Exit Function End If Else '...... skiperrorStr: If Right$(q1$, 1) = ")" Then If here$ Like "*." + q1$ Then subHash.ItemCreatorNoSwap q1$, bstackstr.OriginalCode, True GoTo contStrFun ElseIf q1$ = "LAMBDA$()" Then contlambda01: If bstackstr.IamLambda Then q1$ = bstackstr.FuncRec Else q1$ = Mid$(here$, rinstr(here$, "».") + 2) If Right$(here$, 2) = "()" And bstackstr.UseGroupname = vbNullString Then q1$ = sbf(bstackstr.OriginalCode).goodname w1 = bstackstr.OriginalCode ElseIf Not GetSub(q1$, w1) Then If here$ Like "*." + q1$ Then q1$ = sbf(bstackstr.OriginalCode).goodname w1 = bstackstr.OriginalCode Else GoTo skiperrorStr End If End If End If GoTo contStrFun ElseIf q1$ = "ΛΑΜΔΑ$()" Then GoTo contlambda01 ElseIf neoGetArray(bstackstr, Left$(q1$, Len(q1$) - 3) + "(", ppppl, , True) Then If Typename(ppppl.GroupRef) = mGroup Then If TypeOf ppppl Is iBoxArray Then q$ = Left$(q1$, Len(q1$) - 3) ppppl.CodeName = q$ End If End If GoTo contStrArr End If End If If strfunidbackup.Find(q$, w2) Then GoTo findthird cont112233: If Len(here$) > 0 Then q1$ = here$ + "." + q$ + ")" subHash.ItemCreatorNoSwap q1$, -1, True GoTo isasub End If cont334: If FindNameForGroup(bstackstr, q$) Then MyErMacroStr a$, "unknown method/array " + q$, "Άγνωστη μέθοδος/πίνακας " + q$ Else MyErMacroStr a$, "unknown function/array " + q$, "Άγνωστη συνάρτηση/πίνακας " + q$ End If Exit Function End If Case 106 isasub: If CurrentStackSize > stacksize Then MyEr "Function's Stack is Full - 15", "Η στοίβα των συναρτήσεων έχει γεμίσει - 15" MOUT = True IsStr1 = False: Exit Function End If PushStage bstackstr, False w1 = bstackstr.soros.Total If Not PushParamSUB(bstackstr, a$) Then PopStage bstackstr w1 = bstackstr.soros.Total - w1 If w1 > 0 Then bstackstr.soros.drop w1 IsStr1 = False: Exit Function End If If FastSymbol(a$, ")") Then w2 = bstackstr.OriginalCode w3 = w2 q1$ = bstackstr.originalname$ bstackstr.originalname$ = q2$ + ")" If gr Then q2$ = "ΣΥΝΑΡΤΗΣΗ " + q2$ Else q2$ = "FUNCTION " + q2$ End If If searchsub(0&, w2, q2$, w1, w2, n$, True) Then againsub: If Len(q2$) > 0 Then If Not MyRead7(bstackstr, q2$, 1) Then bstackstr.originalname$ = q1$ PopStage bstackstr IsStr1 = False Exit Function End If End If bstackstr.FuncValue = vbNullString Set bstackstr.FuncObj = Nothing dn = bstackstr.addlen bstackstr.RetStack.Push3long Len(a$), 0, Len(a$) - Len(n$) If trace Then q2$ = TestShowSub: sg1 = TestShowBypass If w2 > 0 Then bstackstr.addlen = Len(sbf(w2).sb) - w1 - Len(n$) + 1 TestShowSub = sbf(w2).sb ElseIf w2 = 0 Then bstackstr.addlen = 0 TestShowSub = n$ Else bstackstr.addlen = Len(var(-w2).Code) - w1 - Len(n$) + 1 TestShowSub = var(-w2).Code End If TestShowBypass = True dd = 1 Module10.executeblock dd, bstackstr, n$, False, False, , True SwapStrings q2$, TestShowSub: TestShowBypass = sg1 Else dd = 1 Module10.executeblock dd, bstackstr, n$, False, False, , True End If bstackstr.RetStackDrop 1 bstackstr.addlen = dn If dd > 0 Then IsStr1 = True Set bstackstr.lastobj = bstackstr.FuncObj Set bstackstr.FuncObj = Nothing If myVarType(bstackstr.FuncValue, vbString) Then r$ = bstackstr.FuncValue Else If bstackstr.lastobj Is Nothing Then If onlyString Then MissString: IsStr1 = False: Exit Function End If r$ = fixthis(bstackstr.FuncValue) End If bstackstr.FuncValue = Empty Else IsStr1 = False If bstackstr.ErrorOriginal = 0 Then LastErNum = -1 LastErNum1 = -1 bstackstr.ErrorOriginal = w2 If w2 > 0 Then a$ = n$ + space$(Len(sbf(w2).sb) - w1 + 1) ElseIf w2 = 0 Then a$ = n$ Else a$ = n$ + space$(Len(var(-w2).Code) - w1 + 1) End If End If Exit Function End If If usebackup Then If Not bstackstr.lastobj Is Nothing Then If InStr(q$, "$") = 0 Then GoTo Final End If End If ElseIf bstackstr.IamChild Then dn = FindPrevOriginal(bstackstr) If searchsub(w3, dn, q2$, w1, w2, n$, True) Then If dn <> w2 And w2 < 0 Then w2 = dn End If GoTo againsub Else If subHash.Count > 0 Then subHash.ReadVar subHash.Count - 1, q2$, dn If here$ + "." + q$ + ")" = q2$ Then GoTo cont334 End If End If q2$ = q$ GoTo nofun1 End If Else nofun1: MyEr "Function @" + Mid$(q2$, InStr(q2$, " ") + 1) + ") not found", "Η συνάρτηση @" + Mid$(q2$, InStr(q2$, " ") + 1) + ") δεν βρέθηκε" IsStr1 = False End If bstackstr.originalname$ = q1$ PopStage bstackstr Else IsStr1 = False End If Exit Function End Select If a$ = vbNullString Then IsStr1 = False: Exit Function IsStr1 = True End Function Function mDate(bstackstr As basetask, a$, r$) As Boolean Dim pp, p, s$ If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True) Then If MemInt(VarPtr(pp)) = vbString Then SwapString2Variant s$, pp pp = Clid GoTo here1 End If ElseIf LastErNum1 Then Exit Function ElseIf IsStrExp(bstackstr, a$, s$, False) Then pp = Clid GoTo here1 ElseIf LastErNum1 Then Exit Function Else pp = Clid End If If FastSymbol(a$, ",") Then If IsFlatStringExpr(bstackstr, a$, s$) Then here1: If UCase(s$) = "SHORT DATE" Then s$ = GetlocaleString2(&H1F, CLng(pp)) ElseIf UCase(s$) = "LONG DATE" Then s$ = GetlocaleString2(&H20, CLng(pp)) ElseIf s$ = "" Then s$ = GetlocaleString2(&H1F, CLng(pp)) ElseIf InStr(s$, "D") > 0 Or InStr(s$, "Y") > 0 Then r$ = format(CDate(p), s$) GoTo conthere ElseIf InStr(s$, "M") = 0 And InStr(s$, "d") = 0 And InStr(s$, "y") = 0 Then r$ = format(CDate(p), s$) GoTo conthere End If s$ = Replace(s$, "m", "M") s$ = Replace(s$, "D", "d") s$ = Replace(s$, "Y", "y") s$ = Replace(s$, "G", "g") ' era r$ = FormatDateWithLocale(s$, CDate(p), CLng(pp)) Else missParam a$ Exit Function End If Else r$ = FormatDateWithLocale(GetlocaleString2(&H1F, pp), CDate(p), pp) End If Else r$ = FormatDateWithLocale(GetlocaleString2(&H1F, Clid), CDate(p), Clid) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If conthere: mDate = FastSymbol(a$, ")") End Function Function ISSTRINGA(bb$, r$) As Boolean ' Dim q$, W As Long, i As Long, clearme As Boolean If Len(bb$) = 0 Then Exit Function i = MyTrimL(bb$) If i > Len(bb$) Then bb$ = "": Exit Function r$ = vbNullString Select Case AscW(Mid$(bb$, i, 1)) Case 1 q$ = Chr(1) Case 2 r$ = Mid$(bb$, i + 1, 8) r$ = Mid$(bb$, 9 + i, CLng("&H" + r$)) bb$ = Mid$(bb$, Len(r$) + 9 + i) ISSTRINGA = True Exit Function Case 34 q$ = Chr(34) End Select If q$ = vbNullString Or Len(bb$) - i < 1 Then bb$ = Mid$(bb$, i): ISSTRINGA = False: Exit Function If q$ = Chr(34) Then W = i Do W = W + 1 W = InStr(W, bb$, q$) If W > 0 Then If Mid$(bb$, W - 1, 1) <> "\" Then Exit Do Else clearme = True ElseIf W = 0 Then Exit Do End If Loop Else W = InStr(1 + i, bb$, q$, vbBinaryCompare) End If If W = 0 Then ISSTRINGA = False: Exit Function r$ = Mid$(bb$, 1 + i, W - (1 + i)) i = MyTrimLi(bb$, W + 1) bb$ = Mid$(bb$, i) 'bb$ = NLtrim$(Mid$(bb$, W + 1)) If clearme Then r$ = Replace(r$, "\" + """", """") ISSTRINGA = True End Function Function IsOperator(a$, c$, Optional cl As Long = 1) As Boolean If Len(a$) > 0 Then If Left$(a$, cl) = c$ Then a$ = NLtrim$(Mid$(a$, cl + 1)) IsOperator = True End If End If End Function Function IsOperator0(a$, c$, Optional cl As Long = 1) As Boolean Dim n$ If Len(a) > 0 Then If Left$(a$, cl) = c$ Then ' no letters in operator so no UCASE ' check next character n$ = Left$(Mid$(a$, cl + 1, 1) + " ", 1) If Not InStr(novalidstr, n$) > 0 Then a$ = NLtrim$(Mid$(a$, cl + 1)) IsOperator0 = True End If End If End If End Function Function IsOperatorNoRemove(a$, c$, Optional cl As Long = 1) As Boolean Dim n$ If Len(a) > 0 Then If Left$(a$, cl) = c$ Then ' no letters in operator so no UCASE ' check next character n$ = Left$(Mid$(a$, cl + 1, 1) + " ", 1) If Not InStr(novalidstr, n$) > 0 Then IsOperatorNoRemove = True End If End If End If End Function Function codeW(a$) As Long If a$ <> "" Then If AscW(a$) < 128 Then codeW = 1 End If End Function Function IsSymbol(a$, c$, Optional l As Long = 1, Optional mis As Boolean = False) As Boolean Dim i As Long, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i <= j Then If myUcase(Mid$(a$, i, l)) = c$ Then a$ = NLtrim$(Mid$(a$, l + i)) IsSymbol = True Else If mis Then MissSymbol c$ ElseIf i > 1 Then a$ = Mid$(a$, i) End If IsSymbol = False End If Else If mis Then MissSymbol c$ Else a$ = vbNullString End If IsSymbol = False End If End Function Function IsSymbolBracket(a$) As Boolean Dim i As Long, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then Exit Function If Mid$(a$, i, 1) = "{" Then a$ = Mid$(a$, i + 1) IsSymbolBracket = True End If End Function Private Function IsSymbol3(a$, c$) As Boolean ' SAME AS FASTSYMB WITHOUT trim after Dim i As Long, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then Exit Function If j - i > -1 Then If c$ = Mid$(a$, i, 1) Then a$ = Mid$(a$, i + 1) IsSymbol3 = True End If End If End Function ' Function Fast2NoSpace(a$, c$, cl As Long, D$, dl As Long, ahead&) As Boolean Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function Pad$ = myUcase(Left$(a$, ahead&)) If c$ = Left$(Pad$, cl) Then j = MyTrimLi(a$, cl + 1) check: If Len(Mid$(a$, j, 1)) > 0 Then Select Case AscW(Mid$(a$, j, 1)) Case 36, 37, 40, 46, 48 To 57, 95, Is < 0, Is > 64 Fast2NoSpace = False Case Else a$ = Mid$(a$, j) Fast2NoSpace = True End Select Else a$ = Mid$(a$, j) Fast2NoSpace = True End If Exit Function End If If D$ = Left$(Pad$, dl) Then j = MyTrimLi(a$, dl + 1) GoTo check End If End Function Function Fast3NoSpaceCheck(Pos As Long, a$, c$, cl As Long, D$, dl As Long, e$, el As Long, ahead&) As Boolean Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function Pad$ = myUcase(Mid$(a$, Pos, ahead&)) If c$ = Left$(Pad$, cl) Then Pos = Pos + cl Fast3NoSpaceCheck = True Exit Function End If If D$ = Left$(Pad$, dl) Then Pos = Pos + dl Fast3NoSpaceCheck = True Exit Function End If If e$ = Left$(Pad$, el) Then Pos = Pos + el Fast3NoSpaceCheck = True End If End Function Function Fast3NoSpace(a$, c$, cl As Long, D$, dl As Long, e$, el As Long, ahead&) As Boolean Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function Pad$ = myUcase(Left$(a$, ahead&)) If c$ = Left$(Pad$, cl) Then a$ = Mid$(a$, MyTrimLi(a$, cl + 1)) Fast3NoSpace = True Exit Function End If If D$ = Left$(Pad$, dl) Then a$ = Mid$(a$, MyTrimLi(a$, dl + 1)) Fast3NoSpace = True Exit Function End If If e$ = Left$(Pad$, el) Then a$ = Mid$(a$, MyTrimLi(a$, el + 1)) Fast3NoSpace = True End If End Function Function Fast2VarNoTrim(a$, c$, cl As Long, D$, dl As Long, ahead&, Pos As Long) As Boolean ' need space Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then Exit Function Pad$ = myUcase(Mid$(a$, i, ahead&)) + " " If j - i >= cl - 1 Then If InStr(c$, Left$(Pad$, cl)) > 0 Then If Mid$(Pad$, cl + 1, 1) = " " Then Mid$(a$, i) = space$(cl) Pos = 1 Fast2VarNoTrim = True Exit Function End If End If End If If dl = 0 Then Exit Function If j - i >= dl - 1 Then If InStr(D$, Left$(Pad$, dl)) > 0 Then If Mid$(Pad$, dl + 1, 1) = " " Then Mid$(a$, i) = space$(dl) Pos = 2 Fast2VarNoTrim = True End If End If End If End Function Function Fast2Varl(a$, c$, cl As Long, D$, dl As Long, ahead&, ByVal f As Long) As Boolean ' use F if dl>0 Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then a$ = vbNullString: Exit Function Pad$ = myUcase(Mid$(a$, i, ahead&)) If f = 2 Then GoTo there If j - i >= cl - 1 Then If Left$(Pad$, cl) = c$ Then i = i + cl If Len(a$) >= i Then Select Case AscW(Mid$(a$, i, 1)) Case Is < 36, 39, 41, 44, 47, 58, 61, 92, 123, 125, 160 Case Else Exit Function End Select End If a$ = Mid$(a$, MyTrimLi(a$, i)) Fast2Varl = True Exit Function End If End If If dl = 0 Or f = 1 Then Exit Function there: If j - i >= dl - 1 Then If Left$(Pad$, dl) = D$ Then i = i + dl If Len(a$) >= i Then Select Case AscW(Mid$(a$, i, 1)) Case Is < 36, 39, 41, 44, 47, 58, 61, 92, 123, 125, 160 Case Else Exit Function End Select End If a$ = Mid$(a$, MyTrimLi(a$, i)) Fast2Varl = True End If End If End Function Function Fast2VarSpace(a$, c$, cl As Long, D$, dl As Long, ahead&) As Boolean ' need always space Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then a$ = vbNullString: Exit Function Pad$ = myUcase(Mid$(a$, i, ahead&)) If j - i >= cl - 1 Then If Left$(Pad$, cl) = c$ Then If Mid$(Pad$, cl + 1, 1) = " " Then a$ = Mid$(a$, MyTrimLi(a$, i + cl)) Fast2VarSpace = True Exit Function End If End If End If If dl = 0 Then Exit Function If j - i >= dl - 1 Then If Left$(Pad$, dl) = D$ Then If Mid$(Pad$, dl + 1, 1) = " " Then a$ = Mid$(a$, MyTrimLi(a$, i + dl)) Fast2VarSpace = True End If End If End If End Function Function Fast3Varl(a$, c$, cl As Long, D$, dl As Long, e$, el As Long, ahead&) As Boolean Dim i As Long, Pad$, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then a$ = vbNullString: Exit Function Pad$ = myUcase(Mid$(a$, i, ahead&)) If j - i >= cl - 1 Then If Left$(Pad$, cl) = c$ Then a$ = Mid$(a$, MyTrimLi(a$, i + cl)) Fast3Varl = True Exit Function End If End If If dl = 0 Then Exit Function If j - i >= dl - 1 Then If Left$(Pad$, dl) = D$ Then a$ = Mid$(a$, MyTrimLi(a$, i + dl)) Fast3Varl = True End If End If If el = 0 Then Exit Function If j - i >= el - 1 Then If Left$(Pad$, el) = e$ Then a$ = Mid$(a$, MyTrimLi(a$, i + el)) Fast3Varl = True End If End If End Function Function ConstNew(bstack As basetask, b$, W$, makeallglobal As Boolean, Lang As Long) As Boolean Dim p As Variant, ii As Long, ss$, what As Long, vType As Boolean, gr As Group, w2 As Long, ohere$ Dim mAr As mArray, mtu As tuple, mha As mHandler Dim cv As Constant, skipconst As Boolean Do what = IsLabel(bstack, b$, W$) vType = False skipconst = False Select Case what Case 1, 4 If GetlocalVar(W$, ii) Then If IsConstant(var(ii)) Then If var(ii).SUBPord Then skipconst = True GoTo cont112 End If End If MyEr "Variable exist as local", "Η μεταβλητή υπάρχει ως τοπική" ConstNew = False Exit Function ElseIf GetVar(bstack, W$, ii, True) And makeallglobal Then If bstack.Vars < ii Then MyEr "Variable exist as global", "Η μεταβλητή υπάρχει ως γενική" ConstNew = False Exit Function End If End If p = 0 cont112: If IsLabelSymbolNew(b$, "ΩΣ", "AS", Lang) Then If IsLabelSymbolNew(b$, "ΑΡΙΘΜΟΣ", "DECIMAL", Lang) Then p = CDec(0) ElseIf IsLabelSymbolNew(b$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then p = 0# ElseIf IsLabelSymbolNew(b$, "ΑΠΛΟΣ", "SINGLE", Lang) Then p = 0! ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΚΟΣ", "BOOLEAN", Lang) Then what = 0 p = False ElseIf IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then what = 0 p = cInt64(0) Else what = 0 p = 0& End If ElseIf IsLabelSymbolNew(b$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then what = 0 p = 0 ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then p = 0@ ElseIf IsLabelSymbolNew(b$, "ΑΤΥΠΟΣ", "VARIANT", Lang) Then what = 0 vType = True p = 0 ElseIf IsLabelSymbolNew(b$, "ΓΡΑΜΜΑ", "STRING", Lang) Then what = 0 p = vbNullString ElseIf IsLabelSymbolNew(b$, "ΨΗΦΙΟ", "BYTE", Lang) Then what = 0 p = CByte(0) ElseIf IsLabelSymbolNew(b$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang) Then what = -1 Set p = ZeroBig Else MyEr "No type found", "δεν βρήκα τύπο" Exit Function End If If FastSymbol(b$, "=") Then If vType Or MemInt(VarPtr(p)) = vbString Then If ISSTRINGA(b$, ss$) Then p = ss$ GoTo conthere ElseIf MemInt(VarPtr(p)) = vbString Then MissString Exit Function End If End If If Not IsNumberD2(b$, p, True) Then missNumber: Exit Function Else If MemInt(VarPtr(p)) = vbString Then MissString Else missNumber End If Exit Function End If If what = 4 Then If VarType(p) <> vbBoolean Then p = Int(p) End If GoTo conthere ElseIf FastSymbol(b$, "=") Then If Not IsExp(bstack, b$, p) Then If Not IsStrExp(bstack, b$, ss$, False) Then MissNumExpr Exit Function Else p = CVar(ss$) End If End If ElseIf GetVar(bstack, W$, ii, True) Then p = var(ii) Else MyEr "No global const found", "Δεν βρέθηκε γενική σταθερή" Exit Function End If conthere: If skipconst Then Set bstack.lastobj = Nothing GoTo nextconst ElseIf Not bstack.lastobj Is Nothing Then makelambda: If Typename(bstack.lastobj) = "lambda" Then Set cv = New Constant cv.DefineOnce bstack.lastobj Set bstack.lastobj = Nothing ii = globalvar(W$, p, , makeallglobal) If makeallglobal Or here$ = vbNullString Then GlobalSub W$ + "()", "", , , ii Else GlobalSub here$ + "." + W$ + "()", "", , , ii End If ElseIf Typename(bstack.lastobj) = "Group" Then Set cv = New Constant Set gr = bstack.lastobj If gr.IamApointer Then Set gr = gr.link If gr Is NullGroup Then Set gr = New Group gr.BeginFloat 0 gr.EndFloat cv.DefineOnce gr ElseIf gr.IamFloatGroup Then cv.DefineOnce gr Else ohere$ = here$ here$ = gr.lasthere If GetVar(bstack, gr.GroupName, w2, , , True) Then CopyGroup2 gr, bstack End If here$ = ohere$ End If Else cv.DefineOnce gr End If Set bstack.lastobj = Nothing ii = globalvar(W$, p, , makeallglobal) ElseIf Typename(bstack.lastobj) = "BigInteger" Then Set cv = New Constant Set p = CopyBigInteger(bstack.lastobj) Set bstack.lastobj = Nothing cv.DefineOnce p ii = globalvar(W$, p, , makeallglobal) ElseIf IsmHandler(bstack.lastobj) Then Set mha = bstack.lastobj Set bstack.lastobj = Nothing If mha.t1 = 3 Then mha.ReadOnly = True Set cv = New Constant Set p = mha ii = globalvar(W$, p, , makeallglobal) cv.DefineOnce p, , True If TypeOf mha.objref Is mArray Then Set mAr = mha.objref ' Set mha.objref = Nothing If Not mAr.Unique Then Set mha.objref = mAr Set mAr = New mArray mha.objref.CopyArray mAr End If Set mha.objref = mAr ElseIf TypeOf mha.objref Is tuple Then Set mtu = mha.objref ' Set mha.objref = Nothing If Not mtu.Unique Then Set mha.objref = mtu Set mtu = New tuple mha.objref.CopyArray mtu End If Set mha.objref = mtu End If Else WrongType Exit Function End If Else Set bstack.lastobj = Nothing Set cv = New Constant ii = globalvar(W$, p, , makeallglobal) cv.DefineOnce p End If Else Set bstack.lastobj = Nothing Set cv = New Constant If what = 4 Then cv.DefineOnce MyRound(p) Else If vType Then cv.DefineOnce p, vType Else If what = -1 Then Set p = Module13.CreateBigInteger(CStr(p)) If Len(b$) > 0 Then If UCase$(Left$(b$, 1)) = "U" Then Mid$(b$, 1, 1) = " " End If End If End If cv.DefineOnce p End If End If ii = globalvar(W$, p, , makeallglobal) End If Set var(ii) = cv ConstNew = True Case 3 If GetlocalVar(W$, ii) Then If IsConstant(var(ii)) Then If var(ii).SUBPord Then skipconst = True GoTo cont113 End If End If MyEr "Variable exist as local", "Η μεταβλητή υπάρχει ως τοπική" ConstNew = False Exit Function ElseIf GetVar(bstack, W$, ii, True) And makeallglobal Then If bstack.Vars < ii Then MyEr "Variable exist as global", "Η μεταβλητή υπάρχει ως γενική" ConstNew = False Exit Function End If End If If FastSymbol(b$, "=") Then If Not IsStrExp(bstack, b$, ss$) Then MissStringExpr: Exit Function ElseIf GetVar(bstack, W$, ii, True) Then ss$ = var(ii) Else MyEr "No global const found", "Δεν βρέθηκε γενική σταθερή" Exit Function End If cont113: If skipconst Then Set bstack.lastobj = Nothing GoTo nextconst End If If Not bstack.lastobj Is Nothing Then GoTo makelambda Set bstack.lastobj = Nothing Set cv = New Constant cv.DefineOnce ss$ ii = globalvar(W$, p, , makeallglobal) Set var(ii) = cv ConstNew = True Case Else MyErMacro b$, "No constant for that type " + W$, "Όχι σταθερή για αυτό το τύπο " + W$ Exit Function End Select nextconst: If Not FastSymbol(b$, ",") Then Exit Do DropCommentOrLine b$ Loop End Function Function ConstNewParam(bstack As basetask, b$, W$) As Boolean 'If FastSymbol(b$, ":=", , 2) before Dim p As Variant, ii As Long, ss$, what As Long, vType As Boolean, gr As Group, w2 As Long, ohere$ Dim cv As Constant Select Case Right$(W$, 1) Case "$" what = 3 Case Else what = 1 End Select what = IsLabel(bstack, (W$), ss$) vType = False FastSymbol b$, ":=", , 2 Select Case what Case 1 p = 0 If Not IsExp(bstack, b$, p) Then If Not IsStrExp(bstack, b$, ss$, False) Then MissNumExpr Exit Function Else p = CVar(ss$) GoTo cont11 End If End If here: If Not bstack.lastobj Is Nothing Then makelambda: If Typename(bstack.lastobj) = "lambda" Then Set cv = New Constant cv.DefineOnce bstack.lastobj, , True Set bstack.lastobj = Nothing ii = globalvar(W$, p) If here$ = vbNullString Then GlobalSub W$ + "()", "", , , ii Else GlobalSub here$ + "." + W$ + "()", "", , , ii End If ElseIf Typename(bstack.lastobj) = "Group" Then Set cv = New Constant Set gr = bstack.lastobj If gr.IamApointer Then Set gr = gr.link If gr Is NullGroup Then Set gr = New Group gr.BeginFloat 0 gr.EndFloat cv.DefineOnce gr, , True ElseIf gr.IamFloatGroup Then cv.DefineOnce gr, , True Else ohere$ = here$ here$ = gr.lasthere If GetVar(bstack, gr.GroupName, w2, , , True) Then CopyGroup2 gr, bstack End If here$ = ohere$ End If Else cv.DefineOnce gr, , True End If Set bstack.lastobj = Nothing ii = globalvar(W$, p) ElseIf Typename(bstack.lastobj) = "BigInteger" Then Set cv = New Constant Set p = CopyBigInteger(bstack.lastobj) Set bstack.lastobj = Nothing cv.DefineOnce p, , True ii = globalvar(W$, p) ElseIf IsmHandler(bstack.lastobj) Then If bstack.lastobj.t1 = 3 Then Set cv = New Constant Set p = bstack.lastobj Set bstack.lastobj = Nothing ii = globalvar(W$, p) cv.DefineOnce p, , True Else Set bstack.lastobj = Nothing WrongType Exit Function End If Else Set bstack.lastobj = Nothing Set cv = New Constant ii = globalvar(W$, p) cv.DefineOnce p, , True End If Else Set bstack.lastobj = Nothing Set cv = New Constant If what = 4 Then cv.DefineOnce MyRound(p), , True Else If vType Then cv.DefineOnce p, vType, True Else cv.DefineOnce p, , True End If End If ii = globalvar(W$, p) End If Set var(ii) = cv ConstNewParam = True Case 3 If Not IsStrExp(bstack, b$, ss$, False) Then MissStringExpr: Exit Function cont11: If Not bstack.lastobj Is Nothing Then GoTo makelambda Set bstack.lastobj = Nothing Set cv = New Constant cv.DefineOnce ss$, , True ii = globalvar(W$, p) Set var(ii) = cv ConstNewParam = True End Select End Function Sub ConnectStatic(bstack As basetask, ByVal what$) ''what$ = "%_" + what$ Dim vvv As Variant, Parent As basetask, parent1 As basetask Set Parent = bstack.Parent Do While Not Parent Is Nothing If Parent.StaticInUse$ = what$ Then Set bstack.StaticCollection = Parent.StaticCollection bstack.StaticInUse$ = what$ bstack.OriginalCode = Parent.OriginalCode Exit Do End If Set Parent = Parent.Parent Loop Set Parent = Nothing End Sub Function Execute(bstack As basetask, b$, once As Boolean, Optional linebyline As Boolean, Optional loopthis As Boolean = False, Optional noblock As Boolean = True, Optional restartmodule As Boolean, Optional onlyone As Boolean = False) As Long Dim di As Object, nchr As Integer Set di = bstack.Owner Dim myobject As Object, usehandler As mHandler, usehandler1 As mHandler If checkbreak(bstack, b$, once) Then GoTo enterbreak Dim pppp As mArray, ppppl As iBoxArray, bb$, ec$, i As Long, jump As Boolean, slct As Long, sp As Variant, sw$, ok As Boolean, IFCTRL As Long 'If linebyline Then If loopthis Or linebyline And Not noblock Then IFCTRL = bstack.IFCTRL: jump = bstack.jump Dim W$, LLL As Long, sss As Long, v As Long, p As Variant, ss$, lbl As Boolean, st As Variant, bs As basetask Dim sx, VarStat As Boolean, NewStat As Boolean, noVarStat As Boolean Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long, SBB$, nd&, Lang As Long, kolpo As Boolean, iscom As Boolean Dim temphere$, one As Boolean, likebasic As Boolean: likebasic = bstack.BasicSwitch Dim subs As FastCollection If loopthis Then Execute = 2 Else Execute = 1 againexecute: sss = Len(b$): lbl = True Do While Len(b$) <> LLL If checkbreakEsc(bstack) Then enterbreak: NOEXECUTION = False MyClear bstack, "" NOEXECUTION = True MyEr "", "" k1 = 0 REFRESHRATE = 40 SLOW = False extreme = False If MOUT Then TaskMaster.Dispose 'NOEXECUTION = False MOUT = False MKEY$ = "@Start" + Chr$(13) 'b$ = "@Start : error {}" once = False Prefresh(GetCode(bstack.Owner)).k1 = 0 MyDoEvents0 bstack.Owner MyEr "", "" LLL = 0 'NOEXECUTION = True Execute = 0 Exit Function Else myesc b$ If once Then b$ = vbCrLf + b$ ' this cause troubles... Execute = 0 Else once = True Execute = 1 End If Exit Function End If End If If (trace And Not stoponerror) Or SLOW Then If WaitShow > 0 Then WaitShow = WaitShow - 1 refreshGui If IsWine Then MyDoEvents1 di ElseIf trace And Not bypasstrace Then MyDoEvents0new di ' change from simple to version 2\ change to mydoevents0 Else MyDoEvents1 di End If End If again1: If LastErNum <> 0 Then 'Execute = False Exit Function End If 'If Not b$ = vbCrLf Then lbl = Left$(b$, 1) <> ":" againExtra: If DropCommentOrLine(b$) Then ', True NewStat = False VarStat = False noVarStat = False End If againExtra2: LLL = Len(b$) sss = LLL i = 0 If LLL = 0 Then Exit Do If MaybeIsSymbol2(b$, a123, i) Then If Mid$(b$, i, 1) = "=" Then b$ = Mid$(b$, MyTrimLi(b$, i + 1)) If (InStr(bstack.originalname$, "(") > 1) Then ' return from a function no error checking x1 = 0 If GetReturnArray(bstack, x1, b$, p, ss$, pppp) Then Execute = 0: Exit Function If LastErNum <> 0 Then GoTo myerr1 End If If once Then Exit Function End If If Len(b$) > 0 Then GoTo loopcontinue ElseIf Mid$(b$, i, 1) = "-" Then If Mid$(b$, i + 1, 1) = ">" Then b$ = Mid$(b$, MyTrimLi(b$, i + 2)) If (InStr(bstack.originalname$, "(") > 1) Then x1 = 0 If Not GetPointer(bstack, b$) Then Execute = 0: Exit Function If bstack.lastpointer Is Nothing Then MissingGroup: Execute = 0: Exit Function Set bstack.FuncObj = bstack.lastpointer bstack.FuncValue = 0& Set bstack.lastpointer = Nothing Set bstack.lastobj = Nothing If once Then Exit Function End If GoTo loopcontinue Else SyntaxError Execute = 0 Exit Function End If Else b$ = Mid$(b$, MyTrimLi(b$, i + 1)) i = 0 If MaybeIsSymbol3(b$, "}", i) Then ' If checkbreakEsc(bstack) Then Execute = 1: b$ = vbNullString: Exit Function b$ = Mid$(b$, MyTrimLi(b$, i + 1)) sss = Len(b$) lbl = False GoTo againExtra End If If Module10.executeblock(Execute, bstack, b$, once, kolpo) Then Exit Function End If '' WHY 4??? ''If Execute = 4 Then b$ = "{" + b$: Exit Function If kolpo Then ec$ = block(b$) If Execute = 2 And Len(b$) > 0 Then Exit Function If Not FastSymbol(b$, "}") Then Execute = 0: Exit Function Else DropCommentOrLine b$, True sss = Len(b$) 'If Not MaybeIsSymbol(b$, b12345) Then SyntaxError: Execute = 0: Exit Function lbl = False End If If NocharsInLine(b$) Then Exit Function sss = LLL 'basic... If jump Or IFCTRL = 2 Then jump = False i = 1 While FastOperator(b$, vbCrLf, i, 2) Wend If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse If i > 0 Then lbl = True End If If linebyline Then Exit Do End If End If contVarNew: If MaybeIsSymbol(b$, "/\'") Then NewStat = False VarStat = False noVarStat = False SetNextLine b$ sss = Len(b$) lbl = True If jump Or IFCTRL = 2 Then If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse End If If sss > 0 Then GoTo again1 GoTo JUMPHERE ElseIf FastSymbol(b$, ":") Then NewStat = False VarStat = False noVarStat = False sss = Len(b$) If sss > 0 Then GoTo againExtra GoTo JUMPHERE End If jumpforCR: If ReplaceCRLFSPACE(b$) Then If Len(b$) = 0 Then GoTo JUMPHERE End If NewStat = False VarStat = False noVarStat = False sss = LLL: lbl = True: jump = False If IsNumberLabel(b$, W$) Then If FastSymbol(b$, vbCrLf, , 2) Then GoTo againexecute sss = Len(b$): sss = LLL: lbl = False: jump = False: If sss = 0 Then sss = 2: b$ = vbCrLf End If Else If lbl Then If IsNumberLabel(b$, W$) Then If IFCTRL = 2 Then once = False b$ = W$ Execute = 2 Exit Function Else sss = Len(b$): sss = LLL: jump = False: If sss = 0 Then sss = 2: b$ = vbCrLf End If End If End If End If If VarStat Or NewStat Or noVarStat Then If FastSymbol(b$, ",") Then sss = LLL: lbl = False: jump = False If Not onlyone Or linebyline Then DropCommentOrLine b$ LLL = Len(b$) End If jump101: ElseIf FastOperator(b$, ":", 1) Then entry1: NewStat = False VarStat = False noVarStat = False GoTo contconthere ElseIf NocharsInLine(b$) Then SetNextLine b$ If b$ <> "" Then GoTo again1 Else PlaceAcommaBefore Execute = 0 Exit Function End If one = True iscom = True Select Case IsLabelDotSub(temphere$, b$, W$, ss$, (Lang), nchr) Case 0 one = False VarStat = False NewStat = False noVarStat = False GoTo contconthere Case 1234 VarStat = False NewStat = False noVarStat = False GoTo contconthere Case 1 If Left$(W$, 1) = "." Then ss$ = W$ IsLabel bstack, ss$, W$ End If GoTo VarOnly Case 2 noref Execute = 0 Exit Function Case 3 GoTo contcase3 Case 4 GoTo contcase4 Case 5 GoTo contcase5 Case 6 GoTo contcase6 Case 7 GoTo contcase7 Case 10 GoTo contcase10 Case Else GoTo errstat End Select ElseIf FastSymbol(b$, ":") Then contconthere: NewStat = False: VarStat = False: noVarStat = False: sss = LLL: lbl = False: jump = False: If sss = 0 Then sss = 2: b$ = vbCrLf End If again2: If lookOne(b$, "@") Then W$ = vbNullString GoTo parsecommand End If again3: one = True x1 = IsLabelDotSub(temphere$, b$, W$, ss$, Lang, nchr) again4: bstack.LastIdpos = Len(b$) Select Case x1 Case 0 If FastSymbol(b$, "(") Then ' global/local i = 1 x1 = 0 While Len(aheadstatus(b$, False, i)) > 0 x1 = i - 1 i = i + 1 Wend ss$ = Left$(b$, x1) If x1 > 0 And MyTrim(ss$) <> vbNullString Then Mid$(b$, 1, x1) = space$(x1) If FastSymbol(b$, ")", True) Then If FastSymbol(b$, "=") Then If IsExp(bstack, b$, p) Then If Not bstack.lastobj Is Nothing Then If IsobjArray(bstack.lastobj) Then Set ppppl = bstack.lastobj GoTo wehavearray ElseIf TypeOf bstack.lastobj Is mHandler Then If CheckAnyArray(bstack.lastobj) Then Set usehandler = bstack.lastobj Set ppppl = usehandler.objref wehavearray: Set bstack.lastobj = Nothing Set myobject = bstack.soros Set bstack.Sorosref = NewmStiva bstack.soros.MergeBottomCopyArray ppppl If Not MyRead(1, bstack, ss$, 1) Then Set bstack.lastobj = Nothing Set bstack.Sorosref = myobject Execute = 0 Exit Function End If Set bstack.lastobj = Nothing Set bstack.Sorosref = myobject Set myobject = Nothing GoTo loopagain Else a123321: NotArray Execute = 0 Exit Function End If End If End If End If End If End If End If GoTo a123321 End If one = False Case 1234 GoTo jumpforCR Case 2 NoRef2 Execute = 0 Exit Function Case 1 If sss = LLL Then If lbl Then If lookA123(b$) Then sw$ = GetNextLine(b$) LLL = Len(b$): sss = LLL: GoTo again1 End If End If If Trim$(W$) = vbNullString Then Execute = 1 Exit Function End If If trace Then If Not bypasstrace Then tragain: If Not TraceThis(bstack, di, b$, ss$, SBB$) Then Execute = 0: Exit Function If NOEXECUTION Then b$ = "" If Len(tracecode) > 0 Then ss$ = tracecode tracecode = vbNullString bypasstrace = True PushErrStage bstack Execute = Module10.executeblock(Execute, bstack, ss$, once, kolpo, , , True) PopErrStage bstack 'bypasstrace = False: Exit Function 'End If bypasstrace = False tracecode = vbNullString If NOEXECUTION Then Exit Function once = False MOUT = False ' NOEXECUTION = False NERR = False LastErNum = 0 LastErNum1 = 0 bstack.ErrorOriginal = 0 If LastErName <> "" Then LastErName = Chr(0) + LastErName If LastErNameGR <> "" Then LastErNameGR = Chr(0) + LastErNameGR If Execute = 2 Then ' do nohing End If Execute = 1 If trace Then GoTo tragain End If End If End If iscom = False If Left$(W$, 1) = "." Then If Not expanddot(bstack, W$) Then toomanydots Execute = 0 Exit Function End If iscom = True lbl = False GoTo VarOnly ElseIf Len(temphere$) > 0 Then iscom = True lbl = False VarStat = True GoTo VarOnly ElseIf Not NoOptimum Then v = 0 If MaybeIsSymbolNoSpace(b$, "[+/*~-]") Then GoTo VarOnly ElseIf MaybeIsSymbol(b$, "<=_") Then GoTo VarOnly ElseIf Not comhash.Find2(W$, i, v) Then iscom = True lbl = False GoTo VarOnly ElseIf i <> 0 Then If IsBadCodePtr(i) = 0 Then On Error GoTo myerr1 If CallByPtr(i, bstack, b$, Lang) Then LLL = 0 ' maybe b$ changed inside the call if LLL=len(b$) then we exit from loop GoTo conthere222 Else myerr1: If bstack Is Nothing Then Exit Function If LastErNum1 = -1 And bstack.IamThread Then Execute = 1 Else Execute = 0 If Err Then GoTo errstat0 Else Exit Function End If On Error GoTo errstat0 Else GoTo parsecommand End If ElseIf v <> 0 Then On v GoTo contif, ContElse, contElseIf, contSelect, ContTry, ForCont, contNext, contRefr, contWhile, ContRepeat, ContGoto, contSub, autogosub, ContOn, contLoop, contBreak, CONTcontinue, ContRestart, ContReturn, ContEnd, ContExit, ContInline, contUpdate, contThread, contAfter, contPart, contStatic, contEvery, contTask, ContScan, contTarg, BypassGlobalComm, BypassComm, contNegLocal, contNegGlobal, makeconst, VarOnly, contCall, contBinary, contHALT, contSTOP, contDraw, contVar, contClass, ContBASIC, ContRestore, ContCaseGr, ContCaseEN Execute = 0: Exit Function contClass: one = True iscom = True noVarStat = True sss = LLL: lbl = False: jump = False If Not onlyone Or linebyline Then DropCommentOrLine b$ LLL = Len(b$) End If GoTo VarOnly BypassGlobalComm: iscom = True GoTo parsecommand BypassComm: If bstack.commnum = 0 Then W$ = "@" + W$ ElseIf bstack.commnum > comhash.index Then W$ = "@" + W$ Else iscom = True End If GoTo parsecommand Else GoTo parsecommand End If End If Select Case W$ Case "STOP", "ΔΙΑΚΟΠΗ" contSTOP: If HaltLevel = 0 Then If trace Then GoTo notask If MsgBoxN("[STOP] Μ2000 - Temporary Execution Stop / Προσωρινή Κράτηση Εκτέλεσης" + vbCrLf + "use Exit to Return / χρησιμοποίησε το έξοδος για επιστροφή", vbYesNo, MesTitle$) = vbYes Then notask: Set bs = bstack HaltLevel = HaltLevel + 1 crNew bstack, players(GetCode(bstack.Owner)) Form1.MyPrompt "", UserName + " (exit)>", bstack HaltLevel = HaltLevel - 1 Set bstack = bs If ExTarget Then NOEXECUTION = True ElseIf HaltLevel < 0 Then b$ = "START" Execute = 1 ok = True Exit Do Else ExTarget = False MOUT = False End If End If Else ExTarget = False MOUT = False End If Case "HALT", "ΑΛΤ" contHALT: ss$ = here$ HaltLevel = HaltLevel + 1 Form1.MyPrompt "", ">>" HaltLevel = HaltLevel - 1 If HaltLevel < 0 Then b$ = "START" Execute = 1 ok = True Exit Do Else here$ = ss$ ExTarget = False MOUT = False End If Case "TARGET", "ΣΤΟΧΟΣ" contTarg: targetsMyExec Execute, b$, bb$, v, di, W$, bstack, VarStat, temphere$ If Execute = 0 Then Exit Function Case "SCAN", "ΣΑΡΩΣΕ" ContScan: ClearJoyAll PollJoypadk If GetForegroundWindow <> Form1.hWnd Or Not Targets Then If IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then End If MyDoEvents0 di If Fkey > 0 Then If FK$(Fkey) <> "" Then If bstack.IamChild And bstack.IamAnEvent And Fkey = 13 And lastAboutHTitle <> "" Then abt = True Fkey = 0 vHelp Else 'If Not trace Then ss$ = FK$(Fkey) Fkey = 0 If TaskMaster Is Nothing Then If Not interpret(Basestack1, ss$) Then Execute = 0 Exit Function End If Else TaskMaster.StopProcess If Not interpret(Basestack1, ss$) Then Execute = 0 End If TaskMaster.StartProcess If Execute = 0 Then Exit Function End If End If End If Fkey = 0 End If Else If di.Visible = False Then di.Visible = True NoAction = False nomore = True If IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then sx = Timer + p x1 = Form1.lockme If x1 Then UnHook Form1.hWnd Form1.lockme = False Do y1 = BLOCKkey BLOCKkey = True MyDoEvents0 Form1 BLOCKkey = y1 If exWnd <> 0 Then ss$ = MyTitle$(bstack) If Fkey > 0 Then If FK$(Fkey) <> "" Then b$ = FK$(Fkey) + b$ Fkey = 0 Exit Do End If End If Loop Until NoAction Or Timer > sx Or myexit(bstack) Or bstack.IamThread Form1.lockme = x1 If x1 And GetForegroundWindow = Form1.hWnd Then Form1.hookme Form1.TEXT1.glistN Else Do MyDoEvents0 Form1 If exWnd <> 0 Then ss$ = MyTitle$(bstack) If Fkey > 0 Then If FK$(Fkey) <> "" Then b$ = FK$(Fkey) + b$ Fkey = 0 Exit Do End If End If Loop Until NoAction Or myexit(bstack) End If nomore = False End If Case "REFRESH", "ΑΝΑΝΕΩΣΗ" contRefr: If IsLabelSymbolNew(b$, "ΔΟΚΙΜΗ", "TEST", Lang) Then MyDoEvents1 di ElseIf IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then With Prefresh(GetCode(di)) If Int(p) = 0# Then Call GetSystemTimeAsFileTime(basictimer) .k1 = basictimer + REFRESHRATE Else REFRESHRATE = p .k1 = 0 bstack.RRCOUNTER = 0 If bstack.IamThread Then MyDoEvents0 di Else MyDoEvents1 di End If End If End With Else Prefresh(GetCode(di)).RRCOUNTER = 0 MyDoEvents0 di bstack.RRCOUNTER = 0 End If If exWnd <> 0 Then ss$ = MyTitle$(bstack) End If If Fkey > 0 Then If FK$(Fkey) <> "" Then MKEY$ = MKEY$ + FK$(Fkey) Fkey = 0 Case "ΣΤΑΤΙΚΗ", "ΣΤΑΤΙΚΕΣ", "STATIC" contStatic: StaticNew bstack, b$, W$, Lang Case "ΝΗΜΑ", "THREAD" contThread: ss$ = vbNullString If IsLabelSymbolNewExp(b$, "ΘΕΣΕ", "SET", Lang, ss$) Then If bstack.Process Is Nothing Then GoTo dothesame If Not StaticNew(bstack, b$, W$, Lang) Then Execute = 0: Exit Function ElseIf IsLabelSymbolNewExp(b$, "ΑΥΤΟ", "THIS", Lang, ss$) Then If bstack.Process Is Nothing Then dothesame: b$ = vbNullString NoThisInThread Execute = 0: Exit Function once = False ElseIf IsLabelSymbolNewExp(b$, "ΣΒΗΣΕ", "ERASE", Lang, ss$) Then If Not bstack.Process Is Nothing Then Set bstack.Process.Process = Nothing End If GoTo exitfromhere ElseIf IsLabelSymbolNewExp(b$, "ΚΡΑΤΑ", "HOLD", Lang, ss$) Then bstack.Process.Busy = True ElseIf IsLabelSymbolNewExp(b$, "ΞΕΚΙΝΑ", "RESTART", Lang, ss$) Then bstack.Process.Busy = False b$ = vbNullString ElseIf IsLabelSymbolNewExp(b$, "ΚΑΘΕ", "INTERVAL", Lang, ss$) Then If IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then If p < 2 Then p = 2 bstack.Process.Interval = p Else b$ = vbNullString MisInterval Execute = 0: Exit Function End If Else b$ = vbNullString NoClauseInThread Execute = 0: Exit Function End If Else If linebyline Then b$ = W$ + " " + b$ Execute = Execute(bstack, b$, once, False) Exit Do End If If Not MyThread(bstack, b$, Lang) Then Execute = 0: Exit Function If Left$(here$ + "#", 1) = "!" Then here$ = Mid$(here$, 2) End If Case "LOOP", "ΚΥΚΛΙΚΑ" contLoop: If noblock Then loopthis = True Execute = 2 ' If checkbreakEsc(bstack) Then Execute = 1: b$ = vbNullString: Exit Function Else Execute = 5: Exit Function End If Case "BREAK", "ΔΙΕΚΟΨΕ" contBreak: restartmodule = False 'If bstack.SubLevel > 0 Then ' WaitShow = 0 ' PopStagePartContinue2 bstack, bstack.RetStackTotal ' once = False ' b$ = Chr$(0) ' If bstack.RetStackTotal = 0 Then Execute = 1 Else Execute = 2 'Else b$ = "BREAK" once = True Execute = 2 ' End If Exit Function Case "CONTINUE", "ΣΥΝΕΧΙΣΕ" CONTcontinue: restartmodule = False If Execute <> 2 Then b$ = "CONTINUE" once = True Execute = 3 Else b$ = vbNullString End If Exit Function Case "RESTART", "ΞΕΚΙΝΑ" ContRestart: b$ = vbNullString If restartmodule Then restartmodule = False loopthis = True End If Execute = 2 Exit Function Case "RETURN", "ΕΠΙΣΤΡΟΦΗ" ContReturn: LastErNum = 0 If IsExp(bstack, b$, p) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant ss$, p Set bstack.lastobj = Nothing GoTo contRet1 End If If bstack.lastobj Is Nothing Then BadUseofReturn Execute = 0 Exit Function ElseIf Typename(bstack.lastobj) = mHdlr Then Select Case bstack.lastobj.t1 Case 1 If ChangeValues(bstack, b$) Then GoTo loopcontinue Case 2 If ChangeValuesMem(bstack, b$, Lang) Then GoTo loopcontinue Case 3 If ChangeValuesArray(bstack, b$) Then GoTo loopcontinue Case 4 NoProperObject Set bstack.lastobj = Nothing Execute = 0 Exit Function End Select End If BadUseofReturn Execute = 0 Exit Function ElseIf IsStrExp(bstack, b$, ss$) Then contRet1: append_table bstack, ss$, b$, True, Lang Else If LastErNum <> 0 Then LLL = Len(b$) - 1 Else If bstack.RetStackTotal = 0 Then stackproblem Execute = 0 Exit Function Else PopStagePartContinue2 bstack, bstack.RetStackTotal End If once = False b$ = Chr$(0) Execute = 2 Exit Function End If End If Case "ΜΕ" ContCaseGr: If HaveMarkSelGr(bstack) Then loopthis = IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "", 0) ' we return as case or case else Execute = 100 Exit Function ElseIf Not MyWith(bstack, b$, 0&) Then Execute = 0 ' ?? Exit Function End If Case "CASE" ContCaseEN: If HaveMarkSelEn(bstack) Then loopthis = IsLabelSymbolNew(b$, "", "ELSE", 1) ' we return as case or case else Execute = 100 Exit Function Else NoCommandOrBlock Execute = 1 ' ?? Exit Function End If Case "END", "ΤΕΛΟΣ" ContEnd: WaitShow = 0 W$ = vbNullString If IsLabelSymbolNewExp(b$, "ΑΝ", "IF", Lang, W$) Then If bstack.UseofIf > 0 Then If Not HaveMark2(bstack) Then MissIF Execute = 0: Exit Function End If bstack.UseofIf = bstack.UseofIf - 1 Else MissIF Execute = 0: Exit Function End If lbl = False If Len(b$) > 0 Then If Left$(b$, 2) = vbCrLf Then lbl = True End If ElseIf IsLabelSymbolNewExp(b$, "ΡΟΥΤΙΝΑΣ", "SUB", Lang, W$) Then once = False b$ = Chr$(0) Execute = 2 Exit Function ElseIf IsLabelSymbolNewExp(b$, "ΕΠΙΛΟΓΗΣ", "SELECT", Lang, W$) Then If HaveMarkSel(bstack) Then Execute = 51 once = True Exit Function Else NoCommandOrBlock Execute = 1 ' ?? Exit Function End If ElseIf IsLabelSymbolNewExp(b$, "ΣΥΝΑΡΤΗΣΗΣ", "FUNCTION", Lang, W$) Then once = False b$ = Chr$(0) Execute = 2 Exit Function Else b$ = vbNullString ' no more syntax error Execute = 1 MOUT = True Exit Function End If Case "ΕΞΟΔΟΣ", "EXIT" ''\\"SUB", "ΡΟΥΤΙΝΑ" ContExit: '' If loopthis Then loopthis = False: Execute = 1 ss$ = vbNullString If IsLabelSymbolNewExp(b$, "ΡΟΥΤΙΝΑΣ", "SUB", Lang, ss$) Then WaitShow = 0 PopStagePartContinue2 bstack, bstack.RetStackTotal once = False b$ = Chr$(0) If bstack.RetStackTotal = 0 Then Execute = 1 Else Execute = 2 Exit Function ElseIf IsLabelSymbolNewExp(b$, "ΣΥΝΑΡΤΗΣΗΣ", "FUNCTION", Lang, ss$) Then WaitShow = 0 PopStagePartContinue2 bstack, bstack.RetStackTotal once = False b$ = Chr$(0) If bstack.RetStackTotal = 0 Then Execute = 1 Else Execute = 2 Exit Function ElseIf IsLabelSymbolNewExp(b$, "ΓΙΑ", "FOR", Lang, ss$) Then exitfor: once = False PopStagePartContinue2 bstack, bstack.RetStackTotal i = FastPureLabel(b$, W$) If i = 0 Then i = IsNumberLabel(b$, W$) If i = 0 Then b$ = "NEXT" Execute = 2 Else b$ = W$ Execute = 12 End If ElseIf i = 1 Then b$ = W$ Execute = 12 Else If Execute <> 2 Then Execute = 1 Else Execute = 3 restartmodule = False b$ = vbNullString once = True Exit Function b$ = "NEXT" Execute = 2 End If Exit Function ElseIf IsLabelSymbolNewExp(b$, "ΕΚΤΥΠΩΣΗΣ", "PRINTING", Lang, ss$) Then If bstack.toprinter Then pnum = 0 oprinter.ClearUp Form1.PrinterDocument1.Picture = LoadPicture("") Set bstack.Owner = Form1.DIS bstack.toprinter = False SetNormal bstack.Owner End If b$ = vbNullString once = True Else exitfromhere: If Execute <> 2 Then Execute = 1 Else Execute = 3 restartmodule = False If HaveMarkSel(bstack) Then Execute = 51 End If b$ = vbNullString once = True Exit Function End If Case "FOR", "ΓΙΑ" ForCont: If linebyline Then If Not b$ = vbNullString Then If AscW(b$) <> 32 Then b$ = W$ + " " + b$ Else b$ = W$ + b$ End If Execute = Execute(bstack, b$, once, False) Exit Do Else SyntaxError Execute = 0 Exit Function End If End If If once = True Then Execute = 0: Exit Function If Len(b$) < 129 Then x1 = Abs(IsLabelBig(bstack, b$, W$, , SBB$, , True)) Else ss$ = Left$(b$, 128) ok = True x1 = Abs(IsLabelBig(bstack, ss$, W$, , SBB$, , ok)) If Len(ss$) > 0 Then If ok Then b$ = Mid$(b$, 129 - Len(ss$)) ElseIf Len(ss$) <= 128 Then Mid$(b$, 129 - Len(ss$), Len(ss$)) = ss$ Mid$(b$, 1, 129 - Len(ss$)) = space$(128 - Len(ss$)) Else b$ = ss$ + Mid$(b$, 129) End If Else x1 = Abs(IsLabelBig(bstack, b$, W$, , SBB$, , True)) End If End If If x1 = 8 Then bstack.tmpstr = W$ + "[" + Left$(b$, 1) 'BackPort b$ If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) If IsExp(bstack, b$, p) Then If bstack.lastobj Is Nothing Then SyntaxError Exit Function ElseIf Not TypeOf bstack.lastobj Is Group Then SyntaxError Exit Function End If Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstack.lastobj v = -2 GoTo startwithgroup Else SyntaxError Exit Function End If End If againfor948: nd& = x1 Select Case x1 Case 1, 4 'FLOATING POINT If MaybeIsSymbol(b$, "<=") Then If FastSymbol(b$, "=") Then If bstack.StaticCollection Is Nothing Then GoTo cont10456 If bstack.ExistVar(W$) Then x2 = -1 x1 = nd& If IsExp(bstack, b$, p, , True, , True, True) Then If nd& = 4 Then p = MyRound(p) Else p = MyRound(p, 28) bstack.SetVar W$, p GoTo eos Else Execute = 0 Exit Function End If Else cont10456: x1 = Abs(GetlocalVar(W$, x2)) * x1 End If ElseIf FastSymbol(b$, "<=", , 2) Then x1 = Abs(GetVar(bstack, W$, x2, True)) * x1 End If If x1 Then If IsExp(bstack, b$, p, , True, , True, True) Then If VarType(var(x2)) <> VarType(p) Then On Error Resume Next Select Case VarType(var(x2)) Case vbInteger 'x1 = 16 p = CInt(p) Case vbLong x1 = 8 p = CLng(p) Case vbSingle p = CSng(p) Case vbCurrency p = CCur(p) Case vbDecimal p = CDec(p) Case 20 ' INT64 p = cInt64(p) Case vbByte p = CByte(p) Case vbDate p = CDate(p) Case vbObject MissingnumVar Execute = 0 Exit Function Case Else p = Int(p) End Select If Err.Number = 6 Then Execute = 0 OverflowValue VarType(var(x2)) Exit Function End If End If If x1 = 1 Then var(x2) = MyRound(p, 28) Else var(x2) = p End If End If ElseIf IsExp(bstack, b$, p, , True, , True, True) Then If nd& > 1 Then p = MyRound(p) x2 = globalvar(W$, p, , VarStat, temphere$) x1 = nd& Else Execute = 0 Exit Function End If eos: If IsLabelSymbolNew(b$, "ΕΩΣ", "TO", Lang) Then If IsExp(bstack, b$, sp, , True, , True, True) Then If VarType(sp) <> VarType(p) Then On Error Resume Next Select Case VarType(p) Case vbInteger sp = CInt(sp) Case vbLong sp = CLng(sp) Case vbSingle sp = CSng(sp) Case vbCurrency sp = CCur(sp) Case vbDecimal sp = CDec(sp) Case 20 ' INT64 sp = cInt64(sp) Case vbByte sp = CByte(sp) Case vbDate sp = CDate(sp) Case Else sp = Int(sp) End Select If Err.Number = 6 Then Execute = 0 OverflowValue VarType(p) Exit Function End If End If If nd& = 4 Then sp = MyRound(sp) p = MyRound(p) ElseIf x1 > 1 Then 'sp = Int(sp) 'p = Int(p) ElseIf myVarType(p, vbDouble) Then If RoundDouble Then sp = MyRound(sp, 13) p = MyRound(p, 28) End If 'If x1 > 1 Then sp = Round(sp, 0) ' like BASIC FOR If ForLikeBasic Or likebasic Then st = 1 Else st = Sgn(sp - p) End If If IsLabelSymbolNew(b$, "ΑΝΑ", "STEP", Lang) Then If VarType(p) = vbSingle Then st = CSng(1) If IsExp(bstack, b$, st, , True, , True, True) Then If VarType(p) = vbSingle Then st = CSng(st) End If If x1 > 1 Then If x1 >= 8 Then st = Fix(st) Else st = Round(st) End If If Not (Sgn(sp - p) = 0 Or st = 0) Then If ForLikeBasic Or likebasic Then If Sgn(st) <> Sgn(sp - p) Then st = 1 sp = p - 1 End If Else st = Abs(st) If sp < p Then If Fix(st) = st Then If st <> 0 Then sp = sp - ((sp - p) Mod st) \ 2 Else sx = Abs(((sp - p) / st)) If sx = MyRound(sx) Then sp = sp - MyRound(st / 2) ElseIf st < 1 Then sp = sp - 1 / EXP(18 - (Log(st + Abs(sp - p))) / Log(10)) Else sp = p - Fix(sx) * st - st / 2 End If End If Else If Not (Fix(st) = st) Then sx = Abs(((sp - p) / st)) If sx = MyRound(sx) Then sp = sp + MyRound(st / 2) ElseIf st < 1 Then sp = sp + 1 / EXP(18 - (Log(st + Abs(sp - p))) / Log(10)) Else sp = p + Fix(sx) * st + st / 2 End If End If End If st = Sgn(sp - p) * st End If End If Else Execute = 0 Exit Function End If End If If st = 0 Then sp = p If Not FastSymbol(b$, "{") Then '' this is the old like Basic For ' sw$ = b$ i = 1 aheadstatusNext b$, i, Lang, ok If Not ok Then MyEr "Μissing Next", "Δεν βρήκα το Επόμενο" Execute = 0: Exit Function End If ss$ = Left$(b$, i - 1) b$ = Mid$(b$, i) sw$ = ss$ sx = p y1 = True bstack.RetStack.PushVal 0 ' RETURN LENGTH FROM END OF B$ bstack.RetStack.PushStr W$ ' for check if is the right variable TraceStore bstack, nd&, b$, 0 slct = bstack.addlen If ForLikeBasic Or likebasic Then If st > 0 And sp < p Then ss$ = "NEXT " + W$ End If End If GoTo contfor Else y1 = False ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If sw$ = ss$ TraceStore bstack, nd&, b$, 0 slct = bstack.addlen ' reusing slct variable If FastSymbol(b$, "}") Then If ForLikeBasic Or likebasic Then If st > 0 And sp < p Then ss$ = "exit" End If End If contfor: Execute = 1 ok = False v = Len(b$) y2 = 0 Set subs = Nothing If x1 = 1 Then Do bstack.addlen = slct If executeblock(Execute, bstack, subs, ss$, once, ok, , True) Then bstack.addlen = nd& If Execute <> 1 Then If Execute = 2 Then SwapStrings b$, ss$ Exit Function Else b$ = ss$ + b$: Exit Function End If End If Else bstack.addlen = nd& If Execute = 2 And ss$ <> "" And Not ok Then If y1 And ss$ = "NEXT" Then Execute = 1: Exit Do End If SwapStrings b$, ss$ Exit Function ElseIf Execute = 12 Then bstack.RetStackDrop 2 Execute = 2 b$ = ss$ Exit Function End If End If If Not (ok Or MOUT) Or Execute = 3 Then Execute = 1 ss$ = sw$ p = p + st Else Exit Do End If ' If checkbreakEsc(bstack) Then Execute = 1: Exit Do If x2 < 0 Then bstack.SetVar W$, MyRound(p, 10) Else If Not myVarType(var(x2), VarType(p)) Then On Error Resume Next Select Case VarType(var(x2)) Case vbInteger var(x2) = CInt(p) Case vbLong var(x2) = CLng(p) Case vbSingle var(x2) = CSng(MyRound(p, 10)) Case vbCurrency var(x2) = CCur(MyRound(p, 10)) Case vbDecimal var(x2) = CDec(MyRound(p, 10)) Case 20 var(x2) = cInt64(p) Case vbByte var(x2) = CByte(p) Case vbDate var(x2) = CDate(p) Case Else var(x2) = CDbl(MyRound(p, 10)) End Select If Err.Number = 6 Then If st > 0 Then If p > sp Then Err.Clear: Exit Do ElseIf st < 0 Then If p < sp Then Err.Clear: Exit Do Else Exit Do End If OverflowValue VarType(var(x2)) Execute = 0 Exit Function End If ElseIf x1 > 1 Then var(x2) = p Else var(x2) = MyRound(p, 10) End If End If If st > 0 Then If p > sp Then Exit Do ElseIf st < 0 Then If p < sp Then Exit Do Else Exit Do End If Loop Else Do bstack.addlen = slct If executeblock(Execute, bstack, subs, ss$, once, ok, , True) Then bstack.addlen = nd& If Execute <> 1 Then If Execute = 2 Then SwapStrings b$, ss$ Exit Function Else b$ = ss$ + b$: Exit Function End If End If Else bstack.addlen = nd& If Execute = 2 And ss$ <> "" And Not ok Then If y1 And ss$ = "NEXT" Then Execute = 1: Exit Do End If SwapStrings b$, ss$ Exit Function ElseIf Execute = 12 Then bstack.RetStackDrop 2 Execute = 2 b$ = ss$ Exit Function End If End If If Not (ok Or MOUT) Or Execute = 3 Then Execute = 1 ss$ = sw$ p = p + st Else Exit Do End If ' If checkbreakEsc(bstack) Then Execute = 1: Exit Do If x2 < 0 Then bstack.SetVar W$, p Else var(x2) = p End If If st > 0 Then If p > sp Then Exit Do ElseIf st < 0 Then If p < sp Then Exit Do Else Exit Do End If Loop End If If Execute = 1 And y1 Then bstack.RetStackDrop 2 End If x2 = 0 ' need to erased - because reused y2 = 0 If MOUT Then Execute = 0: Exit Function ok = True End If End If End If End If Else v = -1 Set pppp = Nothing GoTo startwithgroup End If Case 5 againarraystring: If neoGetArray(bstack, W$, ppppl) Then If NeoGetArrayItem(ppppl, bstack, W$, v, b$) Then 'If VarTypeName$(ppppL.item(v)) = mGroup Then If ppppl.ItemType(v) = mGroup Then If Left$(b$, 1) = "." Then If SpeedGroup(bstack, ppppl, "VAL", "", b$, v) = 1 Then If Typename(bstack.lastobj) = mGroup Then Set ppppl = New ppppLight ppppl.arr = False Set ppppl.GroupRef = bstack.lastobj v = -2 Else MissingGroup Exit Function End If Else Exit Function End If End If startwithgroup: Execute = SpeedGroup(bstack, ppppl, "FOR", W$, b$, v) Set ppppl = Nothing ' ok here If Execute = 0 Then If LastErNum1 = 0 Then SyntaxError Exit Function ElseIf Execute <> 1 And b$ <> "" Then once = False Exit Function End If sss = Len(b$) GoTo loopagain End If If MaybeIsSymbol(b$, "=<") Then NotForArray Else MissingGroup End If Else NotExistArray W$ + ")" End If Execute = 0 Exit Function Else ok = False If Right$(W$, 2) <> "$(" Then W$ = Left$(W$, Len(W$) - 1) + "$(" GoTo againarraystring End If End If Case 6 If neoGetArray(bstack, W$, ppppl) Then If NeoGetArrayItem(ppppl, bstack, W$, v, b$) Then 'If VarTypeName$(ppppL.item(v)) = mGroup Then If ppppl.ItemType(v) = mGroup Then GoTo startwithgroup Else If TypeOf ppppl Is mArray Then Set pppp = ppppl If pppp.IsStringItem(v) Then ec$ = pppp.item(v) x1 = Abs(IsLabelBig(bstack, ec$, W$, , SBB$, , True)) If Not ec$ = vbNullString Then b$ = ec$ + b$ Set pppp = New mArray GoTo againfor948 Else MissString Execute = 0 Exit Function End If Else Execute = 0 Exit Function End If End If Else Execute = 0 Exit Function End If Else NotExistArray W$ + ")" End If End Select If Not ok Then Execute = 0 Exit Function End If Case "NEXT", "ΕΠΟΜΕΝΟ" contNext: If IsLabel(bstack, b$, W$) Then If bstack.IsInRetStackString(ss$) Then 'ss$ = bstack.RetStack.PopStr If ss$ <> W$ Then bstack.RetStack.PushStr ss$ MissNext Execute = 0 Exit Function Else With bstack.RetStack .drop 1 .PushVal Len(b$) .PushStr ss$ End With End If Exit Function End If Else ' NEW FOR M2000, WE CAN USE NO VARIABLE If bstack.IsInRetStackString(ss$) Then With bstack.RetStack .drop 1 .PushVal Len(b$) .PushStr ss$ End With Exit Function End If End If Case "CALL", "ΚΑΛΕΣΕ" ' CHECK FOR NUMBER... contCall: On Error Resume Next Err.Clear NeoCall ObjPtr(bstack), b$, Lang, ok If Not ok Or Err <> 0 Then Execute = 0 Exit Function ElseIf bstack.callx1 = -1 Then GoTo autogosub ElseIf Len(b$) > 0 Then If AscW(b$) = 8 Then GoTo again3 End If End If Case "INLINE", "ΕΝΘΕΣΗ" ContInline: If once = True Then Execute = 0: Exit Function If IsLabelSymbolNew(b$, "ΚΩΔΙΚΑ", "CODE", Lang) Then If IsLabelDot(here$, b$, sw$) = 1 Then If GetSub(myUcase(sw$, True), nd&) Then WaitShow = Len(b$) bstack.addlen = 0 If IsSymbol(b$, ",") Then If Lang = 1 Then b$ = vbCrLf + "Inline code " + b$ Else b$ = vbCrLf + "Ένθεση Κώδικα " + b$ End If End If b$ = vbCrLf + sbf(nd&).sb + b$ If trace Then TestShowSub = b$ sss = Len(b$) GoTo again1 ElseIf GetSub(here$ + sw$, nd&) Then WaitShow = Len(b$) b$ = vbCrLf + sbf(nd&).sb + b$ If trace Then TestShowSub = b$ sss = Len(b$) GoTo again1 End If Else GoTo errstat1 End If Else If IsStrExp(bstack, b$, ss$, False) Then WaitShow = Len(b$) bstack.addlen = 0 b$ = vbCrLf + ss$ + b$ If trace Then TestShowSub = b$ sss = Len(b$) GoTo again1 Else SyntaxError Execute = 0 Exit Function End If End If Case "UPDATE", "ΕΠΙΚΑΙΡΟ" contUpdate: If Len(bstack.UseGroupname) > 0 Then b$ = ": set " + Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) + "=" + Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) + vbCrLf + b$ sss = Len(b$) Else OnlyInAGroup Execute = 0 Exit Function End If GoTo again1 Case "AFTER", "ΜΕΤΑ" contAfter: If linebyline Then b$ = W$ + " " + b$ Execute = Execute(bstack, b$, once, False) Exit Do End If If once = True Then Execute = 0: Exit Function If IsExp(bstack, b$, p) Then If FastSymbol(b$, "{") Then ss$ = block(b$) + vbCrLf + "thread this erase" If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If sp = GetTaskId + 20000 b$ = Mid$(b$, 2) Set bs = New basetask bs.IamAnEvent = bstack.IamAnEvent Set bs.Parent = bstack bstack.PushThread CLng(sp), "after" sThreadInternal bs, sp, 0, ss$, uintnew(p), here$, True Set bs = Nothing LLL = 0 Execute = 1 Else LLL = 0 b$ = vbCrLf & "WAIT " & Int(p) & ": " & b$ Execute = 1 End If End If Case "ΣΧΕΔΙΟ", "DRAWING" contDraw: If Not linebyline Then If once = True Then Execute = 0: Exit Function End If Execute = 0 If FastSymbol(b$, "{") Then GoTo contDrw2 ElseIf IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then If Not FastSymbol(b$, ",", True) Then Execute = 0: Exit Function If FastSymbol(b$, "{") Then GoTo contDrw1 ElseIf Not IsExp(bstack, b$, sp, flatobject:=True, nostring:=True) Then missParam b$: Execute = 0: Exit Function End If If FastSymbol(b$, "{") Then contDrw1: ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, nd&, b$, 0 Mid$(b$, 1, 1) = " " x2 = Len(b$) If Not MakeEmf(bstack, b$, Lang, ss$, p, sp) Then Execute = 0: b$ = ss$ + space$(x2): Exit Function End If TraceRestore bstack, nd& Execute = 1 Else SyntaxError Execute = 0: Exit Function End If ElseIf LastErNum1 Then Execute = 0: Exit Function Else SyntaxError Execute = 0: Exit Function contDrw2: ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, nd&, b$, 0 Mid$(b$, 1, 1) = " " x2 = Len(b$) ' second type If Not MakeEmf(bstack, b$, Lang, ss$) Then Execute = 0: b$ = ss$ + space$(x2): Exit Function End If TraceRestore bstack, nd& Execute = 1 End If Case "ΔΥΑΔΙΚΟ", "BINARY" contBinary: If Not linebyline Then If once = True Then Execute = 0: Exit Function End If Execute = 0 If FastSymbol(b$, "{") Then ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) If Not GetRes(bstack, b$, Lang, ss$) Then Execute = 0: Exit Function End If Execute = 1 End If Case "ΜΕΡΟΣ", "PART" contPart: If Not linebyline Then If once = True Then Execute = 0: Exit Function End If Execute = 0 If FastSymbol(b$, "{") Then ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If x2 = Len(b$) TraceStore bstack, nd&, b$, bstack.addlen + 1 b$ = Mid$(b$, 2) If IsLabelSymbolNew(b$, "ΩΣ", "AS", Lang) Then ' search for variable name only ok = False If Abs(IsLabel(bstack, b$, W$)) = 1 Then If GetlocalVar(W$, v) Then ' exist... LLL = 0 If var(v) = 0 Then var(v) = True: ok = True ElseIf GetVar(bstack, W$, v) Then ' exist... LLL = 0 If var(v) = 0 Then var(v) = True: ok = True Else v = globalvar(W$, ok, , VarStat, temphere$) LLL = 0 End If If ok Then ok = False Execute = 1 Call executeblock(Execute, bstack, subs, ss$, (once), ok, , True) bstack.addlen = nd& + 1 If Execute = 0 Then b$ = ss$ + space$(x2): Exit Function var(v) = False ok = True If linebyline Then ClearStr b$ Exit Do End If Else bstack.addlen = nd& Execute = 1 End If Else ' ???? Exit Function End If Else SyntaxError Execute = 0 Exit Function End If Else Exit Function End If Case "DO", "REPEAT", "ΕΠΑΝΑΛΑΒΕ", "ΕΠΑΝΕΛΑΒΕ" ContRepeat: If linebyline Then b$ = W$ + " " + b$ sw$ = here$ Execute = Execute(bstack, b$, once, False) SwapStrings sw$, here$ Exit Do End If If once = True Then Execute = 0: Exit Function sw$ = here$ If Not FastSymbol(b$, "{") Then i = 1 aheadstatusDO b$, i, Lang, ok If ok Then v = Len(b$) ss$ = Left$(b$, i - 1) b$ = Mid$(b$, i) TraceStore bstack, x1, b$, 0 y1 = bstack.addlen GoTo contdo Else MissUntil Execute = 0 Exit Function End If Else v = Len(b$) ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, x1, b$, 0 b$ = Mid$(b$, 2) y1 = bstack.addlen contdo: Set subs = Nothing ok = False sss = Len(b$) ec$ = ss$ If IsLabelSymbolNew(b$, "ΟΣΟ", "WHEN", Lang) Then nchr = True GoTo CONDwhen End If If IsLabelSymbolNew(b$, "ΜΕΧΡΙ", "UNTIL", Lang) Then nchr = False CONDwhen: Execute = 1 bstack.addlen = y1 Call executeblock(Execute, bstack, subs, ss$, once, ok, , True) bstack.addlen = x1 If Execute = 0 Then b$ = space$(v - (Len(ec$) - Len(ss$))) Execute = 0: Exit Function ElseIf Execute = 2 Then If ss$ <> "" And Not ok Then b$ = ss$: Exit Function ElseIf ss$ = "" And ok Then b$ = "BREAK": Exit Function End If End If If Execute = 3 Then ok = False If ok Or MOUT Then If ok Then ss$ = GetNextLine(b$) 'FORGET ANY CODE TO THE RIGHT Else Exit Function End If Else sss = Len(b) W$ = b$ If IsExp(bstack, b$, p) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing With usehandler If .UseIterator Then i = .indirect If i < 0 Then Set myobject = .objref If TypeOf myobject Is mHandler Then Set usehandler1 = myobject Set myobject = usehandler1.objref Set usehandler1 = Nothing End If Else InternalError b$ = vbNullString Exit Function End If p = .index_End <> -1 And Not myobject.IsEmpty If p Then If .index_start <= .index_End Then v = 1 Else v = -1 If v >= 0 Then p = .index_cursor < .index_End Else p = .index_cursor > .index_End End If If p Then myobject.index = .index_cursor + v: .index_cursor = .index_cursor + v End If p = Not p ElseIf .IamEnum Then p = .Iterate() p = Not p End If End With Set usehandler = Nothing End If End If W$ = Left$(W$, Len(W$) - Len(b$)) If nchr Then p = p = 0 If p = 0 Then bb$ = W$ ok = False Set subs = Nothing Do ss$ = ec$ W$ = bb$ Execute = 1 bstack.addlen = y1 Call executeblock(Execute, bstack, subs, ss$, once, ok, , True) bstack.addlen = x1 If Execute = 0 Then b$ = space$(v - (Len(ec$) - Len(ss$))) SwapStrings sw$, here$ Execute = 0: Exit Function ElseIf Execute = 2 Then If ss$ <> "" And Not ok Then SwapStrings sw$, here$ b$ = ss$: Exit Function ElseIf ss$ = "" And ok Then SwapStrings sw$, here$ b$ = "BREAK": Exit Function End If End If If Execute = 3 Then ok = False If ok Or MOUT Then Exit Do IsExp bstack, W$, p If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing With usehandler If .UseIterator Then i = .indirect If i < 0 Then Set myobject = .objref If TypeOf myobject Is mHandler Then Set usehandler1 = myobject Set myobject = usehandler1.objref Set usehandler1 = Nothing End If Else InternalError b$ = vbNullString Exit Function End If p = .index_End <> -1 And Not myobject.IsEmpty If p Then If .index_start <= .index_End Then v = 1 Else v = -1 If v >= 0 Then p = .index_cursor < .index_End Else p = .index_cursor > .index_End End If If p Then myobject.index = .index_cursor + v: .index_cursor = .index_cursor + v End If p = Not p ElseIf .IamEnum Then p = .Iterate() p = Not p End If End With Set usehandler = Nothing End If End If If nchr Then p = p = 0 Loop Until p SwapStrings sw$, here$ End If End If End If Else ' play always If IsLabelSymbolNew(b$, "ΠΑΝΤΑ", "ALWAYS", Lang) Then Set subs = Nothing Do ss$ = ec$ Execute = 1 bstack.addlen = y1 Call executeblock(Execute, bstack, subs, ss$, once, ok, , True, True) bstack.addlen = x1 If Execute = 0 Then b$ = space$(v - (Len(ec$) - Len(ss$))) SwapStrings sw$, here$ Execute = 0: Exit Function ElseIf Execute = 2 Then If ss$ <> "" And Not ok Then SwapStrings sw$, here$ b$ = ss$: Exit Function ElseIf ss$ = "" And ok Then SwapStrings sw$, here$ b$ = "BREAK": Exit Function End If ElseIf Execute = 1 Then 'If ok Then once = True: b$ = vbNullString: Exit Function ElseIf Execute = 3 Then ok = False End If If ok Or MOUT Then Exit Do Loop Else Execute = 0 Exit Function End If End If lbl = False If Len(b$) > 0 Then If Left$(b$, 2) = vbCrLf Then lbl = True End If End If Case "ΕΝΩ", "WHILE" contWhile: If linebyline Then b$ = W$ + " " + b$ sw$ = here$ Execute = Execute(bstack, b$, once, False) SwapStrings sw$, here$ Exit Do End If If once = True Then Execute = 0: Exit Function i = 0 x1 = 0 again112: i = i + 1 If Len(aheadstatus(b$, False, i)) > 0 Then x1 = i If MaybeIsSymbol3(b$, ",", i) Then GoTo again112 End If If x1 > 0 Then Else SyntaxError Execute = 0 Exit Function End If x1 = x1 - 1 W$ = Left$(b$, x1) If IsExp(bstack, W$, p, nostring:=True) Then st = True ss$ = vbNullString getanother: If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing With usehandler If .UseIterator Then i = .indirect If i < 0 Then Set myobject = .objref If TypeOf myobject Is mHandler Then Set usehandler1 = myobject Set myobject = usehandler1.objref Set usehandler1 = Nothing End If Else InternalError b$ = vbNullString Exit Function End If p = .index_End <> -1 And Not myobject.IsEmpty If p Then myobject.index = .index_start .index_cursor = .index_start If .index_start <= .index_End Then v = 1 Else v = -1 End If ElseIf .IamEnum Then p = .index_End <> -1 If p Then If .index_End <> 0 Then p = .Iterate() End If End If End If Set bstack.lastobj = Nothing End With Set usehandler = Nothing End If End If st = st And CBool(p) If FastSymbol(W$, ",") Then If IsExp(bstack, W$, p) Then If Not bstack.lastobj Is Nothing Then GoTo getanother Else MissNumExpr Execute = 0 Exit Function End If End If If Not Len(NLtrim(W$)) = 0 Then If Len(W$) > x1 Then b$ = W$ + b$ ElseIf Len(W$) = x1 Then Mid$(b$, 1, x1) = W$ Else Mid$(b$, 1, x1) = space$(x1 - Len(W$)) + W$ End If End If 'w$ = Left$(w$, Len(w$) - Len(b$)) W$ = Left$(b$, x1) b$ = Mid$(b$, x1 + 1) If p = 0# Then If FastSymbol(b$, "{") Then W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If ' b$ = NLtrim$(b$) If FastSymbol(b$, "}") Then b$ = NLtrim(b$) If b$ = vbNullString Then Exit Function GoTo again1 Else b$ = NLtrim$(b$) If b$ = vbNullString Then Exit Function GoTo again1 End If Else i = 1 aheadstatusENDWHILE b$, i, Lang, ok, sss If Not ok Then MissWhile Execute = 0 Exit Function End If b$ = NLtrim(Mid$(b$, i)) If b$ = vbNullString Then Exit Function lbl = False If Len(b$) > 0 Then If Left$(b$, 2) = vbCrLf Then lbl = True End If GoTo again1 Exit Do End If Else If Not FastSymbol(b$, "{") Then i = 1 aheadstatusENDWHILE b$, i, Lang, ok, sss If ok Then ss$ = Left$(b$, sss - 1) + space$(i - sss) b$ = Mid$(b$, i) TraceStore bstack, x1, b$, 0 y1 = bstack.addlen ec$ = ss$ GoTo contWhile1 Else MissWhile Execute = 0 Exit Function End If Else ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, x1, b$, 0 y1 = bstack.addlen ec$ = ss$ b$ = Mid$(b$, 2) contWhile1: sss = Len(b$) bb$ = W$ Execute = 1 ok = False sw$ = here$ Set subs = Nothing Do st = True ss$ = ec$ W$ = bb$ bstack.addlen = y1 If executeblock(Execute, bstack, subs, ss$, once, ok, , True) Then SwapStrings sw$, here$ TraceRestore bstack, x1 If Execute = 2 Then If ok And ss$ = "" Then b$ = "BREAK": Exit Function b$ = ss$: Exit Function End If b$ = ss$ + b$ Exit Function Else SwapStrings sw$, here$ TraceRestore bstack, x1 If Execute = 2 And ss$ <> "" And Not ok Then b$ = ss$ Exit Function ElseIf Execute = 12 Then Execute = 2 b$ = ss$ Exit Function End If End If If Execute = 3 Then ok = False If ok Or MOUT Then Exit Do another1: IsExp bstack, W$, p If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing With usehandler If .UseIterator Then i = .indirect If i < 0 Then Set myobject = .objref If TypeOf myobject Is mHandler Then Set usehandler1 = myobject Set myobject = usehandler1.objref Set usehandler1 = Nothing End If Else InternalError b$ = vbNullString Exit Function End If p = .index_End <> -1 And Not myobject.IsEmpty If p Then If .index_start <= .index_End Then v = 1 Else v = -1 If v >= 0 Then p = .index_cursor < .index_End Else p = .index_cursor > .index_End End If If p Then myobject.index = .index_cursor + v: .index_cursor = .index_cursor + v End If ElseIf .IamEnum Then p = .Iterate() End If End With Set usehandler = Nothing End If End If st = st And CBool(p) If FastSymbol(W$, ",") Then GoTo another1 Loop Until st = 0 Or NOEXECUTION ' addition in 8.9 rev 33 Set bstack.lastobj = Nothing If MOUT Then Execute = 0: Exit Function End If End If End If lbl = False DropCommentOrLine b$, True sss = Len(b$) If Len(b$) > 0 Then If Left$(b$, 2) <> vbCrLf Then GoTo jumpforCR End If Else Exit Do End If Case "ΚΑΘΕ", "EVERY" contEvery: If once = True Then Execute = 0: Exit Function If linebyline Then b$ = W$ + " " + b$ sw$ = here$ Execute = Execute(bstack, b$, once, False) SwapStrings sw$, here$ Exit Do End If If IsExp(bstack, b$, p) Then If p <= 0 Then If FastSymbol(b$, "{") Then W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) sss = Len(b$) Else Exit Do End If Else sw$ = here$ If FastSymbol(b$, "{") Then ss$ = block(b$) '+ "}" If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If ec$ = ss$ b$ = Mid$(b$, 2) sss = Len(b$) Execute = 1 ok = False ' GET A TICK HERE If p < 1 Then p = 1 y2 = Signed(p) 'sX = y2 'Call GetSystemTimeAsFileTime(basictimer) Set subs = Nothing x2 = timeGetTime Do ss$ = ec$ 'y2 = sX Execute = 1 Call executeblock(Execute, bstack, subs, ss$, once, ok, , True) If Execute = 0 Then '''Execute(bstack, ss$, ok) = 0 If NOEXECUTION Then b$ = "START" Execute = 1 ok = True Exit Do End If b$ = ss$ + b$ SwapStrings sw$, here$ Execute = 0: Exit Function ElseIf Execute = 2 Then If Len(ss$) > 0 Then SwapStrings sw$, here$ b$ = ss$: Exit Function ElseIf ok Then b$ = "BREAK": once = True SwapStrings sw$, here$ Exit Function End If End If If ok Or MOUT Then Exit Do If UnsignedSub(timeGetTime, x2) > y2 Then x2 = UnsignedSub(x2, Not y2) ' // add End If If bstack.IamThread Then SkipRefresh bstack Do ProcTask2 bstack x1 = timeGetTime Loop Until UnsignedSub(x1, x2) >= y2 x2 = x1 Loop SwapStrings sw$, here$ If NOEXECUTION Then b$ = "START" Execute = 1 ok = True Exit Do End If If MOUT Then Execute = 0: Exit Function Else sss = Len(b$) End If End If End If Case "ΚΥΡΙΟ.ΕΡΓΟ", "MAIN.TASK", "TASK.MAIN" contTask: If once = True Then Execute = 0: Exit Function If linebyline Then b$ = W$ + " " + b$ sw$ = here$ Execute = Execute(bstack, b$, once, False) SwapStrings sw$, here$ Exit Do End If ' only one task main If taskmainonly = True Then Execute = 0: Exit Function taskmainonly = True W$ = b$ Execute = 1 If IsExp(bstack, b$, p) Then If FastSymbol(b$, "{") Then ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) sp = GetTaskId + 20000 Set bs = New basetask Set bs.Parent = bstack bs.addlen = Len(b$) + bstack.addlen + 1 bstack.PushThread CLng(sp), "_multi" sThreadInternal bs, sp, 10, ss$, -1&, here$, True TaskMaster.Message CLng(sp), 3, CLng(uintnew(p)) On Error Resume Next bstack.TaskMain = True i = 0 Do If TaskMaster Is Nothing Then Execute = 0: Exit Function If TaskMaster.Processing Then TaskMaster.TimerTick i = 0 Else If i = 1 Then DoEvents i = 10 Else If Timer Mod (100 + i) < 10 Then i = i + 1 End If End If bstack.TaskMain = bstack.exist(CLng(sp), "_multi") = False Loop Until MOUT Or bstack.TaskMain Or NOEXECUTION Or TaskMaster.CanStopMain ' QueueCount < 2 ' ' If bstack.exist(CLng(sp), "_multi") Then TaskMaster.Message CLng(sp), 1 End If On Error GoTo 0 bstack.TaskMain = False 'If TaskMaster.PlayMusic Then mute = True End If End If taskmainonly = False If MOUT Then Execute = 0: Exit Function Case "ELSE", "ΑΛΛΙΩΣ" ContElse: If HaveMarkSel(bstack) Then If Len(W$) = 4 Then If HaveMarkSelEn(bstack) Then IsLabelSymbolNew b$, "", "CASE", 1 Execute = 100 Exit Function End If ElseIf HaveMarkSelGr(bstack) Then IsLabelSymbolNew b$, "ΜΕ", "", 0 Execute = 100 Exit Function End If End If ContElse1: If IFCTRL = 0 Then If lookB123(b$) Then If HaveMark(bstack, i, ok) Then If i = 0 Then SyntaxError Execute = 0: Exit Function End If If (Not ok) Or i = 2 Then findEndif: i = SetNextLineCLR(b$) i = MyTrimLi(b$, i + 1) If i > 0 Then aheadstatusENDIF b$, i, Lang, ok If Not ok Then Execute = 0: Exit Function If i = Len(b$) + 2 Then MissENDIF: Execute = 0: Exit Function DropMark bstack bstack.UseofIf = bstack.UseofIf - 1 b$ = Mid$(b$, i) Else b$ = vbNullString End If sss = Len(b$) lbl = False If Len(b$) > 0 Then If Left$(b$, 2) = vbCrLf Then lbl = True End If Else ' no other else.if DropMark bstack MarkIf bstack, 0, False End If GoTo loopcontinue End If End If SyntaxError Execute = 0 Exit Function Else If (Not jump) Or IFCTRL = 2 Then If FastSymbol(b$, "{") Then W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) DropCommentOrLine b$, True If Not CheckFreeExecute(b$) Then SyntaxError Execute = 0 Exit Function End If ElseIf lookB123(b$) Then i = SetNextLineCLR(b$) i = MyTrimLi(b$, i + 1) If i > 0 Then aheadstatusENDIF b$, i, Lang, ok If Not ok Then Execute = 0: Exit Function If i = Len(b$) + 2 Then MissENDIF: Execute = 0: Exit Function DropMark bstack bstack.UseofIf = bstack.UseofIf - 1 b$ = Mid$(b$, i) Else b$ = vbNullString End If lbl = True Else If Not once Then SetNextLine b$ End If lbl = True jump = False sss = Len(b$) GoTo loopagain lbl = True End If jump = False Else If IsNumberLabel(b$, W$) Then once = False b$ = W$ Execute = 2 Exit Function End If If lookB123(b$) Then If Not once Then SetNextLineCLR b$ End If lbl = True jump = False sss = Len(b$) GoTo loopagain End If lbl = False IFCTRL = 0 ' NONEED ANYTHING AND ERROR FOR IF.ELSE AND ELSE jump = False sss = Len(b$) If FastSymbol(b$, "{") Then ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, nd&, b$, 0 b$ = Mid$(b$, 2) Call Module10.executeblock(Execute, bstack, ss$, False, ok, , True) TraceRestore bstack, nd& If Execute = 2 Then If Len(ss$) > 0 Then b$ = ss$: Exit Function If ok Then b$ = "BREAK": once = True: Exit Function End If DropCommentOrLine b$, True If Not CheckFreeExecute(b$) Then SyntaxError Execute = 0 Exit Function End If Else If once Or linebyline Then GoTo again1 End If End If End If IFCTRL = 0 ' NONEED ANYTHING AND ERROR FOR IF.ELSE AND ELSE jump = False lbl = False DropCommentOrLine b$, True sss = Len(b$) If Len(b$) > 0 Then If Left$(b$, 2) <> vbCrLf Then GoTo againExtra2 End If Else Exit Do End If Case "TRY", "ΔΕΣ" ContTry: If IsLabelSymbolNew(b$, "ΡΕΥΜΑ", "STREAM", Lang) Then If bstack.CallW <> "" Then ss$ = here$ i = bstack.soros.Total here$ = bstack.fHere If bstack.strg Then If IsStrExp(bstack, (bstack.CallW), ec$) Then bstack.soros.DataStr ec$ End If Else If IsExp(bstack, (bstack.CallW), p) Then bstack.soros.DataVal p End If End If here$ = ss$ End If GoTo loopagain End If If once = True Then Execute = 0: Exit Function If linebyline Then b$ = W$ + " " + b$ sw$ = here$ PushErrStage bstack Execute = Execute(bstack, b$, once, False) PopErrStage bstack SwapStrings sw$, here$ bstack.nokillvars = False Exit Do End If ' ΜΕΤΑΒΛΗΤΗ i = Abs(IsLabel(bstack, b$, W$)) Select Case i Case 0 ' new If FastSymbol(b$, "{") Then Execute = 1 ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, x1, b$, 0 b$ = Mid$(b$, 2) Execute = 1 PushErrStage bstack Call Module10.executeblock(Execute, bstack, ss$, once, ok, , True) PopErrStage bstack TraceRestore bstack, x1 bstack.nokillvars = False If NOEXECUTION Then Exit Function once = False MOUT = False ' NOEXECUTION = False NERR = False LastErNum = 0 LastErNum1 = 0 bstack.ErrorOriginal = 0 If LastErName <> "" Then LastErName = Chr(0) + LastErName If LastErNameGR <> "" Then LastErNameGR = Chr(0) + LastErNameGR If Execute = 2 Then If ss$ = "" Then ' no here ' b$ = ": Break" Else b$ = ": Goto " + ss$ End If sss = Len(b$) End If Execute = 1 Else SyntaxError Execute = 0: Exit Function End If Case 1, 4 If FastSymbol(b$, "{") Then p = 0# If Not GetlocalVar(W$, v) Then If Not GetVar(bstack, W$, v) Then v = globalvar(W$, p, , VarStat, temphere$) '': GetlocalVar W$, v End If End If Execute = 1 ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) LastErNum2 = 0 PushErrStage bstack Call Module10.executeblock(Execute, bstack, ss$, once, ok, , True) PopErrStage bstack var(v) = CDbl(Execute = 1) If NOEXECUTION Then Exit Function MOUT = False ' NOEXECUTION = False NERR = False LastErNum = 0 LastErNum2 = LastErNum1 LastErNum1 = 0 bstack.ErrorOriginal = 0 If Execute = 2 Then If ss$ = "" Then Else b$ = ": Goto " + ss$ End If sss = Len(b$) End If Execute = 1 Else SyntaxError Execute = 0: Exit Function End If End Select If MOUT Then Execute = 0: Exit Function Execute = 1 Case "ELSE.IF", "ΑΛΛΙΩΣ.ΑΝ" contElseIf: ' If once = True Then Execute = 0: Exit Function If IFCTRL = 0 Then If HaveMark(bstack, i, ok) Then If i = 0 Then SyntaxError Execute = 0: Exit Function End If x1 = 1 aheadstatusThen b$, x1, Lang, W$ If W$ = vbNullString Then MissTHENELSE Execute = 0 Exit Function End If If lookB123(b$, x1) Then 'If MaybeIsSymbol3lot(b$, b123, (x1)) Then If (Not ok) Or i = 2 Then ' so we have to jump x1 = i i = SetNextLineCLR(b$) i = MyTrimLi(b$, i + 1) If i > 0 Then aheadstatusELSEIF b$, i, Lang, ok, x1, (ok) If x1 = 0 Then DropMark bstack bstack.UseofIf = bstack.UseofIf - 1 End If b$ = Mid$(b$, i) Else b$ = vbNullString End If sss = Len(b$) lbl = True Else ' so we have to check expression If IsExp(bstack, Left$(b$, x1), p, flatobject:=True, nostring:=True) Then i = 1 ok = (p = 0#) ' drop old save new Select Case Lang Case 0 Select Case W$ Case "ΑΛΛΙΩΣ" Mid$(b$, 1, x1) = space(x1) ok = Not ok GoTo contThenElseIf Case "ΤΟΤΕ" GoTo contThenElseIf End Select Case 1 Select Case W$ Case "ELSE" Mid$(b$, 1, x1) = space(x1) ok = Not ok GoTo contThenElseIf Case "THEN" contThenElseIf: If ok Then x1 = x1 + 1 aheadstatusELSEIF b$, x1, Lang, ok, i, (ok) DropMark bstack If i = 0 Then bstack.UseofIf = bstack.UseofIf - 1 Else MarkIf bstack, 1, True End If b$ = Mid$(b$, x1) Else Mid$(b$, 1, x1) = space(x1) DropMark bstack MarkIf bstack, 2, True End If End Select End Select sss = Len(b$) lbl = True End If End If GoTo loopcontinue End If End If SyntaxError Execute = 0 Exit Function Else ' use of flags If (Not jump) Or IFCTRL = 2 Then ' LOOK AHEAD...DO NOT PLAY THE LOGICAL EXPRESSION ' ALSO THROW ALL { } ELSE {} BECAUSE FOUND THAT IS AN EXPRESSION;;; IFCTRL = 1 aheadstatusIF b$, IFCTRL, Lang, W$ If Len(W$) = 0 Then SyntaxError: Execute = 0: Exit Function If FastOperator(b$, vbCrLf, IFCTRL, 2) Then b$ = Mid$(b$, IFCTRL) SetNextLine b$ IFCTRL = 1 aheadstatusANY b$, IFCTRL b$ = Mid$(b$, IFCTRL) Else ' aheadstatusANY b$, IFCTRL b$ = Mid$(b$, IFCTRL) If FastSymbol(b$, "{") Then W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) If FastSymbol(b$, ":") Then sss = Len(b$) IFCTRL = 0: GoTo again1 End If Else SetNextLine b$ End If End If If bstack.RetStackTotal > 0 Then If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse If bstack.RetStack.LookTopVal = -3 Then jump = False IFCTRL = 0 End If Else lbl = True IFCTRL = 1 jump = False i = 1 While FastOperator(b$, vbCrLf, i, 2) Wend If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse End If Else ' ONLY FOR NOT JUMP If IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then IFCTRL = 1 jump = (p = 0#) i = 1 Select Case Abs(IsLabel(bstack, b$, W$)) ' now w$ is Ucase Case 1 Select Case W$ Case "THEN", "ΤΟΤΕ" 'While FastOperator(b$, vbCrLf, i, 2) 'Wend If jump Then If FastSymbol(b$, "{") Then W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) If FastSymbol(b$, ":") Then sss = Len(b$) IFCTRL = 0: GoTo again1 End If Else i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then If Lang = 0 Then Select Case W$ Case "ΑΛΛΙΩΣ" b$ = Mid$(b$, i) GoTo ContElse1 Case "ΑΛΛΙΩΣ.ΑΝ" b$ = Mid$(b$, i) GoTo contElseIf End Select Else Select Case W$ Case "ELSE" b$ = Mid$(b$, i) GoTo ContElse1 Case "ELSE.IF" b$ = Mid$(b$, i) GoTo contElseIf End Select End If sss = Len(b$) GoTo again1 Else SetNextLine b$ lbl = True End If 'End If End If Else If Not FastSymbol(b$, "{") Then ' ELSE.IF true THEN ****************************************************** If MaybeIsSymbol(b$, "0123456789") Then GoTo ContGoto Set subs = Nothing i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then ' #1 ss$ = Left$(b$, i - 1 - Len(W$)) '+ "}" If once Then once = False b$ = Mid$(b$, Len(ss$) + 1) TraceStore bstack, nd&, b$, 0 Call executeblock(Execute, bstack, subs, ss$, once, ok, , True, False) TraceRestore bstack, nd& If Execute = 0 Then b$ = ss$ + b$ ElseIf Execute = 5 Then once = True GoTo contLoop ElseIf Execute = 6 Then b$ = vbNullString Execute = 2 once = True Exit Function ElseIf Execute = 2 And once Then b$ = ss$ Exit Function ElseIf Execute = 3 Then b$ = ss$ Exit Function Else SetNextLine b$ End If once = True Exit Function Else ' else.if then .... no block b$ = Mid$(b$, Len(ss$) + 1) ok = False Set subs = Nothing TraceStore bstack, nd&, b$, 0 Call executeblock(Execute, bstack, subs, ss$, False, ok, , True, False) TraceRestore bstack, nd& End If If Execute = 1 Then If ok Then Exit Function GoTo contif2 ElseIf Execute = 2 Then b$ = ss$ once = False Exit Function ElseIf Execute = 6 Then GoTo ContRestart ElseIf Execute = 5 Then Execute = 2 loopthis = True GoTo contif2 Else If loopthis Then Execute = 2 GoTo CONTcontinue End If Else IFCTRL = 2 End If Else contelseifpass: IFCTRL = 2 ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If TraceStore bstack, nd&, b$, 0 b$ = Mid$(b$, 2) Set subs = Nothing Call executeblock(Execute, bstack, subs, ss$, False, ok, , True) TraceRestore bstack, nd& If Execute = 1 Then ' If once Then Exit Do If FastSymbol(b$, ":") Then sss = Len(b$) IFCTRL = 0: GoTo again1 End If If Not lookB123(b$) Then GoTo contif2 Else b$ = ss$ once = False Execute = 2 Exit Function End If End If End If Case "ELSE", "ΑΛΛΙΩΣ" ' While FastOperator(b$, vbCrLf, i, 2) 'Wend If Not jump Then ' JUMP FALSE SKIP ELSE If FastSymbol(b$, "{") Then W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) Else i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then jump = True IFCTRL = 1 If Lang = 0 Then Select Case W$ Case "ΑΛΛΙΩΣ" b$ = Mid$(b$, i) GoTo ContElse Case "ΑΛΛΙΩΣ.ΑΝ" b$ = Mid$(b$, i) GoTo contElseIf End Select Else Select Case W$ Case "ELSE" b$ = Mid$(b$, i) GoTo ContElse Case "ELSE.IF" b$ = Mid$(b$, i) GoTo contElseIf End Select End If sss = Len(b$) Else SetNextLine b$ lbl = True End If End If jump = True IFCTRL = 1 Else IFCTRL = 2 If MaybeIsSymbol(b$, "0123456789") Then GoTo ContGoto i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then ' #2 ss$ = Left$(b$, i - 1 - Len(W$)) If once Then once = False b$ = Mid$(b$, Len(ss$) + 1) TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(Execute, bstack, ss$, once, ok, , True, False) TraceRestore bstack, nd& If Execute = 0 Then b$ = ss$ + b$ ElseIf Execute = 5 Then once = True GoTo contLoop ElseIf Execute = 6 Then b$ = vbNullString Execute = 2 once = True Exit Function ElseIf Execute = 3 Then b$ = ss$ Exit Function ElseIf Execute = 2 And once Then b$ = ss$ Exit Function Else SetNextLine b$ End If once = True Exit Function Else ' else.if else ..... no block b$ = Mid$(b$, Len(ss$) + 1) TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(Execute, bstack, ss$, False, ok, , True, False) TraceRestore bstack, nd& End If If Execute = 1 Then ' else.if pass If ok Then Exit Function If FastSymbol(b$, ":") Then sss = Len(b$) IFCTRL = 0: GoTo again1 End If If Not lookB123(b$) Then GoTo contif2 ElseIf Execute = 2 Then If ok And Len(ss$) = 0 Then b$ = "BREAK" Else b$ = ss$ once = False Exit Function ElseIf Execute = 6 Then GoTo ContRestart ElseIf Execute = 5 Then loopthis = True Execute = 2 Else If loopthis Then Execute = 2 GoTo CONTcontinue End If Else If FastSymbol(b$, "{") Then GoTo contelseifpass End If End If Case Else Execute = 0 Exit Function End Select If bstack.RetStackTotal > 0 Then If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse If bstack.RetStack.LookTopVal = -3 Then jump = False IFCTRL = 0 End If Else If jump Or IFCTRL = 2 Then i = 1 If Not once Then If FastOperator(b$, vbCrLf, i, 2) Then While FastOperator(b$, vbCrLf, i, 2) Wend End If End If If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse1 End If End If Case Else Execute = 0 Exit Function End Select Else Execute = 0 Exit Function End If End If End If sss = Len(b$) Case "IF", "ΑΝ" contif: jump = 0 IFCTRL = 0 If IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then x1 = 1 ' NEED THEN OR ELSE OR ELSE.IF ok = (p = 0#) ' JUMP TRUE GOTO ELSE i = 1 Select Case Abs(IsLabel(bstack, b$, W$)) Case 1 Select Case W$ Case "THEN", "ΤΟΤΕ" If ok Then If lookB123(b$) Then i = SetNextLineCLR(b$) MarkIf bstack, 1, ok bstack.UseofIf = bstack.UseofIf + 1 x1 = 1 aheadstatusELSEIF b$, i, Lang, ok, x1, (ok) DropMark bstack If x1 = 0 Then bstack.UseofIf = bstack.UseofIf - 1 Else MarkIf bstack, 1, True End If b$ = Mid$(b$, i) IFCTRL = 0 jump = False lbl = False If Len(b$) > 0 Then If Left$(b$, 2) = vbCrLf Then lbl = True End If sss = Len(b$) GoTo loopcontinue ElseIf FastSymbol(b$, "{") Then ' If once = True Then Execute = 0: Exit Function W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) If FastSymbol(b$, ":") Then sss = Len(b$) IFCTRL = 0: GoTo again1 End If i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then GoTo contif22 DropCommentOrLine b$, True If Not CheckFreeExecute(b$) Then SyntaxError Execute = 0 Exit Function End If sss = Len(b$) GoTo loopagain Else contif2: i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then contif22: jump = ok If IFCTRL = 0 Then IFCTRL = 1 If Lang = 0 Then Select Case W$ Case "ΑΛΛΙΩΣ" b$ = Mid$(b$, i) GoTo ContElse1 Case "ΑΛΛΙΩΣ.ΑΝ" b$ = Mid$(b$, i) GoTo contElseIf End Select Else Select Case W$ Case "ELSE" b$ = Mid$(b$, i) GoTo ContElse1 Case "ELSE.IF" b$ = Mid$(b$, i) GoTo contElseIf End Select End If sss = Len(b$) Else If once Then W$ = GetStrUntil(vbCrLf, b$, False) Exit Function Else 'if module2 SetNextLine b$ End If End If End If If bstack.RetStackTotal = 0 Then jump = ok If IFCTRL = 0 Then IFCTRL = 1 Else If Not bstack.RetStack.LookTopVal = -3 Then jump = ok If IFCTRL = 0 Then IFCTRL = 1 Else IFCTRL = 0 End If End If Else If lookB123(b$) Then i = SetNextLineCLR(b$) MarkIf bstack, 2, jump bstack.UseofIf = bstack.UseofIf + 1 jump = False IFCTRL = 0 lbl = True sss = Len(b$) GoTo loopcontinue Else IFCTRL = 1 jump = True If MaybeIsSymbol(b$, "0123456789") Then GoTo ContGoto IFCTRL = 2 ' NONEED ANYTHING BUT NOT ERROR FOR IF.ELSE AND ELSE If Not FastSymbol(b$, "{") Then i = 1 aheadstatusELSE b$, i, Lang, W$ If Len(W$) > 2 Then ' #3 ss$ = Left$(b$, i - 1 - Len(W$)) b$ = Mid$(b$, i - Len(W$)) If once Then TraceStore bstack, nd&, b$, 0 once = False Call Module10.executeblock(Execute, bstack, ss$, once, ok, , True, False) TraceRestore bstack, nd If Execute = 0 Then b$ = ss$ + b$ ElseIf Execute = 5 Then once = True GoTo contLoop ElseIf Execute = 6 Then b$ = vbNullString Execute = 2 once = True Exit Function ElseIf Execute = 3 Then b$ = ss$ Exit Function ElseIf Execute = 2 And once Then b$ = ss$ Exit Function ElseIf Execute = 1 Then If ok And Len(ss$) = 0 Then b$ = vbNullString Else SetNextLineNL b$ End If Else If ok = True Then b$ = "BREAK" Else b$ = ss$ once = False ' Execute = 2 Exit Function End If Exit Do Else ' if then ... else or else.if, no block TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(Execute, bstack, ss$, False, ok, , True, False) TraceRestore bstack, nd& End If If Execute = 1 Then SetNextLine b$ lbl = True If bstack.RetStackTotal > 0 Then If bstack.RetStack.LookTopVal = -3 Then IFCTRL = 0 End If End If If ok Then once = True: b$ = vbNullString: Exit Function ElseIf Execute = 2 Then If ok And Len(ss$) = 0 Then b$ = "BREAK" Else b$ = ss$ once = False Exit Function ElseIf Execute = 3 Then If loopthis Then Execute = 2 GoTo CONTcontinue ElseIf Execute = 6 Then GoTo ContRestart ElseIf Execute = 5 Then loopthis = True ok = False SetNextLine b$ Execute = 2 If bstack.RetStackTotal > 0 Then If bstack.RetStack.LookTopVal = -3 Then IFCTRL = 0 End If End If ElseIf Execute = 0 Then Exit Do Else If loopthis Then Execute = 2 GoTo CONTcontinue End If Else If bstack.RetStack.LookTopVal = -3 Then IFCTRL = 0 End If End If Else ' bstack.addlen = Len(b$) ss$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If ok = False TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(Execute, bstack, ss$, False, ok, , True) TraceRestore bstack, nd& b$ = Mid$(b$, 2) If Execute = 1 Then If FastSymbol(b$, ":") Then sss = Len(b$) IFCTRL = 0 GoTo again1 End If If Not lookB123(b$) Then GoTo contif2 IFCTRL = 0 ElseIf Execute = 2 Then If ok Then b$ = "BREAK": once = True Else b$ = ss$ Exit Function End If End If End If End If Case "ELSE", "ΑΛΛΙΩΣ" If lookB123(b$) Then If Not ok Then ' find END IF MarkIf bstack, 1, ok bstack.UseofIf = bstack.UseofIf + 1 GoTo findEndif Else MarkIf bstack, 0, ok bstack.UseofIf = bstack.UseofIf + 1 jump = False IFCTRL = 0 lbl = True End If i = SetNextLineCLR(b$) ElseIf Not ok Then ' JUMP FALSE SKIP ELSE If FastSymbol(b$, "{") Then If once = True Then Execute = 0: Exit Function W$ = block(b$) If Not Left$(b$, 1) = "}" Then Execute = CheckBlock(once): Exit Function End If b$ = Mid$(b$, 2) Else SetNextLine b$ lbl = True sss = Len(b$) GoTo again1 End If IFCTRL = 0 ' NONEED ANYTHING AND ERROR FOR IF.ELSE AND ELSE Else If MaybeIsSymbol(b$, "0123456789") Then GoTo ContGoto IFCTRL = 0 jump = False End If sss = Len(b$) Case Else Execute = 0 Exit Function End Select Case Else Execute = 0 Exit Function End Select If once Then sss = Len(b$) GoTo again1 Else If jump Or IFCTRL = 2 Then ' lbl = True i = 1 If FastOperator(b$, vbCrLf, i, 2) Then While FastOperator(b$, vbCrLf, i, 2) Wend If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ.ΑΝ", "ELSE.IF", Lang) Then GoTo contElseIf If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo ContElse1 End If GoTo again1 End If End If lbl = False DropCommentOrLine b$, True If Len(b$) > 0 Then If Left$(b$, 2) <> vbCrLf Then GoTo againExtra2 End If Else Exit Do End If Else ' error If LastErNum = -2 Then Execute bstack, b$, True Else MissNumExpr End If Execute = 0 Exit Function End If sss = Len(b$) Case "SELECT", "ΕΠΕΛΕΞΕ", "ΕΠΙΛΕΞΕ" '*************************************** SELECT CASE contSelect: 'Us$ = vbNullString If once = True Then Execute = 0: Exit Function If exeSelect(Execute, once, bstack, b$, v, Lang) Then Exit Function End If If Len(b$) = 0 Then If Execute = 2 Then Exit Function If Execute = 51 Then Exit Function End If End If once = False lbl = False If Len(b$) > 0 Then If Left$(b$, 2) = vbCrLf Then lbl = True End If sss = Len(b$) Case "ΑΠΟ", "ON" '************************************* ON NUMBER GOTO LABELS ContOn: If IsExp(bstack, b$, p, flatobject:=True, nostring:=True) Then y1 = IsLabelSymbolNew(b$, "ΠΡΟΣ", "GOTO", Lang) y2 = False If Not y1 Then y1 = IsLabelSymbolNew(b$, "ΔΙΑΜΕΣΟΥ", "GOSUB", Lang) If Not y1 Then If likebasic Then y1 = IsLabelSymbolNew(b$, "ΕΠΑΝΑΦΟΡΑ", "RESTORE", Lang) If Not y1 Then MisGosub1 y2 = 2 Else If Not y1 Then MisGosub End If Else y2 = 1 End If End If If y1 Then On Error Resume Next p = CLng(p) If Err.Number = 6 Then OverflowValue vbLong Execute = 0 Exit Function End If On Error GoTo 0 If p <= 0 Then ' no exit SetNextLine b$ If Execute <> 2 Then Execute = 1 Else Execute = 3 b$ = vbNullString once = True Exit Function Else W$ = vbNullString i = 0 Do i = 1 x1 = FastPureLabel(b$, W$) If x1 = 0 Then If Not IsNumberLabel(b$, W$) Then p = 1000: Exit Do ElseIf x1 > 1 Then p = 1000 Exit Do End If i = 0 p = p - 1 If Not FastSymbol(b$, ",") Then Exit Do Loop Until p = 0# If p <> 0 Then If i = 0 Then If y2 = 2 Then W$ = "" GoTo RESTcontinue End If Execute = 1: W$ = GetNextLine$(b$): sss = Len(b$): End If W$ = vbNullString Else If i > 0 Then MissingLabel sss = LLL Execute = 0 Exit Function Else If y2 Then If y2 = 2 Then RESTcontinue: sw$ = W$ i = 1 Select Case bstack.OriginalCode Case Is > 0 W$ = sbf(Abs(bstack.OriginalCode)).sb Case Is < 0 W$ = var(-bstack.OriginalCode).Code$ End Select If Len(sw$) = 0 Then i = 1 Else i = PosLabel(sw$, W$) i = i - 2 End If aheadstatusDATA W$, i, ok If ok Then bstack.datasearch = Mid$(W$, i) If ok Then bstack.datasearch = Mid$(W$, i) SetNextLine b$ GoTo loopcontinue ElseIf bstack.SubLevel > deep And deep <> 0 Then If bstack.RetStackTotal >= 9 * deep Then NoMoreDeep deep Execute = 0 Exit Function Else bstack.RetStackDrop bstack.RetStackTotal End If InternalError NOEXECUTION = True Execute = 0 Exit Function End If If p = 1000 Then Exit Function SetNextLine b$ If x1 = 1 Then i = 1 GoTo contHereFromOn Else GoTo contHere2FromOn End If End If b$ = W$ Execute = 2 Exit Function End If End If End If Else sss = LLL End If Else missParam b$ Execute = 0 Exit Function End If Case "SUB", "ΡΟΥΤΙΝΑ" contSub: If once = True Then Execute = 0: Exit Function If Execute <> 2 Then b$ = W$ once = True Execute = 3 Else b$ = vbNullString End If Exit Function Case "GOSUB", "ΔΙΑΜΕΣΟΥ" ' bstack.addlen = Len(b$) autogosub: x1 = bstack.callx1 bstack.callx1 = 0 If bstack.SubLevel > deep And deep <> 0 Then ' GO BACK TO FIRST CALL If bstack.RetStackTotal >= 9 * deep Then NoMoreDeep deep Execute = 0 Exit Function Else bstack.RetStackDrop bstack.RetStackTotal End If InternalError NOEXECUTION = True Execute = 0 Exit Function End If If Len(bstack.tmpstr) = 0 Then i = FastPureLabel(b$, W$) If i = 6 Or i = 3 Then againsub: If Len(b$) = 0 Then bstack.tmpstr = W$ + " " b$ = Chr(8) Else bstack.tmpstr = W$ + Left$(b$, 1) Mid$(b$, 1, 1) = Chr(8) End If If Not IsStrExp(bstack, b$, W$, False) Then InternalError Execute = 0 Exit Function End If i = FastPureLabel(W$, "", , , , , False) If i = 5 Then bb$ = W$: GoTo constrsub End If Else If Len(b$) > 0 Then If AscW(b$) = 8 Then W$ = bstack.tmpstr Mid$(b$, 1, 1) = Right$(W$, 1) bstack.tmpstr = Left$(W$, Len(W$) - 1) End If End If i = FastPureLabel(bstack.tmpstr, W$) bstack.tmpstr = vbNullString If i = 6 Or i = 3 Then GoTo againsub If x1 = -1 Then If i <> 5 Then W$ = W$ + "(" i = 5 Else x1 = 0 End If ElseIf x1 = -2 Then If i > 4 Then bstack.tmpstr = Left$(W$, Len(W$) - 1) Else bstack.tmpstr = W$ End If End If End If contHereFromOn: If i = 5 Then once = False y1 = bstack.soros.Total PushStage bstack, False If Not PushParamSUB(bstack, b$) Then PopStage bstack y1 = bstack.soros.Total - y1 If y1 > 0 Then bstack.soros.drop y1 Execute = 0 Exit Function End If If x1 < 0 Then GoTo noParentheses ElseIf FastSymbol(b$, ")") Then If Len(b$) > 0 Then If Not MaybeIsSymbol(b$, b12345) Then bstack.SubLevel = bstack.SubLevel - 1 SyntaxError Execute = 0 Exit Function End If End If noParentheses: bstack.RetStack.PushLong Len(b$) '******************************** If Lang Then bstack.RetStack.PushStr "SUB " + W$ Else bstack.RetStack.PushStr "ΡΟΥΤΙΝΑ " + W$ End If b$ = ChrW$(0) loopthis = Execute = 2 Execute = 2 bstack.IFCTRL = IFCTRL bstack.jump = jump bstack.callx1 = x1 Exit Function Else ' popstage PopStage bstack If pagio <> "GREEK" Then MissSymbol " ) for calling sub " + W$ + ")" Else MissSymbol " ) για κλήση ρουτίνας " + W$ + ")" End If Execute = 0 Exit Function End If ElseIf i = 1 Then once = False PushStage bstack, True bstack.RetStack.PushVal Len(b$) bstack.RetStack.PushStr "S " + W$ b$ = Chr$(0) Execute = 2 Exit Function ElseIf i = 0 Then If IsNumberLabel(b$, W$) Then contHere2FromOn: once = False PushStage bstack, True ' CORRECT FROM REV 45 - VER 8 bstack.RetStack.PushVal Len(b$) bstack.RetStack.PushStr "* " + W$ b$ = Chr$(0) bstack.IFCTRL = IFCTRL bstack.jump = jump Execute = 2 Exit Function Else If Not IsStrExp(bstack, b$, bb$) Then InternalError Execute = 0 Exit Function End If constrsub: i = FastPureLabel(bb$, W$) If i = 5 Then once = False y1 = bstack.soros.Total PushStage bstack, False If Not PushParamSUB(bstack, bb$) Then PopStage bstack y1 = bstack.soros.Total - y1 If y1 > 0 Then bstack.soros.drop y1 Execute = 0 Exit Function End If If FastSymbol(bb$, ")") Then bstack.RetStack.PushVal Len(b$) If Lang Then bstack.RetStack.PushStr "SUB " + W$ Else bstack.RetStack.PushStr "ΡΟΥΤΙΝΑ " + W$ End If b$ = Chr$(0) '' here is the fault...execute 2 means loop... '' it is known only here... loopthis = Execute = 2 Execute = 2 bstack.IFCTRL = IFCTRL bstack.jump = jump Exit Function Else PopStage bstack MissSymbol ")" Execute = 0 Exit Function End If ElseIf i > 0 Then PopStage bstack bb$ = vbNullString x1 = 0 GoTo contHereFromOn End If End If Else bstack.tmpstr = W$ + Left$(b$, 1) If Len(b$) = 0 Then b$ = Chr(8) Else Mid$(b$, 1, 1) = Chr(8) Exit Do End If Case "BASIC" ContBASIC: If bstack.SubLevel > 0 Or bstack.IamThread Or bstack.IamAnEvent Then Execute = 0: BadUseOfBasic: Exit Function Else likebasic = True: FixRead bstack bstack.BasicSwitch = likebasic End If Case "RESTORE", "ΕΠΑΝΑΦΟΡΑ" ContRestore: If likebasic Then i = 1 Select Case bstack.OriginalCode Case Is > 0 W$ = sbf(Abs(bstack.OriginalCode)).sb Case Is < 0 W$ = var(-bstack.OriginalCode).Code$ End Select If Trim$(b$) = vbNullString Or FastSymbol(b$, ":") Then i = 1 aheadstatusDATA W$, i, ok If ok Then bstack.datasearch = Mid$(W$, i) Else i = FastPureLabel(b$, sw$, , , , , True) If i = 0 Then If Not IsNumberLabel(b$, sw$) Then i = 1 Else i = PosLabel(sw$, W$) i = i - 2 End If aheadstatusDATA W$, i, ok If ok Then bstack.datasearch = Mid$(W$, i) Else i = PosLabel(sw$, W$) aheadstatusDATA W$, i, ok If ok Then bstack.datasearch = Mid$(W$, i) End If End If If Not ok Then BadUseOfRestore Else BadUseOfRestore End If Case "GOTO", "ΠΡΟΣ" '**************************************** This is the GOTO statement ContGoto: ' If checkbreakEsc(bstack) Then Execute = 1: Exit Function If Trim$(b$) = vbNullString Or FastSymbol(b$, ":") Then Execute = 0 MissingLabel Exit Function Else ' GET OUT FOR NEXT bstack.LastIdpos = Len(b$) i = FastPureLabel(b$, W$, , , , , False) If i = 1 Then once = False b$ = W$ Execute = 2 Exit Function ElseIf i = 0 Then If IsNumberLabel(b$, W$) Then once = False b$ = W$ Execute = 2 Exit Function ' Else 'b$ = w$ & b$ End If Else 'b$ = w$ & b$ Exit Do End If End If Case "VAR", "VARIABLE", "VARIABLES", "ΜΕΤΑΒΛΗΤΗ", "ΜΕΤΑΒΛΗΤΕΣ" contVar: Select Case chektype1(bstack, b$, Lang) Case 0 Execute = 0: Exit Function Case 1 sss = LLL: lbl = False: jump = False GoTo loopcontinue Case 2 noVarStat = True sss = LLL: lbl = False: jump = False GoTo jump101 End Select Case "LOCAL", "ΤΟΠΙΚΑ", "ΤΟΠΙΚΗ", "ΤΟΠΙΚΕΣ" contNegLocal: ' If noVarStat Then SyntaxError: Execute = 0: Exit Function If Not NewStat Then If IsLabelSymbolNew(b$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbDouble) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbInteger) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbLong) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΠΛΟΣ", "SINGLE", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbSingle) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΚΟΣ", "BOOLEAN", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbBoolean) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΡΙΘΜΟΣ", "DECIMAL", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbDecimal) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbCurrency) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΓΡΑΜΜΑ", "STRING", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbString) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΤΥΠΟΣ", "VARIANT", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbVariant) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΟΜΑΔΑ", "GROUP", Lang) Then If Not ProcGroup(-1, bstack, b$, Lang) Then Execute = 0 Exit Function End If GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΨΗΦΙΟ", "BYTE", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbByte) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbDate) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΝΤΙΚΕΙΜΕΝΟ", "OBJECT", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbObject) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, vbObject, , New BigInteger) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΜΙΓΑΔΙΚΟΣ", "COMPLEX", Lang) Then If Not MyAnyType(bstack, b$, Lang, True, 200) Then Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΠΑΡ", "ENUM", Lang, , True) Then If Not ProcEnum(bstack, b$, , True) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΠΑΡΙΘΜΗΣΗ", "ENUMERATION", Lang, , True) Then If Not ProcEnum(bstack, b$, , True) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΔΙΕΠΑΦΗ", "INTERFACE", Lang) Then If Not ProcInter(bstack, b$, Lang, , True) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΔΟΜΗ", "STRUCTURE", Lang) Then If Not makestruct(bstack, b$, Lang, False, True) Then Execute = 0: Exit Function GoTo loopcontinue End If NewStat = True End If sss = Len(b$) LLL = sss iscom = True Select Case IsLabelDotSub(temphere$, b$, W$, ss$, (Lang), nchr) Case 1234, 0 GoTo errstat Case 1 If Left$(W$, 1) = "." Then ss$ = W$ IsLabel bstack, ss$, W$ End If GoTo VarOnly Case 2 noref Execute = 0 Exit Function Case 3 GoTo contcase3 Case 4 GoTo contcase4 Case 5 GoTo contcase5 Case 6 GoTo contcase6 Case 7 GoTo contcase7 End Select GoTo errstat Case "GLOBAL", "ΓΕΝΙΚΟ", "ΓΕΝΙΚΗ", "ΓΕΝΙΚΕΣ" contNegGlobal: ' If NewStat Then LocalAndGlobal: Execute = 0: Exit Function If Not VarStat Then If IsLabelSymbolNew(b$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbDouble) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbInteger) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbLong) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΠΛΟΣ", "SINGLE", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbSingle) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΚΟΣ", "BOOLEAN", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbBoolean) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΡΙΘΜΟΣ", "DECIMAL", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbDecimal) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbCurrency) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΓΡΑΜΜΑ", "STRING", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbString) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΤΥΠΟΣ", "VARIANT", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbVariant) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΨΗΦΙΟ", "BYTE", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbByte) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbDate) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΟΜΑΔΑ", "GROUP", Lang) Then ' group can't be used as variable because exist read only variable ' which pop group from stack If Not ProcGroup(1, bstack, b$, Lang) Then Execute = 0: Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΝΤΙΚΕΙΜΕΝΟ", "OBJECT", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbObject) Then Execute = 0: Exit Function GoTo loopcontinue ' ElseIf IsLabelSymbolNew(b$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, vbObject, , New BigInteger) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΜΙΓΑΔΙΚΟΣ", "COMPLEX", Lang) Then If Not MyAnyType(bstack, b$, Lang, False, 200) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΓΕΓΟΝΟΣ", "EVENT", Lang) Then If lookOne(b$, "=") Then VarStat = True If Lang = 0 Then W$ = "ΓΕΓΟΝΟΣ" Else W$ = "EVENT" End If sss = Len(b$) GoTo VarOnly End If If Not GlobalEVENT(bstack, b$, Lang) Then Execute = 0: Exit Function ElseIf IsLabelSymbolNew(b$, "ΚΑΤΑΣΤΑΣΗ", "INVENTORY", Lang) Then If lookOne(b$, "=") Then VarStat = True If Lang = 0 Then W$ = "ΚΑΤΑΣΤΑΣΗ" Else W$ = "INVENTORY" End If sss = Len(b$) GoTo VarOnly End If If IsLabelSymbolNew(b$, "ΟΥΡΑ", "QUEUE", Lang) Then If Not GlobalHandler(bstack, b$, Lang, 3) Then Execute = 0: Exit Function Else If Not GlobalHandler(bstack, b$, Lang, 1) Then Execute = 0: Exit Function End If ElseIf IsLabelSymbolNew(b$, "ΔΙΑΡΘΡΩΣΗ", "BUFFER", Lang) Then If lookOne(b$, "=") Then VarStat = True If Lang = 0 Then W$ = "ΔΙΑΡΘΡΩΣΗ" Else W$ = "BUFFER" End If sss = Len(b$) GoTo VarOnly End If If Not GlobalHandler(bstack, b$, Lang, 2) Then Execute = 0: Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΠΑΡ", "ENUM", Lang) Then If Not ProcEnum(bstack, b$, True) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΑΠΑΡΙΘΜΗΣΗ", "ENUMERATION", Lang) Then If Not ProcEnum(bstack, b$, True) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΔΟΜΗ", "STRUCTURE", Lang) Then If Not makestruct(bstack, b$, Lang, True, False) Then Execute = 0: Exit Function GoTo loopcontinue ElseIf IsLabelSymbolNew(b$, "ΔΙΕΠΑΦΗ", "INTERFACE", Lang) Then If Not ProcInter(bstack, b$, Lang, True) Then Execute = 0: Exit Function GoTo loopcontinue Else GoTo CONT12212 End If VarStat = True sss = Len(b$) Else CONT12212: VarStat = True sss = Len(b$) LLL = sss iscom = True Select Case IsLabelDotSub(temphere$, b$, W$, ss$, (Lang), nchr) Case 1234, 0 GoTo errstat Case 1 If Left$(W$, 1) = "." Then ss$ = W$ IsLabel bstack, ss$, W$ ElseIf comhash.Find2(W$, i, v) Then If i = 0 And v = 36 Then ConstNew bstack, b$, W$, True, Lang If LastErNum = -1 Then Execute = 0 Exit Function End If sss = Len(b$) GoTo loopcontinue End If End If GoTo VarOnly Case 2 noref Execute = 0 Exit Function Case 3 GoTo contcase3 Case 4 GoTo contcase4 Case 5 GoTo contcase5 Case 6 GoTo contcase6 Case 7 GoTo contcase7 End Select GoTo errstat End If Case "CONST", "ΣΤΑΘΕΡΗ", "ΣΤΑΘΕΡΕΣ" makeconst: ConstNew bstack, b$, W$, here$ = vbNullString, Lang If LastErNum = -1 Then Execute = 0 Exit Function End If ' sss = Len(b$) 'GoTo AGAIN1 Case Else If Not NoOptimum Then If Not iscom Then GoTo parsecommand Else iscom = False End If VarOnly: On ExecuteVar1(Execute, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers, forerror If NoOptimum Then If GetSub(W$, v) Then iscom = True End If End If parsecommand: 'If VarStat Or NewStat Then GoTo errstat ' ss$ If Not Identifier(bstack, W$, b$, iscom, Lang, ss$) Then If W$ = "ΜΕ" Then ' ΜΕ <100 If HaveMarkSelGr(bstack) Then loopthis = IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "", 0) ' we return as case or case else Execute = 100 Exit Function End If ElseIf W$ = "CASE" Then If HaveMarkSelEn(bstack) Then loopthis = IsLabelSymbolNew(b$, "", "ELSE", 1) ' we return as case or case else Execute = 100 Exit Function End If End If If NERR Then NOEXECUTION = True If LastErNum1 = 0 Then If Len(ss$) > 0 Then unknownid b$, ss$ Else unknownid b$, W$ End If End If conthere111: If LastErNum1 = -1 And bstack.IamThread Then Execute = 1 Else Execute = 0 Exit Function ' just happy here exitdo: Exit Do exitfunc: Set bstack.lastpointer = Nothing Exit Function Else If bstack.callx1 <> 0 Then If bstack.callx1 > 0 Then If Not ProcModuleEntry(bstack, "", 0, b$, Lang) Then If MOUT And b$ = vbNullString Then Else unknownid b$, W$ End If End If bstack.RemoveOptionals Else GoTo autogosub End If End If iscom = False conthere222: If bstack.connectnow Then bstack.connectnow = False End If lbl = False DropCommentOrLine b$, True sss = Len(b$) If Len(b$) > 0 Then If AscW(b$) = 8 Then GoTo asap ElseIf Left$(b$, 2) <> vbCrLf Then GoTo againExtra2 End If Else Exit Do End If 'If NocharsInLine(b$) Then Exit Do Else lbl = lookOne(b$, Chr(13)) End If End Select Else b$ = W$ + b$ Execute = 0 If FindNameForGroup(bstack, W$) Then UnknownProperty W$ Else UnknownVariable W$ End If Exit Function forerror: Execute = 0 Exit Function End If Case 2 If Not lbl Then b$ = W$ + b$: Exit Do b$ = Mid$(b$, 2) lbl = False sss = Len(b$) Case 3 contcase3: On ExecuteVar3(Execute, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers Case 4 contcase4: On ExecuteVar4(Execute, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers Case 5 contcase5: On ExecuteVar5(Execute, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers Case 6 contcase6: On ExecuteVar6(Execute, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers Case 7 contcase7: On ExecuteVar7(Execute, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers Case 8: asap: If Len(bstack.tmpstr) > 0 And Len(b$) > 0 Then W$ = bstack.tmpstr Mid$(b$, 1, 1) = Right$(W$, 1) If Left$(W$, 1) = "@" Then W$ = Mid$(W$, 2, Len(W$) - 2) ss$ = W$ W$ = myUcase(W$) GoTo parsecommand End If W$ = Left$(W$, Len(W$) - 1) b$ = NLtrim$(b$) If Right$(W$, 1) = "." Then x1 = IsLabelDotSub(temphere$, b$, sw$, ss$, Lang, nchr) W$ = W$ + sw$ ' sss = Len(b$) 'LLL = sss one = True nchr = AscW(W$) Else 'sss = Len(b$) 'LLL = sss SwapStrings sw$, W$ x1 = IsLabelDotSub(temphere$, sw$, W$, ss$, Lang, nchr) one = True If Len(Trim(sw$)) > 0 Then If nchr = 40 Then nchr = AscW(W$) b$ = sw$ + b$ Else nchr = AscW(sw$) End If ElseIf Len(W$) > 0 Then nchr = AscW(W$) Else nchr = 0 End If End If bstack.tmpstr = vbNullString GoTo again4 Else MyEr "Internal Error 2", "Εσωτερικό λάθος 2" Execute = 0 Exit Function End If Case 10 contcase10: If Left$(W$, 1) = "." Then If Not expanddot(bstack, W$) Then MyEr "too many dots", "πολλές τελείες" Execute = 0 Exit Function End If End If iscom = True lbl = False On ExecuteVar(Execute, 8, bstack, W$, b$, v, Lang, VarStat, NewStat, nchr, ss$, sss, temphere$, noVarStat) GoTo exitdo, autogosub, loopagain, contVarNew, again3, parsecommand, loopcontinue, exitfunc, forpointers, forfloatpointers Case Else If lookOne(b$, ".") Then b$ = NLtrim$(b$) nd& = Len(b$) If bstack.GetDot(b$, (1)) Then sss = (Len(b$) - nd&) + sss LLL = (Len(b$) - nd&) + LLL End If GoTo again2 Else one = False End If If MaybeIsSymbol(b$, ",+*/_!@()[];<>|~`0123456789") Then SyntaxError Execute = 0 Exit Function End If End Select loopcontinue: If once Then If Not lookOne(b$, ":") Then Exit Do Else If onlyone Then Exit Do End If End If loopagain: If one Then If linebyline Then If Not lookOne(b$, ":") Then Exit Do End If End If Loop JUMPHERE: If linebyline Then With bstack .IFCTRL = IFCTRL .jump = jump End With Exit Function ElseIf onlyone Then Exit Function End If 'linebyline = False 'If Len(b$) > 0 Then If AscW(b$) = 34 Then SyntaxError: Execute = 0 'If Len(b$) > 0 Then If sss = LLL Then SyntaxError: Execute = 0 If m_bInIDE Then If Len(b$) > 0 Then Debug.Print "Execute:", sss, LLL, bstack.OriginalCode, bstack.originalname If bstack.OriginalCode >= 0 Then Debug.Print Left$(sbf(bstack.OriginalCode).sb, 200) Else ' from lambda function Debug.Print Left$(var(-bstack.OriginalCode).Code$, 200) End If 'If sss = LLL Then SyntaxError: Execute = 0 End If End If Exit Function errstat0: If Err.Number = 13 Then MyEr Err.Description, "λάθος τύπος παραμέτρου" Else MyEr Err.Description, Err.Description End If Err.Clear Execute = 0: Exit Function errstat1: MissModuleName Execute = 0: Exit Function errstat: MissVarName Execute = 0: Exit Function LONGERR: If Err.Number = 6 Then Execute = 0 OverflowValue ElseIf Err.Number = 450 Then jwrong: Execute = 0 WrongOperator End If Exit Function forfloatpointers: Set ppppl = BoxGroupObj(bstack.lastpointer) v = 0 Set bstack.lastpointer = Nothing Execute = SpeedGroup(bstack, ppppl, "", W$, b$, v) Set ppppl = Nothing ' now group ref counting work fine If Execute = 0 Then Exit Function ElseIf Execute <> 1 And b$ <> "" Then once = False Exit Function End If sss = Len(b$) GoTo loopagain forpointers: If Len(b$) > 1 Then If Not bstack.lastpointer Is Nothing Then ' Mid$(b$, 1, 1) = " " nchr = 0 x1 = IsLabelDotSub(temphere$, b$, W$, ss$, Lang, nchr) With bstack.lastpointer If x1 = 0 Then Select Case nchr Case 40 If .link.HasStrValue Then If here$ = .lasthere Then W$ = .GroupName + "$(" Else W$ = .lasthere + "." + .GroupName + "$(" End If Mid$(b$, 1, 1) = " " x1 = 6 sss = Len(b$) GoTo contcase6 Else If here$ = .lasthere Then W$ = .GroupName + "(" Else W$ = .lasthere + "." + .GroupName + "(" End If Mid$(b$, 1, 1) = " " x1 = 5 sss = Len(b$) GoTo contcase5 End If Case 60 W$ = .lasthere + "." + .GroupName Case Else If here$ = .lasthere Then W$ = .GroupName Else W$ = .lasthere + "." + .GroupName End If End Select x1 = 1 GoTo VarOnly Else If .lasthere = vbNullString Then W$ = .GroupName + "." + W$ Else W$ = .lasthere + "." + .GroupName + "." + W$ End If If MaybeIsSymbol3(b$, "=", i) Then If i = 1 Then Mid$(b$, 1, 1) = "_" Else Mid$(b$, i - 1, 1) = "<" End If End If End If End With Set bstack.lastpointer = Nothing Else InternalError Execute = 0 Exit Function End If End If GoTo again4 End Function Function GoFunc(mystack As basetask, what$, rest$, vl As Variant, Optional Recursive As Long, Optional ByVal choosethis As Long = -1, Optional ByVal strg As Boolean = False, Optional ByVal usesamestack As Boolean = False) As Boolean Dim f As Long, it As Long, pa$ Dim x1 As Long, par As Boolean, ohere$, W$, loopthis As Boolean Dim Vars As Long, Vname As Long, subs As Long, snames As Long Dim once As Boolean, RetStackSize As Long Dim subsfc As FastCollection Dim c As Constant, myl As lambda Dim basestack As basetask Dim ok As Boolean, nokillvars As Boolean Dim i As Long, p As Long, S3 As Long, bb$, Code$, ec$, small$, sbi As Long Set basestack = mystack.Parent If basestack Is Nothing Then Set basestack = mystack ohere$ = here$ Dim backup$, TSHB As Boolean If trace Then SwapStrings backup$, TestShowSub: TSHB = TestShowBypass TestShowBypass = False If CurrentStackSize > stacksize Then MyEr "Function's Stack is Full - 15", "Η στοίβα των συναρτήσεων έχει γεμίσει - 15" MOUT = True Set basestack = Nothing GoFunc = False: GoTo lastfun End If pa$ = mystack.UseGroupname mystack.UseGroupname = basestack.UseGroupname mystack.Look2Parent = True mystack.strg = strg mystack.fHere = here$ Vname = varhash.Count Vars = var2used If usesamestack Then Set mystack.Sorosref = basestack.soros Else If Not PushParamGeneralV70(mystack, rest$, basestack.restpart) Then mystack.Look2Parent = False GoTo lastfun End If End If mystack.Look2Parent = False mystack.UseGroupname = pa$ If choosethis >= 0 Then x1 = choosethis If what$ = vbNullString Then If SecureNames Then If Left$(here$, 1) <> "_" Then If basestack.IamThread Then here$ = "_" + LTrim$(str$(basestack.Process.id)) + here$ here$ = RVAL33(here$, x1) Else here$ = RVAL(here$, 1) + mystack.originalname End If ElseIf Recursive Then here$ = RVAL(here$, 1) + "." + Trim$(what$) If SecureNames Then If basestack.IamThread Then If Left$(here$, 1) <> "_" Then here$ = "_" + LTrim$(basestack.Process.id) + here$: basestack.StaticInUse = LTrim$(basestack.Process.id) Else If SecureNames Then If basestack.IamThread Then If basestack.StaticInUse = vbNullString Then basestack.StaticInUse = LTrim$(basestack.Process.id) End If Else If InStr(what$, "(") > 0 Then If GetSub(what$, x1) Then If here$ = vbNullString Then If ohere$ = vbNullString Then here$ = what$ Else here$ = RVAL(here$, 1) + "." + what$ ' Left$(Trim$(what$), 1) & x1 If SecureNames Then If basestack.IamThread Then If Left$(here$, 1) <> "_" Then here$ = "_" + LTrim$(basestack.Process.id) + here$: basestack.StaticInUse = LTrim$(basestack.Process.id) End If ElseIf GetSub2(basestack, what$, x1) Then If here$ = vbNullString Then If ohere$ = vbNullString Then here$ = what$ Else here$ = RVAL(here$, 1) + "." + Trim$(what$) End If End If Else If here$ = vbNullString Then If GetSub(what$, x1) Then here$ = RVAL(here$, 1) End If ElseIf GetlocalSub(what$, x1) Then here$ = RVAL(here$, 1) ElseIf GetSub(what$, x1) Then here$ = RVAL(here$, 1) ElseIf Recursive > 0 Then here$ = RVAL(here$, 1) x1 = Recursive End If End If End If ' prepare function for static variables If iRVAL(basestack.StaticInUse, 0) = 0 Then mystack.StaticInUse = RVAL(basestack.StaticInUse, 1) + "." + what$ + mystack.StaticInUse ' If Not basestack Is Basestack1 Then If Not basestack.StaticCollection Is Nothing Then StaticWork basestack, mystack, mystack.StaticInUse$ End If ' End If ElseIf basestack.OriginalCode = mystack.OriginalCode Then mystack.StaticInUse = basestack.StaticInUse Set mystack.StaticCollection = basestack.StaticCollection Else mystack.StaticInUse = RVAL(basestack.StaticInUse, 1) + "." + what$ + mystack.StaticInUse If mystack.CallLocalLast Then mystack.StaticInUse = basestack.StaticInUse ElseIf Not basestack Is Basestack1 Then If Not basestack.StaticCollection Is Nothing Then StaticWork basestack, mystack, mystack.StaticInUse$ End If End If End If If here$ <> ohere$ Or mystack.IamChild Or basestack.IamAnEvent Then subs = sb2used: snames = subHash.Count If Not mystack.CallLocalLast Then With mystack .commnum = comhash.Count .strfunnum = strfunid.Count .numfunnum = funid.Count .strnum = strid.Count .numnum = numid.Count End With End If i = 1: FK$(13) = vbNullString nokillvars = basestack.nokillvars: basestack.nokillvars = False If nokillvars Then mystack.ErrVars = basestack.ErrVars If sbf(x1).sbc Then numid.pushtopGlobal funid.pushtopGlobal strfunid.pushtopGlobal strid.pushtopGlobal End If Else mystack.ErrVars = var2used End If If Mid$(sbf(x1).sb, i) = vbNullString Then GoFunc = True If sbf(x1).Extern = 0 Then GoTo emptyfunc End If mystack.originalname$ = here$ If usesamestack Then GoFunc = True ElseIf FastSymbolNoTrimAfter(rest$, ")") Then GoFunc = True ElseIf GoFunc Then MyEr "Missing )", "λείπει )" GoFunc = False GoTo lastfun End If If FastSymbol(rest$, "<<", , 2) Then f = 1 W$ = aheadstatus(rest$, True, f) W$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) f = 1 While FastSymbol(rest$, "<<", , 2) pa$ = aheadstatus(rest$, True, f) W$ = W$ + " << " + Left$(rest$, f - 1) rest$ = Mid$(rest$, f) f = 1 Wend mystack.CallW = W$ mystack.NoFuncError = True par = True End If Do If choosethis >= 0 Then mystack.UseGroupname = pa$ Else mystack.UseGroupname = sbf(x1).sbgroup mystack.tpointer = sbf(x1).tpointer End If Code$ = Mid$(sbf(x1).sb, i) If Len(Code$) = 0 Then If sbf(x1).Extern > 0 Then If Not PrepareLambda(mystack, myl, sbf(x1).Extern, Code$, c) Then GoTo fastexit End If End If End If it = 1 RetStackSize = mystack.RetStackTotal againstream: ec$ = Code$ If Len(ec$) > 0 Then it = 1 ok = False once = True i = 1 Do bb$ = Mid$(ec$, i) subsentry10: ok = False Select Case Execute(mystack, bb$, ok, False, loopthis) ' this is a major point Case 0 thh: Code$ = bb$ it = 0 Set mystack.lastobj = Nothing GoTo normalexit Case 1 If LastErNum <> 0 Then Code$ = vbNullString If once Then Exit Do here$ = ohere$ Exit Do Case 2 If Not ok Then i = 1 If Len(bb$) <> 0 Then If bb$ = ChrW$(0) Then If trace Then TestShowBypass = False If RetStackSize = mystack.RetStackTotal And mystack.RetStack.LookTopVal < 0 Then ' this is a return form other block it = 2 SwapStrings Code$, bb$ GoTo fastexit End If If Not mystack.IsInRetStackString(small$) Then p = mystack.isPop3Long(S3, sbi) If p > 0 Then If S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then bb$ = Mid$(ec$, Len(ec$) - p + 1) Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code ElseIf S3 = 0 Then TestShowSub = ec$ Else TestShowSub = sbf(S3).sb End If End If mystack.addlen = sbi End If PopStage mystack GoTo subsentry10 Else fulty: MyEr "Fault in Return", "Λάθος στην Επιστροφή" mystack.Flush Exit Do End If Else If InStr(small$, " ") > 0 Then mystack.PushSecondThird S3, sbi If searchsub(0, mystack.OriginalCode, small$, i, S3, bb$) Then mystack.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead7(mystack, small$, 1) Then GoTo thh GoTo contSub ElseIf mystack.IamChild Then mystack.callx1 = 0 If searchsub(mystack.OriginalCode, FindPrevOriginal(mystack), small$, i, S3, bb$) Then If Len(small$) <> 0 Then If Not MyRead7(mystack, small$, 1) Then GoTo thh contSub: If Len(bb$) = 0 Then If S3 < 0 Then bb$ = Mid$(var(-S3).Code, i) Else bb$ = Mid$(sbf(S3).sb, i) End If sbi = 0 Else If S3 < 0 Then sbi = Len(var(-S3).Code) - i - Len(bb$) + 1 Else sbi = Len(sbf(S3).sb) - i - Len(bb$) + 1 End If End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If End If mystack.addlen = Len(TestShowSub) - i + 1 - Len(bb$) End If GoTo subsentry10 Else therebad: If mystack.callx1 < 0 Then mystack.callx1 = 0 small$ = Split(small$, " ")(1) small$ = Left$(small$, Len(small$) - 1) If Not mystack.IsDecimal Then rest$ = Right(Code$, mystack.LastIdpos - 1 - Len(small$)) End If unknownModule rest$, small$ Else If Len(Split(small$, " ")(0)) = 1 Then small$ = Split(small$, " ")(1) unknownLabel rest$, small$ Else small$ = Split(small$, " ")(1) unknownSub rest$, Left$(small$, Len(small$) - 1) End If End If SwapStrings bb$, rest$ If mystack.IsDecimal Then p = mystack.Pop3Long(S3, sbi) If mystack.LastIdpos > 0 Then p = mystack.LastIdpos bb$ = Right$(Code$, p) ElseIf S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then bb$ = Mid$(ec$, Len(ec$) - p + 1) Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If End If mystack.LastIdpos = 0 mystack.RetStackDrop 3 '5 GoTo thh ' see procmoduleentry myerror1: for additional code ' or exit do ??? End If Else GoTo therebad End If End If End If ElseIf bb$ = "BREAK" Then GoTo breakexit Else If subsfc Is Nothing Then Set subsfc = New FastCollection If subsfc.ExistKey(bb$) Then i = subsfc.Value If subsfc.sValue = 0 Then If i = 0 Or i > Len(ec$) Then SwapStrings rest$, bb$ ' bstack.addlen = nd& GoTo thh Else bb$ = Mid$(ec$, i) sbi = 0 ' ???? CHECK THIS End If Else S3 = subsfc.sValue If S3 < 0 Then If i = 0 Or i > Len(var(-S3).Code$) Then SwapStrings rest$, bb$ ' bstack.addlen = nd& GoTo thh Else AGAINGOTOLAMBDA: If mystack.SubLevel > 0 Then If Len(var(-S3).Code$) - i > sbi Then bb$ = Mid$(var(-S3).Code$, i, Len(var(-S3).Code$) - i - sbi) Else bb$ = Mid$(var(-S3).Code$, i) sbi = 0 End If Else bb$ = Mid$(var(-S3).Code$, i) sbi = 0 End If End If Else If i = 0 Or i > Len(sbf(S3).sb) Then SwapStrings rest$, bb$ ' bstack.addlen = nd& GoTo thh End If AGAINGOTO: If mystack.SubLevel > 0 Then If Len(sbf(S3).sb) - i > sbi Then bb$ = Mid$(sbf(S3).sb, i, Len(sbf(S3).sb) - i - sbi) Else bb$ = Mid$(sbf(S3).sb, i) sbi = 0 End If Else bb$ = Mid$(sbf(S3).sb, i) sbi = 0 End If End If End If GoTo subsentry10 Else If S3 = 0 Then i = PosLabel(bb$, ec$) If i = 0 Or i > Len(ec$) Then GoTo checkother Else subsfc.ItemCreator2 bb$, i, 0 bb$ = Mid$(ec$, i) sbi = 0 GoTo subsentry10 End If End If checkother: If S3 < 0 Then i = PosLabel(bb$, var(-S3).Code$) If i = 0 Or i > Len(var(-S3).Code$) Then SwapStrings rest$, bb$ ' bstack.addlen = nd& GoTo thh End If subsfc.ItemCreator2 bb$, i, S3 GoTo AGAINGOTOLAMBDA Else i = PosLabel(bb$, sbf(S3).sb) If i = 0 Or i > Len(sbf(S3).sb) Then rest$ = Right$(Code$, mystack.LastIdpos - 1 - Len(bb$)) mystack.LastIdpos = 0 unknownLabel rest$, bb$ SwapStrings rest$, bb$ GoTo thh End If subsfc.ItemCreator2 bb$, i, S3 GoTo AGAINGOTO End If GoTo subsentry10 End If End If Else loopthis = False End If Else ' ok is true Code$ = "" once = ok it = 2: Set mystack.lastobj = Nothing GoTo breakexit End If Case Else If once Then Exit Do here$ = ohere$ Exit Do End Select here$ = ohere$ ' If checkbreakEsc(mystack) Then it = 1: Exit Do Loop ElseIf mystack.UseofIf > 0 Then MissENDIF it = 0 Else it = 1 End If breakexit: normalexit: fastexit: TestShowBypass = False If Not myl Is Nothing Then myl.CopyFromVar mystack, var() If c Is Nothing Then Set var(sbf(x1).Extern) = myl End If If Not basestack.CopyInOutCol Is Nothing Then CopyBack basestack Select Case it ''Execute(mystack, code$, False) Case 0 Set mystack.lastobj = Nothing Set mystack.FuncObj = Nothing mystack.ThrowThreads ' always throw threads If Not NERR Then ' Nerr = true from command ERROR 0 means Fatal Error, shows a message and act as a crash! If Not myl Is Nothing Then MyErMacro rest$, Chr(0) + "Problem in lambda", Chr(0) + "Πρόβλημα στη λάμδα" FK$(13) = "EDIT " & GetName(sbf(myl.OriginalCode).goodname) & "," & (-myl.lastlen - Len(bb$)) GoTo there1234 End If If Len(mystack.UseGroupname) > 0 Then If InStr(mystack.UseGroupname, ChrW(&H1FFF)) > 0 Then pa$ = GetNextLine((sbf(Abs(mystack.OriginalCode)).sb)) If InStr(pa$, ",") = 0 Then pa$ = "'11001EDIT " + GetModuleName(mystack, here$) + "," + Mid$(pa$, 11) End If FK$(13) = Mid$(pa$, 7) + "-" + LTrim$(str(Len(NLtrim$(Code$)))) If Right$(GetName(sbf(x1).goodname), 2) = "()" Then MyErMacro rest$, "Problem in class in function " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), ""), "Πρόβλημα στη κλάση στη συνάρτηση " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), "") Else MyErMacro rest$, "Problem in class in module " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), ""), "Πρόβλημα στη κλάση στο τμήμα " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), "") End If GoTo there1234 End If End If pa$ = GetModuleName(mystack, here$) If Right$(pa$, 1) = "(" Then pa$ = pa$ + ")" pa$ = "EDIT " & pa$ & ", " & (Len(sbf(x1).sb) + 1) If Left$(sbf(x1).sb, 10) = "'11001EDIT" Then With sbf(x1) pa$ = Mid$(GetNextLine(.sb), 7) ''+ "+1" .sb = Mid$(.sb, 3) ' needed because we measure length...look the preparation of Shift F1 below Set .subs = Nothing Set .Pad = Nothing End With If what$ <> "" Then If InStrRev(here$, ".") > 0 Then MyEr "in function " + Replace(GetName(what$), ChrW(&HFFBF), ""), "στη συνάρτηση " + Replace(GetName(what$), ChrW(&HFFBF), "") ' Mid$(what$, InStrRev(what$, ".") + 1) Else MyEr "in function " + what$, "στη συνάρτηση " + what$ End If Else If Right$(GetName(sbf(x1).goodname), 2) = "()" Then MyEr "in function ", "στη συνάρτηση " Else MyEr "in module ", "στο τμήμα " End If End If Else If Right$(here$, 1) = ")" Then If what$ <> "" Then MyEr "in function " + Replace(GetName(what$), ChrW(&HFFBF), ""), "στη συνάρτηση " + Replace(GetName(what$), ChrW(&HFFBF), "") 'Mid$(what$, InStrRev(what$, ".") + 1) Else MyEr "in function ", "στη συνάρτηση " End If Else MyEr "in module " + GetName(here$), "στο τμήμα " + GetName(here$) End If End If If (Len(sbf(x1).sb) - Len(Code$)) < 0 Then ' Maybe in a galaxy far away FK$(13) = pa$ Else ' Or in Earth If Len(pa$) > 0 Then ' prepare Shift F1 for a jump to the point of interest..the faulty one If InStr(FK$(13), ",") > 0 Then GoTo there1234 '' forget it ''If Left$(pa$, InStr(pa$, ",")) = Left$(FK$(13), InStr(FK$(13), ",")) Then GoTo there1234 End If If (Len(sbf(x1).sb) - Len(Code$)) < 0 Then FK$(13) = pa$ Else DropLeft ",", FK$(13) If FK$(13) <> "" Then FK$(13) = "+" + FK$(13) FK$(13) = pa$ & "-" & LTrim$(str(Len(Code$) - 1)) + FK$(13) End If End If End If there1234: If LastErNum = 0 Then MyErMacro rest$, "", "" End If GoFunc = False If Not basestack.CopyInOutCol Is Nothing Then CopyBack basestack here$ = ohere$ If Not mystack.CallLocalLast Then With mystack If .commnum <> comhash.Count Then comhash.ReduceHash2 .commnum If .numfunnum <> funid.Count Then funid.ReduceHash .numfunnum If .strfunnum <> strfunid.Count Then strfunid.ReduceHash .strfunnum If .numnum <> numid.Count Then numid.ReduceHash .numnum If .strnum <> strid.Count Then strid.ReduceHash .strnum End With If nokillvars Then If sbf(x1).sbc Then numid.poptopGlobal funid.poptopGlobal strfunid.poptopGlobal strid.poptopGlobal End If End If End If If var2used > Vars Then var2used = Vars varhash.ReduceHash Vname, var() If UBound(var()) <> varhash.MaxSpace Then ReDim Preserve var(varhash.MaxSpace) As Variant End If sb2used = subs subHash.ReduceHash snames, sbf() If UBound(sbf()) <> subHash.MaxSpace Then ReDim Preserve sbf(subHash.MaxSpace) As modfun End If basestack.soros.MergeTop mystack.soros Exit Do Case 1, 3 If Len(W$) > 0 Then pa$ = block(Code$) If FastSymbol(Code$, "}") Then GoTo againstream End If emptyfunc: here$ = mystack.originalname$ mystack.ThrowThreads Set mystack.lastobj = mystack.FuncObj Set mystack.FuncObj = Nothing If MyIsObject(mystack.lastobj) Then If mystack.lastobj Is Nothing Then If myVarType(vl, &H4008) Then If myVarType(mystack.FuncValue, vbString) Then vl = mystack.FuncValue Else vl = fixthis(mystack.FuncValue) End If Else vl = mystack.FuncValue End If Else Set basestack.lastobj = mystack.lastobj End If Else If myVarType(vl, &H4008) Then If myVarType(mystack.FuncValue, vbString) Then vl = mystack.FuncValue Else vl = fixthis(mystack.FuncValue) End If Else vl = mystack.FuncValue End If End If here$ = ohere$ If Not mystack.CallLocalLast Then With mystack If .commnum <> comhash.Count Then comhash.ReduceHash2 .commnum If .numfunnum <> funid.Count Then funid.ReduceHash .numfunnum If .strfunnum <> strfunid.Count Then strfunid.ReduceHash .strfunnum If .numnum <> numid.Count Then numid.ReduceHash .numnum If .strnum <> strid.Count Then strid.ReduceHash .strnum End With End If If Not nokillvars Then If var2used > Vars Then var2used = Vars varhash.ReduceHash Vname, var() If UBound(var()) <> varhash.MaxSpace Then ReDim Preserve var(varhash.MaxSpace) As Variant End If sb2used = subs subHash.ReduceHash snames, sbf() If UBound(sbf()) <> subHash.MaxSpace Then ReDim Preserve sbf(subHash.MaxSpace) As modfun End If Else If sbf(x1).sbc Then numid.poptopGlobal funid.poptopGlobal strfunid.poptopGlobal strid.poptopGlobal End If End If Exit Do Case 2 mystack.ThrowThreads ' for safety... i = 1 If Code$ <> "" Then If Code$ = Chr$(0) Then If basestack.IsInRetStackNumberLong(p) Then i = Len(sbf(x1).sb) - p + 1 Else If InStr(Code$, vbCr) > 0 Then i = rinstr(sbf(x1).sb, Code$) If i = 0 Then i = Len(sbf(x1).sb) + 1 Else i = PosLabel(Code$, sbf(x1).sb) End If End If Else GoTo emptyfunc End If Case 12 MyEr "Exit for out of for next loop", "Έξοδος για έξω από Για Επόμενο" GoFunc = False Exit Do End Select Loop Else rest$ = what$ + " " + rest$ GoFunc = False End If lastfun: If trace Then SwapStrings backup$, TestShowSub: TestShowBypass = TSHB End Function Function RepPara(basestack As basetask, rest$) As Boolean Dim x1 As Long, y1 As Long, i As Long, j As Long Dim X As Double, Y As Long, YY, ss$, s$, what$ Dim pppp As mArray, aa() As String, p As Variant RepPara = True i = 1 If MaybeIsSymbol3(rest$, "&", i) Then Mid$(rest$, i, 1) = " " GoTo there2 ' Overwrite &A, ".", 1:="Hello",5:="one more" End If x1 = FastPureLabel(rest$, what$, i, True, True, j, False) If x1 = 3 Or x1 = 6 Then GoTo there ' Overwrite A$, ".", 1:="Hello",5:="one more" If Not IsExp(basestack, rest$, YY, , , , True) Then there: Err.Clear On Error Resume Next ' new mode If Left$(rest$, 1) = "&" Then Mid$(rest$, 1, 1) = " " there2: x1 = Abs(IsLabel(basestack, rest$, what$)) If x1 = 8 Then NotForArrayBrackets RepPara = False Exit Function ElseIf x1 = 3 Or x1 = 1 Then If GetVar(basestack, what$, i) Then If x1 = 1 Then If Not myVarType(var(i), vbString) Then MissingStrVar: RepPara = False: Exit Function If FastSymbol(rest$, ",") Then If IsStrExp(basestack, rest$, ss$, False) Then aa = Split(var(i), ss$) Do While FastSymbol(rest$, ",") RepPara = True If IsExp(basestack, rest$, p, flatobject:=True) Then p = Abs(p) If FastSymbol(rest$, ":=", , 2) Then If IsStrExp(basestack, rest$, s$, False) Then ' HERE PLACE PART TO ARRAY, MAKE IT BIGGER IF NEEDED If UBound(aa) < p Then ReDim Preserve aa(p) aa(p) = s$ Else aa(p) = s$ End If Else RepPara = False End If Else RepPara = False End If Else RepPara = False Exit Do End If Loop If IsObject(var(i)) Then var(i).EmptyDoc var(i).textDoc = Join(aa, ss$) Else var(i) = Join(aa, ss$) End If Else MissStringExpr End If Else MissPar End If End If ElseIf x1 = 6 Or x1 = 5 Then If neoGetArray(basestack, what$, pppp) Then If Not NeoGetArrayItem(pppp, basestack, what$, i, rest$) Then RepPara = False: Exit Function If Not pppp.IsStringItem(i) Then If pppp.ItemType(i) <> doc Then MissType RepPara = False Exit Function End If End If If FastSymbol(rest$, ",") Then If IsStrExp(basestack, rest$, ss$) Then aa = Split(pppp.item(i), ss$) Do While FastSymbol(rest$, ",") RepPara = True If IsExp(basestack, rest$, p, flatobject:=True) Then p = Abs(p) If FastSymbol(rest$, ":=", , 2) Then If IsStrExp(basestack, rest$, s$, False) Then ' HERE PLACE PART TO ARRAY, MAKE IT BIGGER IF NEEDED If UBound(aa) < p Then ReDim Preserve aa(p) aa(p) = s$ Else RepPara = False End If Else RepPara = False End If Else RepPara = False Exit Do End If Loop If IsObject(pppp.item(i)) Then pppp.item(i).EmptyDoc pppp.item(i).textDoc = Join(aa, ss$) Else pppp.item(i) = Join(aa, ss$) End If Else MissStringExpr End If Else MissPar End If End If Else MyEr "Need a string/document as variable/array item or a numeric expression, look help", "Χρειάζομαι αλφαριθμητικό ή έγγραφο σε μεταβλητή ή σε στοιχείο πίνακα ή μια έκφραση αριθμητική, δες βοήθεια" RepPara = False End If Exit Function Else Err.Clear On Error Resume Next Y = CLng(YY) If Err Then Overflow RepPara = False Exit Function End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, X) Then X = Int(X) If X < 1 Then MyErMacro rest$, "the index base must be >=1", "η βάση δείκτη πρέπει να είναι >=1" Exit Function End If End If Else X = 0 End If If Left$(rest$, 1) = "&" Then Mid$(rest$, 1, 1) = " " x1 = Abs(IsLabel(basestack, rest$, what$)) If x1 = 3 Then If GetVar(basestack, what$, i) Then If VarTypeName(var(i)) = doc Then If Not FastSymbol(rest$, "=") Then MissSymbol "=" RepPara = False Exit Function Else If Not IsStrExp(basestack, rest$, what$) Then MissStringExpr RepPara = False Exit Function Else s$ = GetNextLineNoTrim(what$) j = var(i).ParagraphFromOrder(Y) If j = -1 Then MyErMacro rest$, "no such paragraph" & (Y), "δεν υπάρχει τέτοια παράγραφος" & (Y) Exit Function Else If X > 1 Then If what$ = vbNullString Then ss$ = var(i).TextParagraph(j) s$ = Left(ss$ + space$(X - 1), X - 1) + s$ + Mid$(ss$, Len(s$) + X) Else s$ = Left(var(i).TextParagraph(j) + space$(X - 1), X - 1) + s$ End If End If ''var(i).ReWritePara j, s$ var(i).TextParagraph(j) = s$ SetNextLine what$ While what$ <> "" s$ = GetNextLineNoTrim(what$) Y = Y + 1 j = var(i).ParagraphFromOrder(Y) If j = -1 Then var(i).AppendParagraph s$ Else If what$ = vbNullString Then s$ = s$ + Mid$(var(i).TextParagraph(j), Len(s$) + 1) ''var(i).ReWritePara j, s$ var(i).TextParagraph(j) = s$ End If SetNextLine what$ Wend End If End If End If Else MissingDoc ' only doc not string var RepPara = False Exit Function End If Else Nosuchvariable what$ RepPara = False Exit Function End If ElseIf x1 = 6 Then If neoGetArray(basestack, what$, pppp) Then If Not NeoGetArrayItem(pppp, basestack, what$, i, rest$) Then RepPara = False: Exit Function If pppp.ItemType(i) = doc Then If Not FastSymbol(rest$, "=") Then MissSymbol "=" RepPara = False Exit Function Else If IsStrExp(basestack, rest$, what$) Then s$ = GetNextLineNoTrim(what$) j = pppp.item(i).ParagraphFromOrder(Y) If j = -1 Then MyErMacro rest$, "no such paragraph" & (Y), "δεν υπάρχει τέτοια παράγραφος" & (Y) Exit Function Else If X > 1 Then If what$ = vbNullString Then ss$ = pppp.item(i).TextParagraph(j) s$ = Left(ss$ + space$(X - 1), X - 1) + s$ + Mid$(ss$, Len(s$) + X) Else s$ = Left(pppp.item(i).TextParagraph(j) + space$(X - 1), X - 1) + s$ End If End If pppp.item(i).TextParagraph(j) = s$ SetNextLine what$ While what$ <> "" s$ = GetNextLineNoTrim(what$) Y = Y + 1 j = pppp.item(i).ParagraphFromOrder(Y) If j = -1 Then pppp.item(i).AppendParagraph s$ Else If what$ = vbNullString Then s$ = s$ + Mid$(pppp.item(i).TextParagraph(j), Len(s$) + 1) pppp.item(i).TextParagraph(j) = s$ End If SetNextLine what$ Wend End If Else MissStringExpr RepPara = False Exit Function End If End If Else MissingDoc ' only doc not string var RepPara = False Exit Function End If End If Else MissingDoc ' only doc not string var RepPara = False Exit Function End If End If End Function Function IdentifierGroup(basestack As basetask, what$, rest$, Lang As Long, alocal As Boolean, addlen As Long) As Boolean IdentifierGroup = True Select Case what$ Case "&" IdentifierGroup = MyFunction(2, basestack, rest$, Lang, addlen) Exit Function Case "FUNCTION", "ΣΥΝΑΡΤΗΣΗ" IdentifierGroup = MyFunction(-1, basestack, rest$, Lang, True, alocal, addlen) Exit Function Case "MODULE", "ΤΜΗΜΑ" IdentifierGroup = MyModule(basestack, rest$, Lang, True, alocal, addlen, True) Exit Function Case "SUPERCLASS", "ΥΠΕΡΚΛΑΣΗ" IdentifierGroup = ProcClass(basestack, rest$, Lang, True) Exit Function Case "GROUP", "ΟΜΑΔΑ" IdentifierGroup = ProcGroup(0, basestack, rest$, Lang) Exit Function Case "CLASS", "ΚΛΑΣΗ" IdentifierGroup = ProcClass(basestack, rest$, Lang, False) Exit Function Case "DIM", "ΠΙΝΑΚΑΣ", "ΠΙΝΑΚΕΣ" IdentifierGroup = MyDim(basestack, rest$, Lang, alocal) Exit Function Case "ΚΑΤΑΣΤΑΣΗ", "INVENTORY" IdentifierGroup = ProcInventory(basestack, rest$, Lang, alocal) Exit Function Case "ΔΙΑΡΘΡΩΣΗ", "BUFFER" IdentifierGroup = ProcBuffer(basestack, rest$, Lang) Exit Function Case "EVENT", "ΓΕΓΟΝΟΣ" IdentifierGroup = myEvent(basestack, rest$, Lang, alocal) Exit Function Case "DOCUMENT", "ΕΓΓΡΑΦΟ" IdentifierGroup = MyDocument(basestack, rest$, Lang) Exit Function Case "STRING", "ΓΡΑΜΜΑ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbString) Exit Function Case "VARIANT", "ΑΤΥΠΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbVariant) Exit Function Case "INTEGER", "ΑΚΕΡΑΙΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbInteger) Exit Function Case "LONG", "ΜΑΚΡΥΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbLong) Exit Function Case "DOUBLE", "ΔΙΠΛΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbDouble) Exit Function Case "SINGLE", "ΑΠΛΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbSingle) Exit Function Case "BOOLEAN", "ΛΟΓΙΚΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbBoolean) Exit Function Case "DECIMAL", "ΑΡΙΘΜΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbDecimal) Exit Function Case "BIGINTEGER", "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbObject, , New BigInteger) Exit Function Case "CURRENCY", "ΛΟΓΙΣΤΙΚΟΣ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbCurrency) Exit Function Case "BYTE", "ΨΗΦΙΟ" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbByte) Exit Function Case "ΗΜΕΡΟΜΗΝΙΑ", "DATE" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, vbDate) Exit Function Case "ΜΙΓΑΔΙΚΟΣ", "COMPLEX" IdentifierGroup = MyAnyType(basestack, rest$, Lang, alocal, 200) Exit Function Case "ΑΠΑΡΙΘΜΗΣΗ", "ΑΠΑΡ", "ENUMERATION", "ENUM" IdentifierGroup = ProcEnum(basestack, rest$, LenB(here$) = 0, alocal) Exit Function Case "ΔΙΕΠΑΦΗ", "INTERFACE" IdentifierGroup = ProcInter(basestack, rest$, Lang, LenB(here$) = 0, alocal) Exit Function Exit Function End Select End Function Function Identifier(basestack As basetask, what$, rest$, Optional nocom As Boolean = False, Optional Lang As Long = 1, Optional originalwhat$) As Boolean Dim x1 As Long, y1 As Long, it As Long, ohere$, s$, par As Boolean, p As Variant If what$ = vbNullString Then ' DROP @ BY DEFAULT Identifier = IsLabelNoUcase(basestack, rest$, originalwhat$) If Not Identifier Then Exit Function what$ = myUcase(originalwhat$) Lang = codeW(what$) Else Identifier = True x1 = Len(rest$) If Left$(what$, 1) <> "@" Then If nocom Then GoTo JUMPHEREFORMODULESFAST Else what$ = Mid$(what$, 2) End If End If Select Case what$ Case "&" Identifier = MyFunction(2, basestack, rest$, Lang) Exit Function Case "ΑΝΑΛΥΤΗΣ", "PROFILER" ' no Neo... Identifier = True If basestack.Prof Is Nothing Then If FastSymbol(rest$, "!") Then Set basestack.Prof = New clsProfiler basestack.Prof.MARKONE Else Prof.MARKONE End If Else FastSymbol rest$, "!" basestack.Prof.MARKONE End If Exit Function Case "READ", "ΔΙΑΒΑΣΕ" Identifier = MyRead(1, basestack, rest$, Lang) Exit Function Case "LINK", "ΕΝΩΣΕ" Identifier = MyLink(basestack, rest$, Lang) Exit Function Case "FUNCTION", "ΣΥΝΑΡΤΗΣΗ" Identifier = MyFunction(0, basestack, rest$, Lang) Exit Function Case "MODULE", "ΤΜΗΜΑ" Identifier = MyModule(basestack, rest$, Lang) Exit Function Case "SUPERCLASS", "ΥΠΕΡΚΛΑΣΗ" Identifier = ProcClass(basestack, rest$, Lang, True) Exit Function Case "EVENT", "ΓΕΓΟΝΟΣ" Identifier = myEvent(basestack, rest$, Lang) Exit Function Case "GROUP", "ΟΜΑΔΑ" Identifier = ProcGroup(0, basestack, rest$, Lang) Exit Function Case "CLASS", "ΚΛΑΣΗ" Identifier = ProcClass(basestack, rest$, Lang, False) Exit Function Case "DIM", "ΠΙΝΑΚΑΣ", "ΠΙΝΑΚΕΣ" Identifier = MyDim(basestack, rest$, Lang) Exit Function Case "ΚΑΤΑΣΤΑΣΗ", "INVENTORY" Identifier = ProcInventory(basestack, rest$, Lang) Exit Function Case "ΔΙΑΡΘΡΩΣΗ", "BUFFER" Identifier = ProcBuffer(basestack, rest$, Lang) Exit Function Case "WAIT", "ΑΝΑΜΟΝΗ" '' copy to NeoWait Identifier = MyDelay(basestack, rest$) Exit Function Case "REPORT", "ΑΝΑΦΟΡΑ" Identifier = MyReport(basestack, rest$, Lang) Exit Function Case "LET", "ΣΤΗ", "ΣΤΗΝ", "ΣΤΟ" 'ok Identifier = MyLet(basestack, rest$, Lang) Exit Function Case "COMMIT", "ΑΝΕΘΕΣΕ" Identifier = MyRead(3, basestack, rest$, Lang) Exit Function Case "ICON", "ΕΙΚΟΝΙΔΙΟ" Identifier = MyIcon(basestack, rest$) Exit Function Case "TITLE", "ΤΙΤΛΟΣ" Identifier = ProcTitle(basestack, rest$, Lang) Exit Function Case "ESCAPE", "ΔΙΑΦΥΓΗ" Identifier = MyEscape(rest$, Lang) Case "HIDE", "ΣΒΗΣΕ" newHide basestack Exit Function Case "SHOW", "ΑΝΑΨΕ" newshow basestack, rest$ Exit Function Case "WRITE", "ΓΡΑΨΕ" Identifier = MyWrite(basestack, rest$, Lang) Exit Function Case "TEXT", "ΚΕΙΜΕΝΟ", "HTML" 'ok Identifier = ProcText(basestack, what$ = "HTML", rest$) Exit Function Case "STRUCTURE", "ΔΟΜΗ" ' ok Identifier = myStructure(basestack, rest$, Lang) Exit Function Case "ΒΑΣΗ", "BASE" 'ok ' ΝΕΑ ΒΑΣΗ Identifier = NewBase(basestack, rest$, Lang) Exit Function Case "ΑΡΧΕΙΟ", "TABLE" 'ok Identifier = NewTable(basestack, rest$, Lang) ' ΝΕΟΣ ΠΙΝΑΚΑΣ ΣΤΗΝ ΒΑΣΗ Exit Function Case "ΕΚΤΕΛΕΣΗ", "EXECUTE" 'ok If IsLabelSymbolNew(rest$, "ΚΩΔΙΚΑ", "CODE", Lang) Then Identifier = ExecCode(basestack, rest$) Else CommExecAndTimeOut basestack, rest$ Identifier = True End If ' ΝΕΑ ΛΙΣΤΑ Case "ΧΡΩΜΑΤΙΣΕ", "PSET" Identifier = MyPset(basestack, rest$) Case "ΑΝΑΚΤΗΣΗ", "RETRIEVE" 'ok getrow basestack, rest$, , , Lang Exit Function Case "ΑΝΑΖΗΤΗΣΗ", "SEARCH" 'ok getrow basestack, rest$, , "", Lang Exit Function Case "ΠΡΟΣΘΗΚΗ", "APPEND" 'ok ' ΒΑΣΗ,ΠΙΝΑΚΑΣ,ΣΤΟΙΧΕΙΑ par = Appfields(basestack, rest$) Exit Function Case "ΑΦΑΙΡΕΣΗ", "DELETE" 'ok ' ΒΑΣΗ, ΠΙΝΑΚΑΣ,ΠΟΙΟ , ΤΙ par = DELfields(basestack, rest$) Exit Function Case "ΤΑΞΗ", "ORDER" 'ok Identifier = MyOrder(basestack, rest$, Lang) Exit Function Case "ΕΠΙΣΤΡΟΦΗ", "RETURN" ' no need here ' ΒΑΣΗ,"SELECT ΠΙΝΑΚΑΣ",ΣΤΟΙΧΕΙΑ If IsStrExp(basestack, rest$, s$) Then append_table basestack, s$, rest$, True, Lang End If Exit Function Case "ΣΥΜΠΙΕΣΗ", "COMPRESS" 'ok BaseCompact basestack, rest$ Exit Function Case "LAYER", "ΕΠΙΠΕΔΟ" ' ok Identifier = ProcLayer(basestack, rest$) Exit Function Case "PRINTER", "ΕΚΤΥΠΩΤΗΣ" ' ok Identifier = ProcPrinter(basestack, rest$) Exit Function Case "MOTION", "ΚΙΝΗΣΗ" Identifier = ProcMotion(basestack, rest$, Lang) Exit Function Case "ASSERT", "ΑΞΙΩΣΗ" ProcAssert basestack, rest$ Exit Function Case "PAGE", "ΣΕΛΙΔΑ" 'ok ProcPage basestack, rest$, Lang Exit Function Case "PRINTING", "ΕΚΤΥΠΩΣΗ" Identifier = ProcPrinting(basestack, rest$, Lang) Exit Function Case "FORMLABEL", "ΕΤΙΚΕΤΑ.ΦΟΡΜΑΣ" Identifier = ProcLabel(basestack, rest$) Exit Function Case "LEGEND", "ΕΠΙΓΡΑΦΗ" ' NEW JUSTIFY...1 RIGHT,2 CENTER ,3 LEFT Identifier = ProcLegend(basestack, rest$) Exit Function Case "MEDIA", "MOVIE", "ΤΑΙΝΙΑ", "MUSIC", "ΜΟΥΣΙΚΗ" ' μόνο ένα και μπορεί να περιμένει ή να το διώξει για άλλο Identifier = ProcMedia(basestack, rest$, Lang) Exit Function Case "PUT", "ΔΩΣΕ" Identifier = MyPut(basestack, rest$) Exit Function Case "ΦΟΡΜΑ", "FORM" Kform = True Identifier = MakeForm(basestack, rest$) Exit Function Case "SUBDIR", "ΥΠΟΚΑΤΑΛΟΓΟΣ" Identifier = ProcSubDir(basestack, rest$, Lang) Exit Function Case "DIR", "ΚΑΤΑΛΟΓΟΣ" Identifier = ProcDir(basestack, rest$, Lang) Exit Function Case "START", "ΑΡΧΗ" Identifier = newStart(basestack, rest$, Lang) Exit Function Case "REMOVE", "ΔΙΑΓΡΑΦΗ" Identifier = ProcRemove(basestack, rest$, Lang) Exit Function Case "DEF", "ΚΑΝΕ" Identifier = ProcDef(basestack, rest$, Lang) Exit Function Case "LOAD", "ΦΟΡΤΩΣΕ" ' Identifier = ProcLoad(basestack, rest$, Lang) Exit Function Case "SAVE", "ΣΩΣΕ" Identifier = ProcSave(basestack, rest$, Lang) Exit Function Case "OVERWRITE", "ΚΑΤΑΧΩΡΗΣΗ" Identifier = RepPara(basestack, rest$) Exit Function Case "INSERT", "ΠΑΡΕΜΒΟΛΗ" Identifier = IdPara(basestack, rest$, Lang) Exit Function Case "DOCUMENT", "ΕΓΓΡΑΦΟ" Identifier = MyDocument(basestack, rest$, Lang) Exit Function Case "STOCK", "ΣΤΟΚ" Identifier = StockValues(basestack, rest$, Lang) Exit Function Case "REFER", "ΑΠΕΔΩΣΕ" Identifier = MyRead8(2, basestack, rest$, Lang) Exit Function Case "DOUBLE" Dim k As Long k = MyTrimL(rest$): If k > 1 Then rest$ = Mid$(rest$, k) If CheckFreeExecute(rest$) Then SetDouble basestack.Owner Identifier = True Else Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbDouble, True) End If Case "ΔΙΠΛΑ" SetDouble basestack.Owner Case "ΔΙΠΛΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbDouble, True) Exit Function Case "INTEGER", "ΑΚΕΡΑΙΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbInteger, True) Exit Function Case "LONG", "ΜΑΚΡΥΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbLong, True) Exit Function Case "SINGLE", "ΑΠΛΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbSingle, True) Exit Function Case "BOOLEAN", "ΛΟΓΙΚΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbBoolean, True) Exit Function Case "DECIMAL", "ΑΡΙΘΜΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbDecimal, True) Exit Function Case "BIGINTEGER", "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbObject, True, New BigInteger) Exit Function Case "CURRENCY", "ΛΟΓΙΣΤΙΚΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbCurrency, True) Exit Function Case "STRING", "ΓΡΑΜΜΑ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbString, True) Exit Function Case "BYTE", "ΨΗΦΙΟ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbByte, True) Exit Function Case "DATE", "ΗΜΕΡΟΜΗΝΙΑ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbDate, True) Exit Function Case "COMPLEX", "ΜΙΓΑΔΙΚΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, 200, True) Exit Function Case "VARIANT", "ΑΤΥΠΟΣ" Identifier = MyAnyType(basestack, rest$, Lang, Len(here$) > 0, vbVariant, True) Exit Function Case "NORMAL", "ΚΑΝΟΝΙΚΑ" SetNormal basestack.Owner Exit Function Case "ERROR", "ΛΑΘΟΣ" Identifier = MyError(basestack, rest$, Lang) Exit Function Case "SET", "ΘΕΣΕ" it = 1 aheadstatusANY rest$, it s$ = Left$(rest$, it - 1) If interpret(basestack, s$) Then rest$ = Mid$(rest$, it) Else rest$ = s$ + Mid$(rest$, it) End If Exit Function Case "NEW", "ΝΕΟ" Identifier = MyNew(basestack, rest$, Lang) Exit Function Case "EDIT", "ΣΥΓΓΡΑΦΗ", "Σ" Identifier = ProcEdit(basestack, rest$, Lang) Exit Function Case "SCAN", "ΣΑΡΩΣΕ" Identifier = MyScan(basestack, rest$) Exit Function Case "ΠΕΝΑ", "PEN" Identifier = ProcPen(basestack, rest$) Exit Function Case "ΟΘΟΝΗ", "CLS" Identifier = ProcCls(basestack, rest$) Exit Function Case "HEX", "ΔΕΚΑΕΞ" Identifier = RevisionPrint(basestack, rest$, 1, Lang) Exit Function Case "PRINT", "ΤΥΠΩΣΕ", "?" Identifier = RevisionPrint(basestack, rest$, 0, Lang) Exit Function Case "BACK", "BACKGROUND", "ΠΕΡΙΘΩΡΙΟ" ProcBackGround basestack, rest$, Lang, Identifier Exit Function Case "PUSH", "ΒΑΛΕ" par = MyPush(basestack, rest$) Exit Function Case "ΣΕΙΡΑ", "DATA" par = MyData(basestack, rest$) Exit Function Case "SWAP", "ΑΛΛΑΞΕ" Identifier = MySwap(basestack, rest$, Lang) Exit Function Case "CLOSE", "ΚΛΕΙΣΕ" Identifier = MyClose(basestack, rest$, Lang) Exit Function Case "SEEK", "ΜΕΤΑΘΕΣΗ" Identifier = MySeek(basestack, rest$) Exit Function Case "APPEND.DOC", "ΠΡΟΣΘΕΣΕ.ΕΓΓΡΑΦΟ" Identifier = ProcSaveDoc(1, basestack, rest$) Exit Function Case "SAVE.DOC", "ΣΩΣΕ.ΕΓΓΡΑΦΟ" Identifier = ProcSaveDoc(0, basestack, rest$) Exit Function Case "MERGE.DOC", "ΣΥΓΧΩΝΕΥΣΕ.ΕΓΓΡΑΦΟ" Identifier = ProcLoadDoc(1, basestack, rest$) Exit Function Case "LOAD.DOC", "ΦΟΡΤΩΣΕ.ΕΓΓΡΑΦΟ" Identifier = ProcLoadDoc(0, basestack, rest$) Exit Function Case "FIND", "ΕΥΡΕΣΗ" Identifier = ProcFind(basestack, rest$) Exit Function Case "WORDS", "ΛΕΞΕΙΣ" Identifier = ProcWords(basestack, rest$) Exit Function Case "SORT", "ΤΑΞΙΝΟΜΗΣΗ" Identifier = ProcSort(basestack, rest$, Lang) Exit Function Case "OVER", "ΠΑΝΩ" 'ΑΝΤΙΓΡΑΦΕΙ ΤΗΝ ΚΟΡΥΦΗ Identifier = ProcOver(basestack, rest$) Exit Function Case "SHIFTBACK", "ΦΕΡΕΠΙΣΩ" 'ΜΕΤΑΚΙΝΕΙ ΑΠΟ ΤΗΝ ΚΟΡΥΦΗ Identifier = ProcShiftBack(basestack, rest$) Exit Function Case "SHIFT", "ΦΕΡΕ" 'ΜΕΤΑΚΙΝΕΙ ΣΤΗΝ ΚΟΡΥΦΗ Identifier = ProcShift(basestack, rest$) Exit Function Case "DROP", "ΠΕΤΑ" Identifier = ProcDrop(basestack, rest$, Lang) Exit Function Case "SCREEN.PIXELS", "ΑΝΑΛΥΣΗ.ΟΘΟΝΗΣ" Identifier = ProcScreenRes(basestack, rest$) Exit Function Case "SOUNDREC", "ΗΧΟΓΡΑΦΗΣΗ" Identifier = ProcSoundRec(basestack, rest$, Lang) Exit Function Case "KEYBOARD", "ΠΛΗΚΤΡΟΛΟΓΙΟ" Identifier = ProcKeyboard(basestack, rest$, Lang) Exit Function Case "JOYPAD", "ΛΑΒΗ" Identifier = ProcJoypad(basestack, rest$) Exit Function Case "PIPE", "ΑΥΛΟΣ" Identifier = ProcPipe(basestack, rest$) Exit Function Case "GET", "ΠΑΡΕ" Identifier = ProcGet(basestack, rest$) Exit Function Case "ΝΗΜΑ", "THREAD" Identifier = MyThread(basestack, rest$, Lang) Exit Function Case "HOLD", "ΚΡΑΤΗΣΕ" Identifier = ProcHold(basestack) Exit Function Case "RELEASE", "ΑΦΗΣΕ" Identifier = ProcRelease(basestack) Exit Function Case "USE", "ΧΡΗΣΗ" Identifier = ProcUSE(basestack, rest$, Lang) Exit Function Case "OPEN.FILE", "ΑΝΟΙΓΜΑ.ΑΡΧΕΙΟΥ" Identifier = ProcOpenFile(basestack, rest$, Lang) Exit Function Case "OPEN.IMAGE", "ΑΝΟΙΓΜΑ.ΕΙΚΟΝΑΣ" Identifier = ProcOpenImage(basestack, rest$, Lang) Exit Function Case "FLUSH", "ΑΔΕΙΑΣΕ" Identifier = ProcFlush(basestack, rest$, Lang) Exit Function Case "PROPERTIES", "ΙΔΙΟΤΗΤΕΣ" ''for printer Identifier = ProcPropeties(basestack, rest$) Exit Function Case "SPEECH", "ΛΟΓΟΣ" Identifier = ProcSpeech(basestack, rest$) Exit Function Case "DOS", "ΚΟΝΣΟΛΑ" Identifier = ProcDos(basestack, rest$) Exit Function Case "WIN", "ΣΥΣ", "ΣΥΣΤΗΜΑ" Identifier = ProcWin(basestack, rest$) Exit Function Case "WINDOW", "ΠΑΡΑΘΥΡΟ" Kform = True ProcWindow basestack, rest$, basestack.Owner, Identifier Exit Function Case "FIELD", "ΠΕΔΙΟ" Identifier = ProcField(basestack, rest$, Lang) Exit Function Case "TEST", "ΔΟΚΙΜΗ" Identifier = procTestMe(basestack, rest$, what$) Exit Function Case "MOUSE.ICON", "ΔΕΙΚΤΗ.ΜΟΡΦΗ" i3MouseIcon basestack, rest$, Lang Exit Function Case "MOTION.W", "ΚΙΝΗΣΗ.Π" Identifier = procMotionW(basestack, rest$) Exit Function Case "CLIPBOARD", "ΠΡΟΧΕΙΡΟ" Identifier = MyClipboard(basestack, rest$, Lang) Exit Function Case "ΒΟΗΘΕΙΑ", "HELP" Identifier = MyHelp(basestack, rest$, Lang) Exit Function Case "CLEAR", "ΚΑΘΑΡΟ" Identifier = MyClear(basestack, rest$) Exit Function Case "DECLARE", "ΟΡΙΣΕ" 'OBJECT Identifier = MyDeclare(basestack, rest$, Lang) Exit Function Case "REM", "ΣΗΜ" NeoRem 0, rest$, 0, Identifier Exit Function Case "VOLUME", "ΕΝΤΑΣΗ" Identifier = MyVol(basestack, rest$) Exit Function Case "ABOUT", "ΠΕΡΙ" ProcAbout basestack, rest$, Lang Exit Function Case "SMOOTH", "ΟΜΑΛΑ" If IsLabelSymbolNew(rest$, "ΟΧΙ", "OFF", Lang) Then GDILines = False ElseIf IsLabelSymbolNew(rest$, "ΝΑΙ", "ON", Lang) Then GDILines = True End If Exit Function Case "OPTIMIZATION", "ΒΕΛΤΙΣΤΟΠΟΙΗΣΗ" '' not a If IsLabelSymbolNew(rest$, "ΟΧΙ", "OFF", Lang) Then NoOptimum = True ElseIf IsLabelSymbolNew(rest$, "ΝΑΙ", "ON", Lang) Then NoOptimum = False End If Exit Function Case "LINESPACE", "ΔΙΑΣΤΙΧΟ" 'ok Identifier = procLineSpace(basestack, rest$) Exit Function Case "BOLD", "ΦΑΡΔΙΑ" 'ok ProcBold basestack, rest$ Exit Function Case "MODE", "ΤΥΠΟΣ" Identifier = ProcMode(basestack, rest$) Exit Function Case "GRADIENT", "ΦΟΝΤΟ" Identifier = ProcGradient(basestack, rest$) Exit Function Case "CHOOSE.OBJECT", "ΕΠΕΛΕΞΕ.ΑΝΤΙΚΕΙΜΕΝΟ", "ΕΠΙΛΕΞΕ.ΑΝΤΙΚΕΙΜΕΝΟ" ProcChooseObj basestack, rest$, Lang Exit Function Case "CHOOSE.FONT", "ΕΠΕΛΕΞΕ.ΓΡΑΜΜΑΤΟΣΕΙΡΑ", "ΕΠΙΛΕΞΕ.ΓΡΑΜΜΑΤΟΣΕΙΡΑ" ProcChooseFont basestack, Lang Exit Function Case "INPUT", "ΕΙΣΑΓΩΓΗ" ' ok Identifier = MyInput(basestack, rest$, Lang) Exit Function Case "ΝΗΜΑΤΑ", "THREADS" procthreads basestack.Owner, basestack, rest$, Lang Exit Function Case "ΟΡΙΟ.ΑΝΑΔΡΟΜΗΣ", "RECURSION.LIMIT" Identifier = ProcRecursionLimit(basestack, rest$, Lang) Exit Function Case "LOCALE", "ΤΟΠΙΚΟ" Identifier = ProcSalata(3, basestack, rest$) Exit Function Case "CODEPAGE", "ΚΩΔΙΚΟΣΕΛΙΔΑ" Identifier = ProcSalata(2, basestack, rest$) Exit Function Case "CHARSET", "ΧΑΡΑΚΤΗΡΕΣ" Identifier = ProcSalata(1, basestack, rest$) Exit Function Case "STEP", "ΒΗΜΑ" Identifier = ProcStep(basestack, rest$, Lang) Exit Function Case "MOVE", "ΘΕΣΗ" Identifier = ProcMove(basestack, rest$) Exit Function Case "ΠΟΛΥΓΩΝΟ", "POLYGON" Identifier = ProcPoly(basestack, rest$, Lang) Exit Function Case "CIRCLE", "ΚΥΚΛΟΣ" Identifier = ProcCircle(basestack, rest$, Lang) Exit Function Case "PLAYER", "ΠΑΙΚΤΗΣ" Identifier = ProcPlayer(basestack, rest$, Lang) Exit Function Case "IMAGE", "ΕΙΚΟΝΑ" Identifier = ProcImage(basestack, rest$, Lang) Exit Function Case "SPRITE", "ΔΙΑΦΑΝΟ", "ΔΙΑΦΑΝΕΙΑ" ' ok NeoSprite exist If IsStrExp(basestack, rest$, s$) Then sprite basestack, s$, rest$ ElseIf IsExp(basestack, rest$, p) Then spriteGDI basestack, rest$ End If If LastErNum1 <> 0 Then Identifier = False Exit Function Case "COPY", "ΑΝΤΕΓΡΑΨΕ", "ΑΝΤΙΓΡΑΨΕ" Identifier = MyCopy(basestack, rest$, Lang) Exit Function Case "ΠΑΙΞΕ", "PLAY" Identifier = MyPlayScore(basestack, rest$) Exit Function Case "SCORE", "ΦΩΝΗ" Identifier = MyScore(basestack, rest$) Exit Function Case "TARGETS", "ΣΤΟΧΟΙ" Identifier = ProcTargets(basestack, rest$, Lang) Exit Function Case "CASE" 'If HaveMarkSelEn(basestack) Then Identifier = False 'End If Exit Function Case "WITH", "ΜΕ", "ΜΕ.ΑΝΤΙΚΕΙΜΕΝΟ" If HaveMarkSelGr(basestack) Then Identifier = False Else Identifier = MyWith(basestack, rest$, Lang) End If Exit Function Case "METHOD", "ΜΕΘΟΔΟΣ" Identifier = MyMethod(basestack, rest$, Lang, False, False) Exit Function Case "LATIN", "ΛΑΤΙΝΙΚΑ", "ENGLISH", "ΑΓΓΛΙΚΑ" LATIN basestack '**************************************************************** Exit Function Case "GREEK", "ΕΛΛΗΝΙΚΑ" GREEK basestack Exit Function Case "MODULES", "ΤΜΗΜΑΤΑ" Identifier = MyModules(basestack, rest$, Lang) Exit Function Case "FILES", "ΑΡΧΕΙΑ" Identifier = ProcFiles(basestack, rest$, Lang) Exit Function Case "CAT", "ΚΑΤΑΛΟΓΟΙ", "ΚΑΤ" Identifier = ProcCat(basestack, rest$, Lang) Exit Function Case "DRAWINGS", "ΣΧΕΔΙΑ" Identifier = MyDrawings(basestack, rest$, Lang) Exit Function Case "BITMAPS", "ΕΙΚΟΝΕΣ" Identifier = MyBitmaps(basestack, rest$, Lang) Exit Function Case "MOVIES", "ΤΑΙΝΙΕΣ" Identifier = MyMovies(basestack, rest$, Lang) Exit Function Case "SOUNDS", "ΗΧΟΙ" Identifier = MySounds(basestack, rest$, Lang) Exit Function Case "WRITER", "ΣΥΓΓΡΑΦΕΑΣ" Identifier = ProcWriter(basestack, rest$, Lang) Exit Function Case "LIST", "ΛΙΣΤΑ" Identifier = ProcList(basestack, rest$, Lang) Exit Function Case "FRAME", "ΠΛΑΙΣΙΟ" ' BOX X1,Y1,COL,BOX Identifier = MyFrame(basestack, rest$) Exit Function Case "MARK", "ΣΗΜΑΔΙ" Identifier = MyMark(basestack, rest$) Exit Function Case "LINE", "ΓΡΑΜΜΗ" Identifier = MyLineInput(basestack, rest$, Lang) Exit Function Case "CURSOR", "ΔΡΟΜΕΑΣ" ' CURSOR X,Y Identifier = MyCursor(basestack, rest$) Exit Function Case "FILL", "ΒΑΨΕ" Identifier = ProcFill(basestack, rest$) Exit Function Case "FLOODFILL", "ΓΕΜΙΣΕ" Identifier = ProcFLOODFILL(basestack, rest$, Lang) Exit Function Case "ΧΑΡΑΞΕ", "DRAW" ' LINE X1,Y1,COL Identifier = ProcDraw(basestack, rest$, Lang) Exit Function Case "WIDTH", "ΠΑΧΟΣ" Identifier = ProcDrawWidth(basestack, rest$) Exit Function Case "ΚΑΜΠΥΛΗ", "CURVE" Identifier = ProcCurve(basestack, rest$, Lang) Exit Function Case "PATH", "COLOR", "ΧΡΩΜΑ", "ΙΧΝΟΣ" Identifier = ProcPath(basestack, rest$, Lang) Exit Function Case "DESKTOP", "ΕΠΙΦΑΝΕΙΑ" Identifier = ProcDesktop(basestack, rest$, Lang) Exit Function Case "CHOOSE.COLOR", "ΕΠΕΛΕΞΕ.ΧΡΩΜΑ", "ΕΠΙΛΕΞΕ.ΧΡΩΜΑ" Identifier = ProcChooseColor(basestack, rest$, Lang) Exit Function Case "SAVE.AS", "ΑΠΟΘΗΚΕΥΣΗ.ΩΣ" Identifier = ProcSaveAs(basestack, rest$, Lang) Exit Function Case "ΑΛΛΑΓΗ", "CHANGE" Identifier = ProcCHANGE(basestack, rest$, Lang) Exit Function Case "STACK", "ΣΩΡΟΣ" Identifier = ProcStack(basestack, rest$, Lang) Exit Function Case "ΕΚΔΟΣΗ", "VERSION" Identifier = ProcVersion(basestack) Exit Function Case "ΓΡΑΜΜΑΤΟΣΕΙΡΑ" Identifier = ProcFont(basestack, rest$, 0&) Exit Function Case "FONT" Identifier = ProcFont(basestack, rest$, 1&) Exit Function Case "SCROLL", "ΚΥΛΙΣΗ" Identifier = ProcSrcoll(basestack, rest$, Lang) Exit Function Case "EDIT.DOC", "ΔΙΟΡΘΩΣΕ" Identifier = ProcEditDoc(basestack, rest$, Lang) Exit Function Case "ITALIC", "ITALICS", "ΠΛΑΓΙΑ" '....................... Identifier = ProcItalic(basestack, rest$) Exit Function Case "ΚΛΕΙΔΙ", "FKEY" Identifier = ProcFKey(basestack, rest$, Lang) Exit Function Case "OPEN", "ΑΝΟΙΞΕ" Identifier = ProcOpen(basestack, rest$, Lang) Exit Function Case "NAME", "ΟΝΟΜΑ" Identifier = ProcName(basestack, rest$, Lang) Exit Function Case "TUNE", "ΜΕΛΩΔΙΑ" Identifier = ProcTune(basestack, rest$) Exit Function Case "ΗΧΟΣ", "SOUND" Identifier = ProcSound(basestack, rest$) Exit Function Case "DB.USER", "ΒΑΣΗ.ΧΡΗΣΤΗΣ" Identifier = ProcDBUSER(basestack, rest$, Lang) Exit Function Case "DB.PROVIDER", "ΒΑΣΗ.ΠΑΡΟΧΟΣ" Identifier = ProcDBprovider(basestack, rest$, Lang) Exit Function Case "TONE", "ΤΟΝΟΣ" Identifier = ProcTone(basestack, rest$) Exit Function Case "VIEW", "ΔΕΙΞΕ" Identifier = ProcView(basestack, rest$, Lang) Exit Function Case "CHOOSE.ORGAN", "ΕΠΕΛΕΞΕ.ΟΡΓΑΝΟ", "ΕΠΙΛΕΞΕ.ΟΡΓΑΝΟ" Identifier = ProcChooseOrgan(basestack, rest$, Lang) Exit Function Case "BROWSER", "ΑΝΑΛΟΓΙΟ" Identifier = ProcBrowser(basestack, rest$, Lang) Exit Function Case "ΜΠΙΠ", "BEEP" Identifier = ProcBeep(basestack, rest$) Exit Function Case "MENU", "ΕΠΙΛΟΓΗ" Identifier = MyMenu(0, basestack, rest$, Lang) Exit Function Case "THREAD.PLAN", "ΣΧΕΔΙΟ.ΝΗΜΑΤΩΝ" Identifier = ProcThreadPlan(basestack, rest$, Lang) Exit Function Case "ΡΥΘΜΙΣΕΙΣ", "SETTINGS" Identifier = ProcSettings(basestack, rest$, Lang) Exit Function Case "PROTOTYPE", "ΠΡΩΤΟΤΥΠΟ" Identifier = ProcProto(basestack, rest$, Lang) Exit Function Case "ΑΠΑΡΙΘΜΗΣΗ", "ΑΠΑΡ", "ENUMERATION", "ENUM" Identifier = ProcEnum(basestack, rest$, LenB(here$) = 0) Exit Function Case "ΔΙΕΠΑΦΗ", "INTERFACE" Identifier = ProcInter(basestack, rest$, Lang, LenB(here$) = 0) Exit Function Case "ΟΡΙΑ.ΕΚΤΥΠΩΤΗ", "ΟΡΙΑ.ΕΚΤΥΠΩΣΗΣ", "PRINTER.MARGINS" Identifier = ProcMargins(basestack, rest$) Exit Function Case "ΠΟΙΟΤΗΤΑ.ΕΚΤΥΠΩΣΗΣ", "PRINTER.QUALITY" Identifier = 0 Exit Function Case Else x1 = Len(rest$) Identifier = True JUMPHEREFORMODULESFAST: MakeThisSub basestack, what$ If GetSub(what$, y1) Then it = 0 ElseIf GetSub(here$ + "." + what$, y1) Then it = 1 ElseIf Len(basestack.UseGroupname) > 0 Then If InStr(what$, basestack.UseGroupname) = 1 Then s$ = basestack.UseGroupname + ChrW(&HFFBF) + Mid$(what$, Len(basestack.UseGroupname) + 1) If GetSub(s$, y1) Then it = 0 ElseIf GetSub(here$ + "." + s$, y1) Then it = 1 Else If GetSub(what$ + "()", y1) Then GoTo jump123class ElseIf GetSub(what$ + "$()", y1) Then GoTo jump123class ElseIf GetSub(s$ + "()", y1) Then GoTo jump123class ElseIf GetSub(s$ + "$()", y1) Then GoTo jump123class End If GoTo conthereplease End If Else GoTo conthereplease End If Else If GetSub(what$ + "()", y1) Then jump123class: If sbf(y1).IamAClass Then jumpclassfinal: If AddGroupFromClass(basestack, rest$, what$, here$ = "", False, "") Then Identifier = True Exit Function End If End If If GetSub(what$ + "$()", y1) Then If sbf(y1).IamAClass Then GoTo jumpclassfinal End If End If conthereplease: x1 = 0 GoTo checksub End If If NORUN1 Then rest$ = vbNullString: Exit Function x1 = y1 If Len(what$) = 0 Then Identifier = False: Exit Function what$ = myUcase(what$): MakeThisSub basestack, what$ ohere$ = here$ If it = 0 Then If SecureNames Then If here$ = vbNullString Then If Len(what$) > 3 Then s$ = "‹" & x1 & "›" 'Left$(what$, 1) & x1 Else s$ = what$ End If Else s$ = RVAL33(here$, x1) End If Else s$ = what$ End If Else s$ = ohere$ + "." + what$ End If If basestack.OriginalCode <> x1 And x1 > 0 Then y1 = var2used par = PushParamGeneral(basestack, rest$, s$) y1 = y1 - var2used Else checksub: If Len(here$) = 0 Then GoTo nomodule With basestack If y1 = -1 Then .callx1 = -1 If Len(originalwhat$) > 0 Then .tmpstr = originalwhat$ Identifier = True ' Exit Function Else .callx1 = -2 End If End With rest$ = LTrim(rest$) If Len(rest$) > 0 Then If Len(originalwhat$) = 0 Then If x1 <> 0 Then MyErMacro rest$, "Use Call command to call recuirsive in module", "Χρησιμοποίησε την Κάλεσε για αναδρομική κλήση τμήματος" If here$ <> ohere$ Then here$ = ohere$ Identifier = True Else nomodule: If Len(originalwhat$) > 0 Then what$ = originalwhat$ rest$ = what$ + rest$ MyEr "unknown module " + what$, "Άγνωστο τμήμα " + what$ Identifier = False End If Exit Function prob1: basestack.callx1 = 0 basestack.tmpstr = what$ + Left$(rest$, 1) GoTo a994995 Exit Function Else it = 1 aheadstatusSkipParam rest$, it y1 = it If MaybeIsSymbol3lot(rest$, b12345, y1) Or y1 > Len(rest$) Then If basestack.callx1 = 0 Then If Mid$(rest$, y1, 2) = ":=" Then GoTo prob1 If Mid$(rest$, y1, 2) = "/=" Then GoTo prob1 End If basestack.tmpstr = originalwhat$ + "(" + Left$(rest$, 1) GoTo a994995 End If End If basestack.tmpstr = originalwhat$ + "()" + Left$(rest$, 1) a994995: If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) Identifier = True Exit Function End If If LastErNum = -2 Then If Left$(rest$, 12) <> " : ERROR -2" Then rest$ = vbNullString Identifier = True Exit Function Else If Not par Then Identifier = False: Exit Function End If here$ = s$ With basestack .callohere = ohere$ .callx1 = x1 .ByName = y1 Identifier = True End With Exit Function NERR: If MOUT And rest$ = vbNullString Then Else MyErMacro rest$, "unknown identifier " + what$, "Άγνωστο αναγνωριστικό " + what$ End If Identifier = True End Select End Function Function ReboundArr(bstack As basetask, Name$, arrcode As Long) As Boolean On Error GoTo 0 Dim ss$ Name$ = myUcase(Name$) If Left$(Name$, 5) = "ΑΥΤΟ." Or Left$(Name$, 5) = "THIS." Then ss$ = bstack.UseGroupname + Mid$(Name$, 6) Else If here$ = vbNullString Then ss$ = Name$ Else ss$ = here$ + "." + Name$ End If End If ReboundArr = varhash.findRebound(ss$, arrcode, var()) End Function Function ReboundVar(bstack As basetask, Name$, q As Long) As Boolean On Error GoTo 0 Dim ss$ Name$ = myUcase(Name$) If Left$(Name$, 5) = "ΑΥΤΟ." Or Left$(Name$, 5) = "THIS." Then ss$ = bstack.UseGroupname + Mid$(Name$, 6) Else If here$ = vbNullString Then ss$ = Name$ Else ss$ = here$ + "." + Name$ End If End If ReboundVar = varhash.findRebound(ss$, q, var()) End Function Function globalvarex(Name$, q As Variant) As Long Dim makeitglobal As Boolean, ohere$ On Error GoTo 0 Dim j As Long j = AllocVar() If MyIsObject(q) Then Set var(j) = q Else If Right$(Name$, 1) = "%" Then On Error Resume Next q = MyRound(q) If Err.Number = 6 Then q = 0 On Error GoTo 0 End If var(j) = q End If varhash.ItemCreator myUcase(Name$), j, , , True globalvarex = j End Function Function globalvarEmpty(Name$) As Long globalvarEmpty = AllocVar() varhash.ItemCreator (Name$), globalvarEmpty, , , True End Function Function globalvar(Name$, q As Variant, Optional link As Boolean = False, Optional makeitglobal As Boolean = False, Optional ohere$ = vbNullString, Optional useType As Boolean = True) As Long On Error GoTo 0 Dim j As Long, M As Long If Not link Then If ohere$ <> vbNullString Then If varhash.Find2(ohere$ + "." + Name$, M, makeitglobal) And Not link Then If Not makeitglobal Then j = M Else j = AllocVar() varhash.ItemCreator ohere$ + "." + Name$, j, link, False, useType End If Else j = AllocVar() varhash.ItemCreator ohere$ + "." + Name$, j, link, False, False End If ohere$ = vbNullString If MyIsObject(q) Then Set var(j) = q Else If Right$(Name$, 1) = "%" Then On Error Resume Next q = MyRound(q) If Err.Number = 6 Then q = 0 On Error GoTo 0 End If var(j) = q End If globalvar = j Exit Function End If j = AllocVar() If MyIsObject(q) Then Set var(j) = q Else If Right$(Name$, 1) = "%" Then On Error Resume Next q = MyRound(q) If Err.Number = 6 Then q = 0 On Error GoTo 0 End If var(j) = q End If Else If CStr(q) = vbNullString Then j = 0 Else j = CLng(q) End If End If If Right$(Name$, 1) = "$" Then If strid.Find(Name$, M) Then If Len(here$) = 0 Or makeitglobal Then strid.ItemCreator2 Name$, -2 varhash.ItemCreator2 strid, Name$, j, link, makeitglobal, useType Else strid.ItemCreator2 Name$, -1 varhash.ItemCreator here$ + "." + Name$, j, link, , useType End If globalvar = j Exit Function End If If Len(here$) = 0 Or makeitglobal Then varhash.ItemCreator2 strid, Name$, j, link, makeitglobal, useType Else varhash.ItemCreator here$ + "." + Name$, j, link, , useType End If Else If numid.Find(Name$, M) Then If Len(here$) = 0 Or makeitglobal Then numid.ItemCreator2 Name$, -2 varhash.ItemCreator2 numid, Name$, j, link, makeitglobal, useType Else numid.ItemCreator Name$, -1 varhash.ItemCreator here$ + "." + Name$, j, link, , useType End If globalvar = j Exit Function End If If Len(here$) = 0 Or makeitglobal Then varhash.ItemCreator2 numid, Name$, j, link, makeitglobal, useType Else varhash.ItemCreator here$ + "." + Name$, j, link, , useType End If End If globalvar = j End Function Function globalvarGroup(Name$, q As Variant, Optional link As Boolean = False, Optional makeitglobal As Boolean = False, Optional ohere$ = vbNullString, Optional useType As Boolean = True) As Long On Error GoTo 0 Dim j As Long, M As Long If Not link Then If ohere$ <> vbNullString Then If varhash.Find2(ohere$ + "." + Name$, M, makeitglobal) And Not link Then If Not makeitglobal Then j = M Else j = AllocVar() varhash.ItemCreator ohere$ + "." + Name$, j, link, False, useType End If Else j = AllocVar() varhash.ItemCreator ohere$ + "." + Name$, j, link, False, False End If ohere$ = vbNullString If MyIsObject(q) Then Set var(j) = q Else If Right$(Name$, 1) = "%" Then On Error Resume Next q = MyRound(q) If Err.Number = 6 Then q = 0 On Error GoTo 0 End If var(j) = q End If globalvarGroup = j Exit Function End If j = AllocVar() If MyIsObject(q) Then Set var(j) = q Else If Right$(Name$, 1) = "%" Then On Error Resume Next q = MyRound(q) If Err.Number = 6 Then q = 0 On Error GoTo 0 End If var(j) = q End If Else If CStr(q) = vbNullString Then j = 0 Else j = CLng(q) End If End If If here$ = vbNullString Then varhash.ItemCreator (Name$), j, link, makeitglobal, useType ElseIf makeitglobal Then varhash.ItemCreator (Name$), j, link, False, useType Else varhash.ItemCreator here$ + "." + Name$, j, link, , useType End If globalvarGroup = j End Function Function globalvarStr(Name$, q$, Optional link As Boolean = False, Optional makeitglobal As Boolean = False, Optional ohere$ = vbNullString) As Long On Error GoTo 0 Dim j As Long, M As Long If Not link Then If ohere$ <> vbNullString Then If varhash.Find2(ohere$ + "." + Name$, M, makeitglobal) And Not link Then If Not makeitglobal Then j = M Else j = AllocVar() varhash.ItemCreator ohere$ + "." + Name$, j, link, False, True End If Else j = AllocVar() varhash.ItemCreator ohere$ + "." + Name$, j, link, False, False End If ohere$ = vbNullString MoveStringToVariant q$, var(j) globalvarStr = j Exit Function End If j = AllocVar() MoveStringToVariant q$, var(j) Else If Len(q$) = 0 Then j = 0 Else j = CLng(q) End If End If If strid.Find(Name$, M) Then If M > -1 Then strid.ItemCreator2 Name$, -1 End If If here$ = vbNullString Or makeitglobal Then varhash.ItemCreator2 strid, Name$, j, link, makeitglobal, True Else varhash.ItemCreator here$ + "." + Name$, j, link, , True End If globalvarStr = j End Function Function GlobalVarRefOnly(Name$, Optional gl As Boolean = False) As Long On Error GoTo 0 Dim j As Long j = AllocVar() ' var2used var(j) = 0& ' like an empty... Dim M As Long If here$ = vbNullString Or gl Then If Right$(Name$, 1) = "$" Then If strid.Find(Name$, M) Then strid.ItemCreator2 Name$, -2 Else If numid.Find(Name$, M) Then numid.ItemCreator2 Name$, -2 End If varhash.ItemCreator myUcase(Name$), j, , gl, True Else If Right$(Name$, 1) = "$" Then If strid.Find(Name$, M) Then strid.ItemCreator2 Name$, -1 Else If numid.Find(Name$, M) Then numid.ItemCreator Name$, -1 End If varhash.ItemCreator here$ + "." + myUcase(Name$), j, , gl, True End If GlobalVarRefOnly = j End Function Sub GlobalVarRefLink(Name$, j As Long, Optional gl As Boolean = False) On Error GoTo 0 If here$ = vbNullString Or gl Then varhash.ItemCreator myUcase(Name$), j, True, gl Else varhash.ItemCreator here$ + "." + myUcase(Name$), j, True, gl End If End Sub Sub GlobalVarRefLink2(Name$, j As Long, Optional gl As Boolean = False) varhash.ItemCreator myUcase(Name$), j, True, gl End Sub Function LinkGroup(bstack As basetask, ByVal Name$, inpq As Variant, Optional usefinal As Boolean = False) As Boolean Dim i As Long, Vlist As Boolean, FList, f$, aa$, v As Long Dim s() As String, ThisGroup As Group, q As Group, ss$, it As Long, ohere$, itGroup As Group Dim UnhidePrivate As Boolean, c As Constant If VarTypeName(inpq) <> mGroup Then Exit Function Set q = inpq If q.IamApointer Then Exit Function End If If bstack.tpointer <> 0 Then If VarTypeName(var(bstack.tpointer)) = mGroup Then Set ThisGroup = var(bstack.tpointer) UnhidePrivate = q.MatchTypes(ThisGroup.mytypes) Set ThisGroup = Nothing End If End If If Not usefinal Then If here$ = vbNullString Then Name$ = Name$ + "." Else Name$ = here$ + "." + myUcase(Name$) + "." End If End If cont1: FList = q.FuncList ohere$ = here$ here$ = Left$(Name$, Len(Name$) - 1) Dim iamvariant As Boolean For i = 1 To q.FieldsCount aa$ = q.ReadField(i) v = Abs(Split(aa$)(1)) Vlist = True If MyIsObject(var(v)) Then Select Case Typename(var(v)) Case mGroup Set ThisGroup = var(v) With ThisGroup ss$ = Split(aa$)(0) If Left$(ss$, 1) = "#" Then iamvariant = True: ss$ = Mid$(ss$, 2) Else iamvariant = False If Left$(ss$, 1) = "*" Then ss$ = Mid$(ss$, 2) If UnhidePrivate And AscW(ss$) = -65 Then ss$ = Mid$(ss$, 2) End If If .IamApointer Then varhash.ItemCreator Name$ + ss$, v, True Else it = globalvar(ss$, it) MakeitObject2 var(it) LinkGroup bstack, ss$, var(v) Set itGroup = var(it) itGroup.edittag = .edittag itGroup.FuncList = .FuncList itGroup.GroupName = ss$ + "." ' Set itGroup.Sorosref = .soros.Copy If UBound(.Fields) > 1 Then itGroup.Fields = .Fields itGroup.HasValue = .HasValue itGroup.HasSet = .HasSet itGroup.HasStrValue = .HasStrValue itGroup.HasParameters = .HasParameters itGroup.HasParametersSet = .HasParametersSet itGroup.HasRemove = .HasRemove Set itGroup.Events = .Events itGroup.highpriorityoper = .highpriorityoper itGroup.HasUnary = .HasUnary itGroup.Patch = Name$ + ss$ If .HasStrValue Then varhash.ItemCreator Name$ + ss$ + "$", it, True, , True End If Set itGroup.mytypes = .mytypes End If Else it = globalvar(ss$, it) MakeitObject2 var(it) Set itGroup = var(it) If .IamApointer Then If .link.IamFloatGroup Then Set itGroup.LinkRef = .link itGroup.IamApointer = True itGroup.isRef = True Else itGroup.edittag = .link.edittag itGroup.FuncList = .link.FuncList itGroup.GroupName = ss$ + "." ' Set itGroup.Sorosref = .link.soros.Copy If UBound(.link.Fields) > 1 Then itGroup.Fields = .link.Fields itGroup.HasValue = .link.HasValue itGroup.HasSet = .link.HasSet itGroup.HasStrValue = .link.HasStrValue itGroup.HasParameters = .link.HasParameters itGroup.HasParametersSet = .link.HasParametersSet itGroup.HasRemove = .link.HasRemove Set itGroup.Events = .link.Events itGroup.highpriorityoper = .link.highpriorityoper itGroup.HasUnary = .link.HasUnary itGroup.Patch = here$ + "." + ss$ If .link.HasStrValue Then varhash.ItemCreator Name$ + ss$ + "$", it, True, , True End If Set itGroup.mytypes = .link.mytypes End If Else If UnhidePrivate And AscW(ss$) = -65 Then ss$ = Mid$(ss$, 2) End If varhash.ItemCreator Name$ + ss$, v, True, , Not iamvariant End If End If End With Case "lambda" IsLambda: ss$ = Split(aa$)(0) If Left$(ss$, 1) = "#" Then iamvariant = True: ss$ = Mid$(ss$, 2) Else iamvariant = False If UnhidePrivate And AscW(ss$) = -65 Then ss$ = Mid$(ss$, 2) End If varhash.ItemCreator Name$ + ss$, v, True, , Not iamvariant GlobalSub Name$ + ss$ + "()", "", Name$, , v Case "Constant" If var(v).flag Then GoTo IsLambda Else GoTo cont123 End If Case Else GoTo cont123 End Select Else cont123: ss$ = Split(aa$)(0) If Left$(ss$, 1) = "#" Then iamvariant = True: ss$ = Mid$(ss$, 2) Else iamvariant = False varhash.ItemCreator Name$ + ss$, v, True, , Not iamvariant If UnhidePrivate And AscW(ss$) = -65 Then varhash.ItemCreator Name$ + Mid$(ss$, 2), v, True, , Not iamvariant End If End If Next Dim mm As Long Dim als As Long Dim subname$ If FList <> "" Then If UnhidePrivate Then subname$ = Replace(FList, ChrW(-65), "") subname$ = Replace(Replace(subname$, Chr$(3), Name$), Chr$(2), Name$) Else subname$ = Replace(Replace(FList, Chr$(3), Name$), Chr$(2), Name$) End If s() = Split(subname$, Chr$(1)) For i = LBound(s$()) + 1 To UBound(s$()) If s(i) <> "" Then mm = val(Split(s(i))(1)) als = AllocSub() sbf(als) = sbf(Abs(mm)) ss$ = Split(s(i))(0) subHash.ItemCreator ss$, als, True End If Next i End If here$ = ohere$ LinkGroup = Vlist Or FList <> "" End Function Sub GlobalArr(bstack As basetask, Name$, rst$, items As Long, q As Long, Optional useglobalname As Boolean = False, Optional Reverse As Boolean = False, Optional declareglobal As Boolean = False) ' new mArray.. Dim afto As New mArray, NewKey As Long, zeroitem As Object If rst$ = vbNullString And q = -1 Then ' Make an empty array rst$ = NLtrim(rst$) GoTo dummyarray End If Dim j As Long, i As Long, p As Variant, aa As Boolean, onemore As Long, pbase As Variant If (DimLikeBasic Or bstack.BasicSwitch) And ArrBase = 0 Then onemore = 1: Reverse = True items = 1 i = 0 If FastSymbol(rst$, ChrW(8)) Then pbase = afto.myarrbase i = 1 GoTo neojump1 Else Do If IsExp(bstack, rst$, p, flatobject:=True, nostring:=True) Then pbase = afto.myarrbase If Fast2Label(rst$, "TO", 2, "ΕΩΣ", 3, 3) Then pbase = -p onemore = 0 If IsExp(bstack, rst$, p, flatobject:=True, nostring:=True) Then If p < -pbase Then j = -p p = -pbase pbase = j End If p = p + pbase + 1 Else missNumber Exit Sub End If End If i = i + 1 If onemore Then If p > 0 Then p = p + onemore items = items * Int(Abs(p)) afto.PushDim CLng(p), pbase aa = True Else GoTo dummyarray End If If i > 9 Then Exit Do Loop Until Not FastSymbol(rst$, ",") End If If aa And FastSymbol(rst$, ")") Then neojump1: afto.RevOrder = Reverse If Right$(Name$, 2) <> "$(" Then If Fast2VarNoTrim(rst$, "ΩΣ", 2, "AS", 2, 3, j) Then i = 0 j = j - 1 If IsLabelSymbolNew(rst$, "ΑΡΙΘΜΟΣ", "DECIMAL", j, i) Then afto.MyTypeToBe = vbDecimal ElseIf IsLabelSymbolNew(rst$, "ΔΙΠΛΟΣ", "DOUBLE", j, i) Then afto.MyTypeToBe = vbDouble ElseIf IsLabelSymbolNew(rst$, "ΑΠΛΟΣ", "SINGLE", j, i) Then afto.MyTypeToBe = vbSingle ElseIf IsLabelSymbolNew(rst$, "ΛΟΓΙΚΟΣ", "BOOLEAN", j, i) Then afto.MyTypeToBe = vbBoolean ElseIf IsLabelSymbolNew(rst$, "ΜΑΚΡΥΣ", "LONG", j, i) Then If IsLabelSymbolNew(rst$, "ΜΑΚΡΥΣ", "LONG", j) Then afto.MyTypeToBe = 20 Else afto.MyTypeToBe = vbLong End If ElseIf IsLabelSymbolNew(rst$, "ΑΚΕΡΑΙΟΣ", "INTEGER", j, i) Then afto.MyTypeToBe = vbInteger ElseIf IsLabelSymbolNew(rst$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", j, i) Then afto.MyTypeToBe = vbCurrency ElseIf IsLabelSymbolNew(rst$, "ΨΗΦΙΟ", "BYTE", j, i) Then afto.MyTypeToBe = vbByte ElseIf IsLabelSymbolNew(rst$, "ΓΡΑΜΜΑ", "STRING", j, i) Then afto.MyTypeToBe = vbString ElseIf IsLabelSymbolNew(rst$, "ΜΙΓΑΔΙΚΟΣ", "COMPLEX", j, i) Then afto.MyTypeToBe = 200 ElseIf IsLabelSymbolNew(rst$, "ΑΤΥΠΟΣ", "VARIANT", j, i) Then afto.MyTypeToBe = vbVariant ElseIf IsLabelSymbolNew(rst$, "ΑΝΤΙΚΕΙΜΕΝΟ", "OBJECT", j, i) Then afto.MyTypeToBe = vbObject ElseIf IsLabelSymbolNew(rst$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", j, i) Then afto.MyTypeToBe = 201 Set zeroitem = New BigInteger ElseIf IsLabelSymbolNew(rst$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", j, i) Then afto.MyTypeToBe = vbObject Set zeroitem = Nothing ElseIf IsLabelSymbolNew(rst$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", j, i) Then afto.MyTypeToBe = vbDate ' ElseIf IsLabelSymbolNew(rst$, "ΔΙΕΠΑΦΗ", "INTERFACE", j, i) Then ' afto.MyTypeToBe = vbDataObject End If End If End If If p < 0 Then End If afto.PushEnd If Not zeroitem Is Nothing Then afto.SerialItem CVar(zeroitem), 0, 3 ' afto.Fillobj bstack Set zeroitem = Nothing End If dummyarray: NewKey = AllocVar() ' version 8.1 ' check if is already in ucase Name$ = myUcase(Name$) If here$ = vbNullString Or useglobalname Then ''If bstack.tpointer > 0 Then varhash.ItemCreator (Name$), NewKey, , declareglobal, True afto.arrname = Name$ Else varhash.ItemCreator here$ + "." + bstack.GroupName + Name$, NewKey, , , True 'afto.arrname = here$ + "." + bstack.GroupName + Name$ afto.arrname = bstack.GroupName + Name$ End If If q = -1 Then q = NewKey End If Set var(NewKey) = afto Else If FastSymbol(rst$, ",") Then items = 0 MyEr "No more 10 dimensions allowed", "Μέχρι 10 διαστάσεις επιτρέπονται" Else items = -1 rst$ = ":?" + rst$ End If End If End Sub Private Function GlobalArrProp(bstack As basetask, Name$, globalName As Boolean) As ppppLight ' new mArray.. Dim afto As New ppppLight, NewKey As Long afto.PushDim 1 afto.PushEnd NewKey = AllocVar() Name$ = myUcase(Name$) If here$ = vbNullString Or globalName Then varhash.ItemCreator (Name$), NewKey, , , True afto.arrname = Name$ Else varhash.ItemCreator here$ + "." + bstack.GroupName + Name$, NewKey, , , True afto.arrname = bstack.GroupName + Name$ End If Set var(NewKey) = afto Set GlobalArrProp = afto End Function Sub GlobalArrResize(afto As mArray, bstack As basetask, Name$, rst$, items As Long) ' new mArray.. Dim j As Long, i As Long, p As Variant, aa As Boolean, onemore As Long, pbase As Variant If DimLikeBasic And afto.myarrbase = 0 Then onemore = 1 items = 1 i = 0 afto.StartResize If FastSymbol(rst$, ChrW(8)) Then pbase = afto.myarrbase i = 1 items = 0 afto.PushDim 0&, pbase afto.PushEnd Else Do If IsExp(bstack, rst$, p) Then If afto.IHaveGui And p <> 0 Then GoTo noredim pbase = afto.myarrbase If Fast2Label(rst$, "TO", 2, "ΕΩΣ", 3, 3) Then pbase = -p onemore = 0 If IsExp(bstack, rst$, p) Then If p < -pbase Then j = -p p = -pbase pbase = j End If p = p + pbase + 1 Else missNumber Exit Sub End If End If i = i + 1 If onemore Then If p > 0 Then p = p + onemore items = items * Int(Abs(p)) afto.PushDim CLng(p), pbase aa = True Else GoTo fault End If If i > 9 Then Exit Do Loop Until Not FastSymbol(rst$, ",") afto.PushEnd fault: If aa And FastSymbol(rst$, ")") Then i = 1 If Fast2VarNoTrim(rst$, "ΩΣ", 2, "AS", 2, 3, i) Then Dim ss$ If IsLabelOnly(rst$, ss$) = 1 Then Else SyntaxError End If End If Else If FastSymbol(rst$, ",") Then items = 0 MyEr "No more 10 dimensions allowed", "Μέχρι 10 διαστάσεις επιτρέπονται" Else items = -1 rst$ = ":?" + rst$ End If End If End If Exit Sub noredim: MyEr "No Redim allowed, use Declare Over/Under ", "Δεν επιτρέπονται αλλαγές, χρησιμοποίησε την ΟΡΙΣΕ ΠΑΝΩ/ΥΠΟ" End Sub Function neoGetArray(bstack As basetask, ByVal nm$, ga As iBoxArray, Optional searchonly As Boolean = False, Optional ByVal useglobalname As Boolean = False, Optional useLocalOnly As Boolean = False, Optional rightexpression As Boolean, Optional feedback As Boolean, Optional fromthere As Long = 0, Optional noobj As Boolean = False) As Boolean Dim k As Long, myobject As Object Dim n$, hidden As Boolean If Len(nm$) = 0 Then SyntaxError: Exit Function 'nm$ = myUcase(nm$) from revision 32 version 14 this removed If useglobalname Or here$ = vbNullString Then n$ = bstack.GroupName + nm$ ElseIf Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then GoTo here12 Else hidden = Left$(nm$, 1) = ChrW(&H1FFF) n$ = here$ + "." + bstack.GroupName + nm$ End If If Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then If useLocalOnly Then Exit Function here12: If Len(bstack.UseGroupname) > 0 Then If Mid$(nm$, 6, 1) = ChrW(&HFFBF) Then n$ = bstack.UseGroupname + Mid$(nm$, 6) If Not varhash.Find3(n$, k, feedback) Then GoTo isagroupvalue ' varhash.Find3 Left$(n$, Len(n$) - 2), k, feedback End If Else n$ = bstack.UseGroupname + Mid$(nm$, 6) If Not varhash.Find3(n$, k, feedback) Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) varhash.Find3 n$, k, feedback End If End If If k = 0 Then ' check for inventory n$ = bstack.UseGroupname + Mid$(nm$, 6) isagroupvalue: If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then If MyIsObject(var(k)) Then If var(k) Is Nothing Then Set ga = New ppppLight Set ga.GroupRef = Nothing ga.arr = False neoGetArray = True Exit Function ElseIf TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function Case Else k = 0 End Select ElseIf TypeOf var(k) Is Group Then GoTo checkgroup End If End If End If n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function End Select End If k = -1 End If End If Else n$ = Mid$(nm$, 5) If bstack.GetDot(n$, 1) Then varhash.Find3 here$ + "." + n$, k, feedback Else Exit Function End If ElseIf varhash.Find(n$, k) = False Then If useLocalOnly Then If Len(bstack.UseGroupname) > 0 Then If InStr(nm$, bstack.UseGroupname) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, Len(bstack.UseGroupname) + 1) varhash.Find3 n$, k, feedback Else If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then GoTo contHandler End If End If Else If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then contHandler: If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function End Select ElseIf TypeOf var(k) Is Group Then checkgroup: If rightexpression Then If var(k).HasParametersSet Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True End If Exit Function ElseIf var(k).HasParameters Then Set ga = New ppppLight Set ga.GroupRef = var(k) If Not hidden Then ga.CodeName = var(k).FloatGroupName If Len(ga.CodeName) = 0 Then ga.CodeName = n$ Else ga.CodeName = vbNullString End If ga.arr = False neoGetArray = True Exit Function Else Exit Function End If ElseIf TypeOf var(k) Is PropReference Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function ElseIf TypeOf var(k) Is lambda Then ElseIf MyIsObject(var(k)) And Not noobj Then getnewprop: Dim neoProp As PropReference Set neoProp = New PropReference Set myobject = var(k) neoProp.ConstructObj myobject, 0 Set ga = New ppppLight Set ga.GroupRef = neoProp ga.arr = False neoGetArray = True Exit Function End If k = -1 End If End If Else If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then checkforglobal: If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function End Select Else If MyIsObject(var(k)) Then If Typename(var(k)) = mGroup Then checkgrouphere: If var(k).HasParametersSet Then ' process parameters Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True If rightexpression Then Exit Function ElseIf var(k).HasParameters Then ' this is for inventories Set ga = New tuple Set ga.GroupRef = var(k) ga.CodeName = n$ ga.arr = False neoGetArray = True End If Exit Function ElseIf TypeOf var(k) Is lambda Then ElseIf TypeOf var(k) Is PropReference Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function Else GoTo getnewprop Exit Function End If Else If varhash.Find(nm$, k) Then GoTo conthere Exit Function End If End If k = -1 n$ = bstack.GroupName + nm$ Else n$ = nm$ If Not varhash.Find3(n$, k, feedback) Then If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then GoTo checkforglobal n$ = nm$ End If End If End If Else fromthere = 0 End If conthere: If k <= 0 Then If searchonly Then Exit Function If Not useLocalOnly Then n$ = nm$ varhash.Find3 n$, k, feedback Else If bstack.StaticCollection Is Nothing Then Exit Function If bstack.ExistVar(Left$(nm$, Len(nm$) - 1)) Then bstack.ReadVar Left$(nm$, Len(nm$) - 1), var(0) If VarTypeName(var(0)) = mHdlr Then Set ga = New ppppLight Set ga.GroupRef = var(0) ga.arr = False neoGetArray = True var(0) = 0& Exit Function End If var(0) = 0& Exit Function End If Exit Function End If End If If k > fromthere Then If myVarType(var(k), vbEmpty) Then Set ga = New tuple: neoGetArray = True Else If TypeOf var(k) Is iBoxArray Then Set ga = var(k) Else Set myobject = var(k) If CheckAnyArray(myobject) Then Set ga = myobject Else NotArray Set myobject = Nothing Exit Function End If Set myobject = Nothing End If End If neoGetArray = True ElseIf k = 0 Then If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find(n$, k) Then If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function End Select End If k = -1 End If If n$ = vbNullString Then Exit Function nm$ = Mid$(n$, 1, Len(n$) - 1) If Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then If useLocalOnly Then Exit Function If Len(bstack.UseGroupname) > 0 Then n$ = bstack.UseGroupname + Mid$(nm$, 6) If Not varhash.Find(n$, k) Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) varhash.Find n$, k End If Else n$ = Mid$(nm$, 5) If bstack.GetDot(n$, 1) Then varhash.Find here$ + "." + n$, k Else Exit Function End If End If If varhash.Find(n$, k) Then If TypeOf var(k) Is mHandler Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray = True Exit Function End If End If End If End Function ' Function neoGetArray0(bstack As basetask, ByVal nm$, ga As iBoxArray, Optional searchonly As Boolean = False, Optional ByVal useglobalname As Boolean = False, Optional useLocalOnly As Boolean = False, Optional rightexpression As Boolean, Optional feedback As Boolean, Optional fromthere As Long = 0) As Boolean Dim k As Long, myobject As Object Dim n$, hidden As Boolean If Len(nm$) = 0 Then SyntaxError: Exit Function 'nm$ = myUcase(nm$) from revision 32 version 14 this removed If useglobalname Or here$ = vbNullString Then n$ = bstack.GroupName + nm$ ElseIf Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then GoTo here12 Else hidden = Left$(nm$, 1) = ChrW(&H1FFF) n$ = here$ + "." + bstack.GroupName + nm$ End If If Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then If useLocalOnly Then Exit Function here12: If Len(bstack.UseGroupname) > 0 Then If Mid$(nm$, 6, 1) = ChrW(&HFFBF) Then n$ = bstack.UseGroupname + Mid$(nm$, 6) If Not varhash.Find3(n$, k, feedback) Then GoTo isagroupvalue ' varhash.Find3 Left$(n$, Len(n$) - 2), k, feedback End If Else n$ = bstack.UseGroupname + Mid$(nm$, 6) If Not varhash.Find3(n$, k, feedback) Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) varhash.Find3 n$, k, feedback End If End If If k = 0 Then ' check for inventory n$ = bstack.UseGroupname + Mid$(nm$, 6) isagroupvalue: If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then If MyIsObject(var(k)) Then If var(k) Is Nothing Then Set ga = New ppppLight Set ga.GroupRef = Nothing ga.arr = False neoGetArray0 = True Exit Function ElseIf TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function Case Else k = 0 End Select ElseIf TypeOf var(k) Is Group Then GoTo checkgroup End If End If End If n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function End Select End If k = -1 End If End If Else n$ = Mid$(nm$, 5) If bstack.GetDot(n$, 1) Then varhash.Find3 here$ + "." + n$, k, feedback Else Exit Function End If ElseIf varhash.Find(n$, k) = False Then If useLocalOnly Then If Len(bstack.UseGroupname) > 0 Then If InStr(nm$, bstack.UseGroupname) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, Len(bstack.UseGroupname) + 1) varhash.Find3 n$, k, feedback Else If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then GoTo contHandler End If End If Else If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then contHandler: If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function End Select ElseIf TypeOf var(k) Is Group Then checkgroup: If rightexpression Then If var(k).HasParametersSet Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True End If Exit Function ElseIf var(k).HasParameters Then Set ga = New ppppLight Set ga.GroupRef = var(k) If Not hidden Then ga.CodeName = var(k).FloatGroupName If Len(ga.CodeName) = 0 Then ga.CodeName = n$ Else ga.CodeName = vbNullString End If ga.arr = False neoGetArray0 = True Exit Function Else Exit Function End If ElseIf TypeOf var(k) Is PropReference Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function End If k = -1 End If End If Else If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then checkforglobal: If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function End Select Else If MyIsObject(var(k)) Then If Typename(var(k)) = mGroup Then checkgrouphere: If var(k).HasParametersSet Then ' process parameters Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True If rightexpression Then Exit Function ElseIf var(k).HasParameters Then ' this is for inventories Set ga = New tuple Set ga.GroupRef = var(k) ga.CodeName = n$ ga.arr = False neoGetArray0 = True End If Exit Function ElseIf TypeOf var(k) Is PropReference Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function Else If varhash.Find(nm$, k) Then GoTo conthere Exit Function End If Else If varhash.Find(nm$, k) Then GoTo conthere Exit Function End If End If k = -1 n$ = bstack.GroupName + nm$ Else n$ = nm$ If Not varhash.Find3(n$, k, feedback) Then If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find3(n$, k, feedback) Then GoTo checkforglobal n$ = nm$ End If End If End If Else fromthere = 0 End If conthere: If k <= 0 Then If searchonly Then Exit Function If Not useLocalOnly Then n$ = nm$ varhash.Find3 n$, k, feedback Else If bstack.StaticCollection Is Nothing Then Exit Function If bstack.ExistVar(Left$(nm$, Len(nm$) - 1)) Then bstack.ReadVar Left$(nm$, Len(nm$) - 1), var(0) If VarTypeName(var(0)) = mHdlr Then Set ga = New ppppLight Set ga.GroupRef = var(0) ga.arr = False neoGetArray0 = True var(0) = 0& Exit Function End If var(0) = 0& Exit Function End If Exit Function End If End If If k > fromthere Then If myVarType(var(k), vbEmpty) Then Set ga = New tuple: neoGetArray0 = True Else If TypeOf var(k) Is iBoxArray Then Set ga = var(k) Else Set myobject = var(k) If CheckAnyArray(myobject) Then Set ga = myobject Else NotArray Set myobject = Nothing Exit Function End If Set myobject = Nothing End If End If neoGetArray0 = True ElseIf k = 0 Then If n$ Like "*[$%](" Then n$ = Mid$(n$, 1, Len(n$) - 2) Else n$ = Mid$(n$, 1, Len(n$) - 1) End If If varhash.Find(n$, k) Then If TypeOf var(k) Is mHandler Then Select Case var(k).t1 Case Is < 3, 5 Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function End Select End If k = -1 End If If n$ = vbNullString Then Exit Function nm$ = Mid$(n$, 1, Len(n$) - 1) If Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then If useLocalOnly Then Exit Function If Len(bstack.UseGroupname) > 0 Then n$ = bstack.UseGroupname + Mid$(nm$, 6) If Not varhash.Find(n$, k) Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) varhash.Find n$, k End If Else n$ = Mid$(nm$, 5) If bstack.GetDot(n$, 1) Then varhash.Find here$ + "." + n$, k Else Exit Function End If End If If varhash.Find(n$, k) Then If TypeOf var(k) Is mHandler Then Set ga = New ppppLight Set ga.GroupRef = var(k) ga.arr = False neoGetArray0 = True Exit Function End If End If End If End Function Function neoGetArrayLinkOnly(bstack As basetask, ByVal nm$, link As Long, Optional useglobalname As Boolean = False, Optional useLocalOnly As Boolean = False) As Boolean Dim k As Long Dim n$ nm$ = myUcase(nm$) If useglobalname Then n$ = nm$ Else If here$ = vbNullString Then n$ = nm$ Else n$ = here$ + "." + bstack.GroupName + nm$ End If End If If varhash.Find(n$, k) = False And Len(bstack.UseGroupname) > 0 Then If Left$(nm$, 5) = "ΑΥΤΟ." Or Left$(nm$, 5) = "THIS." Then If useLocalOnly Then Exit Function If StripThis2(bstack.UseGroupname) = vbNullString Then n$ = bstack.UseGroupname + Mid$(nm$, 6) Else n$ = StripThis2(bstack.UseGroupname) + "." + Mid$(nm$, 6) End If varhash.Find n$, k End If End If If k = 0 Then If Not useLocalOnly Then n$ = myUcase(nm$) varhash.Find n$, k End If End If If k > 0 Then link = k neoGetArrayLinkOnly = True End If End Function Function CopyArrayItems(bstack As basetask, nm$) As String Dim k As Long If neoGetArrayLinkOnly(bstack, nm$, k) Then CopyArrayItems = CStr(k) End Function Function CopyArrayItemsNoFormated(bstack As basetask, nm$) As Long Dim k As Long If varhash.Find(nm$, k) Then CopyArrayItemsNoFormated = k ElseIf varhash.Find(nm$, k) Then If TypeOf var(k) Is mHandler Then CopyArrayItemsNoFormated = -k End If End If End Function Function ModuleSubAsap(n$, q As String, Optional sbgroupname As String = vbNullString, Optional Extern As Long) As Long Dim j As Long, where As Long j = AllocSub() With sbf(j) .Extern = Extern .sb = q .sbc = 0 .sbgroup = sbgroupname Set .subs = Nothing Set .Pad = Nothing .goodname = n$ .Changed = False End With subHash.ItemCreator n$, j ModuleSubAsap = j End Function Function ModuleSub(Name$, q As String, Optional sbgroupname As String = vbNullString) As Long Dim j As Long, n$, where As Long n$ = myUcase(Name$, True) j = AllocSub() With sbf(j) .Extern = 0 .sb = q .sbc = 0 .sbgroup = sbgroupname Set .subs = Nothing Set .Pad = Nothing .goodname = Name$ .Changed = False .locked = Right$(q, 1) = ChrW(&H1FFD) If .locked Then On Error Resume Next where = val(Mid$(q, InStr(q, "CALL EXTERN ") + 12)) If VarType(var(where)) = vbObject Then If TypeOf var(where) Is lambda Then .Extern = where ElseIf Not TypeOf var(where) Is stdCallFunction Then GoTo mes11 Else .sbc = where End If Else mes11: MyEr "Declaration Problem " + Name$, "Πρόβλημα Ορισμού " + Name$ Exit Function End If End If End With subHash.ItemCreator n$, j ModuleSub = j End Function Function GlobalSub(Name$, q As String, Optional sbgroupname As String = vbNullString, Optional ByVal nameonly$ = vbNullString, Optional Extern As Long = 0) As Long Dim j As Long, n$, where As Long n$ = myUcase(Name$, True) j = AllocSub() With sbf(j) .Extern = Extern .sb = q .sbc = 0 .sbgroup = sbgroupname .tpointer = 0 Set .subs = Nothing Set .Pad = Nothing .goodname = Name$ .Changed = False End With If Not nameonly$ = vbNullString Then If sbgroupname = vbNullString Then nameonly$ = myUcase(nameonly$, True) If comhash.Find(nameonly$, where) Then If n$ = nameonly$ Then comhash.ItemCreator2 nameonly$, 0, 32 Else comhash.ItemCreator2 nameonly$, 0, 33 End If End If End If End If subHash.ItemCreator n$, j GlobalSub = j End Function Function GetGlobalVar(nm$, i As Long) As Boolean If varhash.Find(myUcase(nm$), i) Then GetGlobalVar = True End If End Function Function StripThis(ByVal n$) As String Dim a$, b$, i& a$ = n$ DropLeft "».", a$ 'Exit Function a$ = StripRVAL(a$) ' we need that If a$ = n$ Then StripThis = vbNullString Exit Function Else b$ = a$ End If i& = InStr(n$, ".") If i& > 0 Then DropLeft ".", n$ i& = InStrRev(n$, ".") - 1 If i& > 0 Then StripThis = b$ + "." + Left$(n$, i&) Else StripThis = b$ End If Else StripThis = b$ End If End Function Function StripThis2(ByVal n$) As String Dim a$, b$, i& If StripRVAL2(n$, a$) Then StripThis2 = a$ Exit Function End If If a$ = n$ Then StripThis2 = vbNullString Exit Function Else b$ = a$ End If i& = InStr(n$, ".") If i& > 0 Then DropLeft ".", n$ i& = InStrRev(n$, ".") - 1 If i& > 0 Then StripThis2 = b$ + "." + Left$(n$, i&) Else StripThis2 = b$ End If Else StripThis2 = b$ End If End Function Function GetVar1(bstack As basetask, ByVal nm$, i As Long, Optional lookglobalonly As Boolean = False, Optional skip As Boolean, Optional looklocalonly As Boolean = False, Optional finalname As String, Optional checktype As Boolean = 0) As Boolean If skip Then Exit Function ' called from unfloat If varhash.Find2(nm$, i, checktype) Then GetVar1 = True End Function Function GetVar3(bstack As basetask, ByVal nm$, i As Long, Optional lookglobalonly As Boolean = False, Optional skip As Boolean, Optional looklocalonly As Boolean = False, Optional finalname As String, Optional checktype As Boolean = 0, Optional feedback As Boolean, Optional nosearch As Boolean, Optional statobj As Boolean = False) As Boolean If skip Then Exit Function If Not bstack.StaticCollection Is Nothing Then If bstack.ExistVar(nm$, statobj) Then i = -1: Exit Function End If Dim n$, cc As Long cc = Len(nm$) If cc > 5 Then If Left$(nm$, 5) = "ΑΥΤΟ." Then GoTo cont1 ElseIf Left$(nm$, 5) = "THIS." Then cont1: If Len(bstack.UseGroupname) > 0 Then feedback = False n$ = bstack.UseGroupname + Mid$(nm$, 6) If varhash.Find2(n$, cc, checktype) Then finalname = n$: GoTo there12 n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) If varhash.Find2(n$, cc, checktype) Then finalname = n$: GoTo there12 Else n$ = StripThis2(here$) If n$ <> vbNullString Then n$ = n$ + "." + Mid$(nm$, 6) Else If IsLabel(bstack, Mid$(nm$, 6), n$) Then n$ = here$ + "." + n$ Else n$ = here$ + "." + nm$ End If End If End If Else If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If End If ElseIf cc = 4 Then If nm$ = "ΑΥΤΟ" Then GoTo cont2 ElseIf nm$ = "THIS" Then cont2: n$ = vbNullString If bstack.GetDotNew(n$, 1) Then If Len(n$) = 0 Then GetVar3 = False: Exit Function nm$ = Left$(n$, Len(n$) - 1) finalname = nm$ feedback = True End If End If If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If Else If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If End If If varhash.Find2(n$, cc, checktype, feedback) Then there12: GetVar3 = True i = cc ElseIf Not looklocalonly Then n$ = nm$ If Len(bstack.UseGroupname) > 0 Then If InStr(n$, bstack.UseGroupname) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(n$, Len(bstack.UseGroupname) + 1) If varhash.Find(n$, cc) Then checktype = True i = cc GetVar3 = True nm$ = n$ End If ElseIf InStr(bstack.UseGroupname, n$) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(n$, Len(bstack.UseGroupname) + 1) If varhash.Find2(n$, cc, checktype, feedback) Then i = cc GetVar3 = True nm$ = n$ End If End If End If If Not GetVar3 Then If varhash.Find2(nm$, cc, checktype, feedback) Then i = cc GetVar3 = True End If End If End If End Function Function GetVar(bstack As basetask, ByVal nm$, i As Long, Optional lookglobalonly As Boolean = False, Optional skip As Boolean, Optional looklocalonly As Boolean = False, Optional finalname As String, Optional checktype As Boolean = 0, Optional feedback As Boolean, Optional nosearch As Boolean) As Boolean If skip Then Exit Function If Not bstack.StaticCollection Is Nothing Then If bstack.ExistVar(nm$) Then i = -1: Exit Function End If Dim n$, cc As Long cc = Len(nm$) If cc > 5 And i >= 0 Then If Left$(nm$, 5) = "ΑΥΤΟ." Then GoTo cont1 ElseIf Left$(nm$, 5) = "THIS." Then cont1: If Len(bstack.UseGroupname) > 0 Then feedback = False n$ = bstack.UseGroupname + Mid$(nm$, 6) If varhash.Find2(n$, cc, checktype) Then finalname = n$: GoTo there12 n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) If varhash.Find2(n$, cc, checktype) Then finalname = n$: GoTo there12 Else n$ = StripThis2(here$) If n$ <> vbNullString Then n$ = n$ + "." + Mid$(nm$, 6) Else If IsLabel(bstack, Mid$(nm$, 6), n$) Then n$ = here$ + "." + n$ Else n$ = here$ + "." + nm$ End If End If End If Else If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If End If Else If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If End If If varhash.Find2(n$, cc, checktype, feedback) Then there12: GetVar = True i = cc ElseIf Not looklocalonly Then n$ = nm$ If Len(bstack.UseGroupname) > 0 Then If InStr(n$, bstack.UseGroupname) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(n$, Len(bstack.UseGroupname) + 1) If varhash.Find(n$, cc) Then checktype = varhash.vType(varhash.index) i = cc GetVar = True nm$ = n$ End If ElseIf InStr(bstack.UseGroupname, n$) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(n$, Len(bstack.UseGroupname) + 1) If varhash.Find2(n$, cc, checktype, feedback) Then i = cc GetVar = True nm$ = n$ End If End If End If If Not GetVar Then If varhash.Find2(nm$, cc, checktype, feedback) Then i = cc GetVar = True ElseIf varhash.Find2(here$ + "." + nm$, cc, checktype, feedback) Then i = cc GetVar = True End If End If End If End Function Function FindGuiImage(basestack As basetask, Scr As Object) As Object Dim p As Long p = GetCode(Scr) If p > 32 Then If getvar2(basestack, players(p).ControlName, p, True) Then Set FindGuiImage = var(p) End If End If End Function Function getvar2(bstack As basetask, nm$, i As Long, Optional lookglobalonly As Boolean = False, Optional skip As Boolean, Optional looklocalonly As Boolean = False) As Boolean If skip Then Exit Function If Not bstack.StaticCollection Is Nothing Then If bstack.ExistVar(nm$) Then i = -1: Exit Function End If Dim n$, cc As Long cc = Len(nm$) If cc > 5 Then If Left$(nm$, 5) = "ΑΥΤΟ." Then GoTo cont1 ElseIf Left$(nm$, 5) = "THIS." Then cont1: If Len(bstack.UseGroupname) > 0 Then n$ = bstack.UseGroupname + Mid$(nm$, 6) If varhash.Find(n$, cc) Then GoTo there12 n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, 6) If varhash.Find(n$, cc) Then GoTo there12 Else n$ = StripThis2(here$) If n$ <> "" Then n$ = n$ + "." + Mid$(nm$, 6) Else If IsLabel(bstack, Mid$(nm$, 6), n$) Then ' NO NEED DOT ANY MORE..(WE USE DOTNEW) n$ = here$ + "." + n$ Else n$ = here$ + "." + nm$ End If End If End If Else If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If End If ElseIf cc = 4 Then If nm$ = "ΑΥΤΟ" Then GoTo cont2 ElseIf nm$ = "THIS" Then cont2: n$ = vbNullString If bstack.GetDotNew(n$, 1) Then If Len(n$) = 0 Then getvar2 = False: Exit Function nm$ = Left$(n$, Len(n$) - 1) End If End If If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If Else If lookglobalonly Then n$ = nm$ Else n$ = here$ + "." + nm$ End If End If If varhash.Find(n$, cc) Then there12: getvar2 = True i = cc ElseIf Not looklocalonly Then If varhash.Find(nm$, cc) Then i = cc getvar2 = True ElseIf Len(bstack.UseGroupname) > 0 Then If InStr(nm$, bstack.UseGroupname) = 1 Then n$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(nm$, Len(bstack.UseGroupname) + 1) If varhash.Find(n$, cc) Then i = cc getvar2 = True End If End If End If End If End Function Function GetlocalVar(nm$, i As Long) As Boolean If varhash.Find(here$ + "." + myUcase(nm$), i) Then GetlocalVar = True End Function Function RVAL33(ByVal s$, v As Long) As String Dim ss$, n As Long, what$ n = InStrRev(s$, "«") If n = 0 Then RVAL33 = s$ + "«" & (v) & "»«" & (v) & "»" Else ss$ = Left$(s$, n - 1&) RVAL33 = RVAL(ss$, 1) & "«" & (v) & "»" End If End Function Function RVAL2(ByVal s$, v As Long) As String Dim ss$ If InStr(s$, "«") = 0 Then RVAL2 = s$ Else ss$ = GetStrUntil("«", s$) If val(s$) + v <= 0 Then RVAL2 = ss$ + "." Else RVAL2 = ss$ & "«" & (val(s$) + v) & "»." End If End If End Function Function iRVAL22(ByVal s$) As Long Dim n As Long iRVAL22 = val(Mid$(s$, InStrRev(s$, "«") + 1)) End Function Function RVAL(ByVal s$, v As Long) As String Dim ss$ If InStr(s$, "«") = 0 Then RVAL = s$ & "«" & (v) & "»" Else ss$ = GetStrUntil("«", s$) RVAL = ss$ & "«" & (val(s$) + v) & "»" End If End Function Function TheSame(ByVal s$, ByVal q$) As Boolean Dim part1 As String part1 = StripRVAL(s$) If part1 <> "" Then If InStr(part1, ".") > 0 Then ' all in part1 Else DropLeft ".", s$ part1 = part1 + "." + s$ End If End If TheSame = part1 = q$ End Function Function StripRVAL2(s$, result$) As Boolean ' return s$ number as string ' return function name... ' Dim bb$, VarName$ bb$ = s$ If InStr(s$, "«") = 0 Then ' look varlist to find group Dim i As Long i = InStrRev(s$, ".") If i > 1 Then s$ = Left$(s$, i - 1) If InStrRev(VarName$, "." + s$ + " ") < 1 Then Exit Function s$ = Mid$(VarName$, InStrRev(VarName$, Chr$(1), InStrRev(VarName$, "." + s$ + " ")) + 1) result$ = GetStrUntil(" ", s$) StripRVAL2 = True If Not VarTypeName(var(val(s$))) = mGroup Then StripRVAL2 = False: s$ = bb$: result$ = vbNullString Else result$ = GetStrUntil("«", s$) End If End Function Function StripRVAL(ByVal s$) As String Dim i i = InStrRev(s$, "«") If i = 0 Then ' do not delete this..... StripRVAL = s$ ElseIf i = 1 Then Else StripRVAL = Left$(s$, i - 1) End If End Function Function iRVAL(ByVal s$, v As Long) As Long If InStr(s$, "«") = 0 Then iRVAL = v Else DropLeft "«", s$ iRVAL = val(s$) + v End If End Function Function GetSubFullName(nm$, fullname$) As Boolean If Len(here$) > 0 Then If Len(here$) > Len(nm$) Then If Mid$(here$, Len(here$) - Len(nm$)) = "." + nm$ Then GetSubFullName = subHash.ExistKey(nm$) fullname = nm$: Exit Function End If End If End If If here$ <> "" Then GetSubFullName = subHash.ExistKey(here$ + "." + nm$) If GetSubFullName Then fullname$ = here$ + "." + nm$: Exit Function End If GetSubFullName = subHash.ExistKey(nm$) If GetSubFullName Then fullname$ = nm$ End Function Function GetSub2(bstack As basetask, nm$, i&) As Boolean i& = 0 If Len(here$) > 0 Then If Len(here$) > Len(nm$) Then If Mid$(here$, Len(here$) - Len(nm$)) = "." + nm$ Then ' i& = bstack.OriginalCode If bstack.IamLambda Then GetSub2 = subHash.Find(bstack.FuncRec, i&) If GetSub2 Then nm$ = bstack.FuncRec Else nm$ = sbf(i&).goodname GetSub2 = True End If End If ElseIf Right$(here$, 1) = "»" Then GetSub2 = subHash.Find(here$ + "." + nm$, i&) End If End If If i& = 0 And here$ <> "" Then GetSub2 = subHash.Find(here$ + "." + nm$, i&) ElseIf i& <> 0 Then Exit Function End If If i& = 0 Then GetSub2 = subHash.Find(nm$, i&) Else Exit Function End If If i& = 0 Then Else Exit Function End If End Function Function GetSub(nm$, i&) As Boolean i& = 0 If Len(here$) > 0 Then If Len(here$) > Len(nm$) Then If Mid$(here$, Len(here$) - Len(nm$)) = "." + nm$ Then GetSub = subHash.Find(StripRVAL(here$) + "." + nm$, i&) End If ElseIf Right$(here$, 1) = "»" Then GetSub = subHash.Find(here$ + "." + nm$, i&) End If End If If GetSub Then Exit Function If i& = 0 And here$ <> "" Then GetSub = subHash.Find(here$ + "." + nm$, i&) ElseIf i& <> 0 Then Exit Function End If If i& = 0 Then GetSub = subHash.Find(nm$, i&) End If End Function Function GetlocalSub(nm$, i&) As Boolean If subHash.Find(here$ + "." + nm$, i&) Then GetlocalSub = True End Function Function GetGlobalSubAfterHere(basestack As basetask, nm$, i&) As Boolean If basestack.IamAnEvent Or basestack.IamLambda Or basestack.IamAnEvent Then GetGlobalSubAfterHere = subHash.Find(nm$, i&) Exit Function ElseIf subHash.Find(nm$, i&) Then GetGlobalSubAfterHere = Not basestack.IamChild End If End Function Function GetlocalSubExtra(nm$, i&) As Boolean Dim n$ Dim subname$ subname$ = subHash.Show n$ = "." + nm$ + " " i& = InStr(subname$, n$) If i& > 0 Then GetlocalSubExtra = True i& = val(Mid$(subname$, i& + Len(n$))) Else GetlocalSubExtra = False End If End Function Function PosLabel(ByVal W$, b$, Optional ByVal lim As Long = 0) As Long Dim i As Long, j As Long, jmp As Boolean On Error Resume Next If val(Left$(W$, 1)) = 0 Then W$ = W$ + ":": jmp = True If lim = 0 Then lim = Len(b$) PosLabel = lim + 1 If Left$(b$, Len(W$)) = W$ Then If Not jmp Then If Mid$(b$, Len(W$) + 1, 1) Like "[0-9]" Then GoTo conthere i = 1 PosLabel = 1: Exit Function Else conthere: Dim w1$ w1$ = Chr(10) + W$ Do i = InStr(i + 1, b$, w1$) If i > 0 Then If jmp Then Exit Do If Not Mid$(b$, i + Len(W$) + 1, 1) Like "[0-9]" Then Exit Do i = i + Len(W$) Else Exit Do End If Loop If i = 0 Then Dim w2$ w1$ = " " + W$ w2$ = "0" + W$ Dim w3$ w3$ = ChrW(9) + W$ j = i Do again00: i = InStr(j + 1, b$, w3$) If i > lim Then Exit Function If i = 0 Then i = j j = InStr(i + 1, b$, w1$) If j > lim Then Exit Function If j = 0 Then i = 0: Exit Do i = j End If If i < 2 Then Exit Do j = MyTrimRfrom(b$, 1, i + 1) If j < 2 Then Exit Do If Mid$(b$, j - 1, 1) = Chr(10) Then If Not jmp Then If Not Mid$(b$, i + Len(W$) + 1, 1) Like "[0-9]" Then Exit Do Else Exit Do End If End If j = j + Len(W$) Loop If i = 0 Then j = 0 Do shiftone: i = InStr(j + 1, b$, w2$) If i > lim Then Exit Function If i = 0 Then Exit Do If Mid$(b$, i + Len(w2$), 1) Like "[0-9]" Then j = j + 1: GoTo shiftone If i <= 1 Then Exit Do j = i - 1 While j > 1 And Mid$(b$, j, 1) = "0" j = j - 1 Wend If j < 2 Then Exit Do If Mid$(b$, j, 1) = Chr(10) Then Exit Do j = MyTrimRfrom(b$, 1, j) - 1 If Mid$(b$, j, 1) = Chr(10) Then Exit Do j = i + Len(w2$) Loop End If End If End If If jmp Then If i > 0 Then While Mid$(b$, MyTrimLi(b$, i + Len(W$) + 1), 1) Like thislabel$ And i > 0 i = InStr(i + Len(W$) + 1, b$, Chr(10) + W$) Wend If i > lim Then Exit Function If i > 0 Then PosLabel = i + 1 End If Else If i > lim Then Exit Function If i > 1 Then PosLabel = i + 1 End If End Function Function logicalSelect(basestack As basetask, s$, D As Variant, Optional par As Long = 0, Optional flatobject As Boolean = False, Optional ByPass As Boolean = False, Optional sg As Integer = 1, Optional ByVal nostring As Boolean) As Boolean Dim b$, S2$, S3$, usehandler As mHandler, getcom As Boolean Dim ah As String, i As Long For i = 1 To Len(s$) If InStr("><=", Mid$(s$, i)) = 0 Then Exit For Next i If MemInt(VarPtr(D)) = vbString Then SwapString2Variant b$, D D = Empty GoTo conthere End If again11: If ByPass Then ah = aheadstatusFast(basestack.tmpstr) Else ah = aheadstatusFast(s$) End If If InStr(ah, "l") = 0 Then If InStr(ah, "N") > 0 Then If Len(ah) = 1 Then If Not IsNumber(basestack, s$, D, flatobject, sg) Then Set basestack.lastobj = Nothing If LastErNum1 < 0 Then Exit Function Else If flatobject Then Set basestack.lastobj = Nothing End If logicalSelect = True End If Else If Not IsNumber(basestack, s$, D, flatobject, sg) Then Set basestack.lastobj = Nothing If LastErNum1 < 0 Then Exit Function Else logicalSelect = True End If End If Else If par > 0 Then If Not GetArr(basestack, s$, D, S2$, 0, getcom) Then Set basestack.lastobj = Nothing Else If Len(s$) > 0 Then If AscW(s$) = 8 Then par = par - 1 ' what ???? ByPass = True GoTo again11 End If End If logicalSelect = True End If If logicalSelect Then par = par - 1 End If Exit Function Else logicalSelect = False End If End If If nostring Then If myVarType(D, vbString) Then GoTo jumpnostr1 s$ = NLtrim$(s$) Exit Function Else If Left$(ah, 2) = "SN" Then Exit Function nostring = False End If On Error Resume Next If Err.Number > 0 Then Exit Function If Left$(ah, 1) <> "N" Then IsStrExp basestack, s$, b$, False conthere: logicalSelect = False If Not mTextCompare Then If FastSymbol(s$, "=") Then logicalSelect = False If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ = S2$ Else MissStringExpr End If Exit Function ElseIf FastSymbol(s$, "<") Then logicalSelect = False If Left$(s$, 1) = "=" Then Mid$(s$, 1, 1) = " " If Left$(s$, 2) = " >" Then Mid$(s$, 2, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True Select Case b$ Case Is < S2$ D = -1 Case Is = S2$ D = 0 Case Else D = 1 End Select Else MissStringExpr End If Else If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ <= S2$ Else MissStringExpr End If End If Exit Function ElseIf Left$(s$, 1) = ">" Then Mid$(s$, 1, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ <> S2$ Else MissStringExpr End If ElseIf IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ < S2$ Else MissStringExpr End If Exit Function ElseIf FastSymbol(s$, ">") Then logicalSelect = False If Left$(s$, 1) = "=" Then Mid$(s$, 1, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ >= S2$ Else MissStringExpr End If ElseIf IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ > S2$ Else MissStringExpr End If Exit Function ElseIf FastSymbol(s$, "~") Then logicalSelect = False If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ Like S2$ Else MissStringExpr End If Exit Function ElseIf MaybeIsSymbol(s$, "+") Then If myVarType(D, vbString) Then logicalSelect = False Mid$(s$, 1, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True b$ = b$ + S2$ GoTo conthere ElseIf IsNumber(basestack, s$, D, True) Then logicalSelect = True If CheckInt64(D) Then S2$ = CStr(D) ElseIf MemInt(VarPtr(D)) = vbBoolean Then If ShowBooleanAsString Then S2$ = format$(D, DefBooleanString) Else S2$ = CStr(D * 1) End If Else S2$ = fixthis(D) End If b$ = b$ + S2$ GoTo conthere Else MissStringExpr End If End If ElseIf MaybeIsSymbol(s$, "-") Then If myVarType(D, vbEmpty) Then D = vbNullString SwapString2Variant b$, D logicalSelect = True Exit Function End If End If Else If FastSymbol(s$, "=") Then logicalSelect = False If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) = 0 Else MissStringExpr End If Exit Function ElseIf FastSymbol(s$, "<") Then logicalSelect = False If Left$(s$, 1) = "=" Then Mid$(s$, 1, 1) = " " If Left$(s$, 2) = " >" Then Mid$(s$, 2, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) Else MissStringExpr End If ElseIf IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) < 1 Else MissStringExpr End If ElseIf Left$(s$, 1) = ">" Then Mid$(s$, 1, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) <> 0 Else MissStringExpr End If ElseIf IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) = -1 Else MissStringExpr End If Exit Function ElseIf FastSymbol(s$, ">") Then logicalSelect = False If Left$(s$, 1) = "=" Then Mid$(s$, 1, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) > -1 Else MissStringExpr End If ElseIf IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = CompareStr2(b$, S2$) = 1 Else MissStringExpr End If Exit Function ElseIf FastSymbol(s$, "~") Then logicalSelect = False If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True D = b$ Like S2$ Else MissStringExpr End If Exit Function ElseIf MaybeIsSymbol(s$, "+") Then If myVarType(D, vbString) Then logicalSelect = False Mid$(s$, 1, 1) = " " If IsStrExp(basestack, s$, S2$, False) Then logicalSelect = True b$ = b$ + S2$ GoTo conthere End If End If ElseIf MaybeIsSymbol(s$, "-") Then If myVarType(D, vbEmpty) Then D = vbNullString SwapString2Variant b$, D logicalSelect = True Exit Function End If End If End If If LastErNum = -2 Then logicalSelect = True Else GoTo cont145 End If Exit Function Else cont145: If IsNumber(basestack, s$, D, flatobject, sg) Then If myVarType(D, vbString) Then If nostring Then jumpnostr1: MyEr "no string allowed", "δεν επιτρέπεται αλφαριθμητικό" logicalSelect = False Exit Function End If SwapString2Variant b$, D GoTo conthere ElseIf Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is mHandler Then Set usehandler = basestack.lastobj If usehandler.t1 = 4 Then If myVarType(usehandler.index_cursor, vbString) Then If nostring Then GoTo jumpnostr1 b$ = usehandler.index_cursor Set basestack.lastobj = Nothing GoTo conthere End If End If End If End If 'If SG < 0 Then D = -D logicalSelect = True End If End If End Function Function BlockParam(s$) As String ' need to be open Dim i As Long, j As Long j = 1 For i = 1 To Len(s$) Select Case AscW(Mid$(s$, i, 1)) Case 0 Exit For Case 34 i = InStr(i + 1, s$, Chr(34)) If i = 0 Then Exit Function Case 40 j = j + 1 Case 41 j = j - 1 If j = 0 Then Exit For Case 123 i = InStr(i + 1, s$, Chr$(125)) If i = 0 Then Exit Function End Select Next i If j = 0 Then BlockParam = Left$(s$, i - 1) End If End Function Function BlockParamSq(s$) As String ' need to be open Dim i As Long, j As Long, k As Long k = 1 For i = 1 To Len(s$) Select Case AscW(Mid$(s$, i, 1)) Case 91 k = k + 1 Case 93 k = k - 1 If j = 0 And k = 0 Then BlockParamSq = Left$(s$, i - 1) Exit For End If Case 0, 13, 10 Exit For Case 34 i = InStr(i + 1, s$, Chr(34)) If i = 0 Then Exit Function Case 40 j = j + 1 Case 41 j = j - 1 If j < 0 Then Exit For Case 123 i = InStr(i + 1, s$, Chr$(125)) If i = 0 Then Exit Function End Select Next i End Function Function block(s$) As String Dim i As Long, j As Long, c As Long Dim a1 As Boolean Dim jump As Boolean If Trim$(s$) = vbNullString Then Exit Function c = Len(s$) a1 = True i = 1 Do Select Case AscW(Mid$(s$, i, 1)) Case 32 ' nothing Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 47 If Mid$(s$, i + 1, 1) = "/" Then i = i + 1: GoTo a1111 Case 39, 92 a1111: Do While i < c i = i + 1 If Mid$(s$, i, 2) = vbCrLf Then Exit Do Loop Case 61 jump = True Case 123 If jump Then jump = False ' we have a multiline text Dim target As Long target = j Do Select Case AscW(Mid$(s$, i, 1)) Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 123 j = j - 1 Case 125 j = j + 1: If j = target Then Exit Do End Select i = i + 1 Loop Until i > c If j <> target Then Exit Do Else j = j - 1 End If Case 125 j = j + 1: If j = 1 Then Exit Do Case Else jump = False End Select i = i + 1 Loop Until i > c If j = 1 Then block = Left$(s$, i - 1) s$ = Mid$(s$, i) Else block = vbNullString End If End Function Function blockLen(s$) As Long Dim i As Long, j As Long, c As Long Dim a1 As Boolean Dim jump As Boolean If Trim$(s$) = vbNullString Then Exit Function c = Len(s$) a1 = True i = 1 Do Select Case AscW(Mid$(s$, i, 1)) Case 32 ' nothing Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 47 If Mid$(s$, i + 1, 1) = "/" Then i = i + 1: GoTo a1111 Case 39, 92 a1111: Do While i < c i = i + 1 If Mid$(s$, i, 2) = vbCrLf Then Exit Do Loop Case 61 jump = True Case 123 If jump Then jump = False ' we have a multiline text Dim target As Long target = j Do Select Case AscW(Mid$(s$, i, 1)) Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 123 j = j - 1 Case 125 j = j + 1: If j = target Then Exit Do End Select i = i + 1 Loop Until i > c If j <> target Then Exit Do Else j = j - 1 End If Case 125 j = j + 1: If j = 1 Then Exit Do Case Else jump = False End Select i = i + 1 Loop Until i > c If j = 1 Then blockLen = i Else blockLen = 0 End If End Function Function blockLen2(s$, Pos) As Long Dim i As Long, j As Long, c As Long Dim a1 As Boolean Dim jump As Boolean If Trim$(s$) = vbNullString Then Exit Function c = Len(s$) a1 = True i = Pos Do Select Case AscW(Mid$(s$, i, 1)) Case 32 ' nothing Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 47 If Mid$(s$, i + 1, 1) = "/" Then i = i + 1: GoTo a1111 Case 39, 92 a1111: Do While i < c i = i + 1 If Mid$(s$, i, 2) = vbCrLf Then Exit Do Loop Case 61 jump = True Case 123 If jump Then jump = False Dim target As Long target = j Do Select Case AscW(Mid$(s$, i, 1)) Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 123 j = j - 1 Case 125 j = j + 1: If j = target Then Exit Do End Select i = i + 1 Loop Until i > c If j <> target Then Exit Do Else j = j - 1 End If Case 125 j = j + 1: If j = 1 Then Exit Do Case Else jump = False End Select i = i + 1 Loop Until i > c If j = 1 Then blockLen2 = i Else blockLen2 = 0 End If End Function Function BlockParam2OLD(s$, Pos As Long) As Boolean ' need to be open Dim i As Long, j As Long, j1 As Long, ii As Long j = 1 For i = Pos To Len(s$) Select Case AscW(Mid$(s$, i, 1)) Case 0 Exit For Case 34 again: ii = InStr(i + 1, s$, """") If ii = 0 Then Exit Function i = ii 'If Mid$(s$, ii - 1, 1) = "`" Then GoTo again Case 91 j1 = j1 + 1 Case 93 j1 = j1 - 1 'If j1 = 0 Then Exit For Case 40 j = j + 1 Case 41 j = j - 1 If j = 0 Then Exit For Case 123 i = i + 1 If blockStringPOS(s$, i) Then Else i = 0 End If If i = 0 Then Exit Function End Select Next i If j = 0 And j1 = 0 Then Pos = i: BlockParam2OLD = True End Function Function BlockParam2p(s$, Pos As Long) As Boolean ' need to be open Dim i As Long, ii As Long, j As Long, j1 As Long j = 1 For i = Pos To Len(s$) Select Case AscW(Mid$(s$, i, 1)) Case 0 Exit For Case 34 again: ii = InStr(i + 1, s$, """") If ii = 0 Then Exit Function i = ii 'If Mid$(s$, ii - 1, 1) = "`" Then GoTo again Case 91 j1 = j1 + 1 Case 93 j1 = j1 - 1 If j1 < 0 Then Exit For Case 40 j = j + 1 Case 41 j = j - 1 If j = 0 Then Exit For Case 123 i = i + 1 If blockStringPOS(s$, i) Then Else i = 0 End If If i = 0 Then Exit Function End Select Next i If j = 0 And j1 = 0 Then Pos = i: BlockParam2p = True End Function Function BlockParam2s(s$, Pos As Long) As Boolean ' need to be open Dim i As Long, ii As Long, j As Long, j1 As Long, exit1 As Boolean j1 = 1 For i = Pos To Len(s$) Select Case AscW(Mid$(s$, i, 1)) Case 0 Exit For Case 34 again: ii = InStr(i + 1, s$, """") If ii = 0 Then Exit Function i = ii 'If Mid$(s$, ii - 1, 1) = "`" Then GoTo again Case 91 j1 = j1 + 1 Case 93 j1 = j1 - 1 If j1 <= 0 Then Exit For Case 40 j = j + 1 Case 41 j = j - 1 If j < 0 Then Exit For Case 123 i = i + 1 If blockStringPOS(s$, i) Then Else i = 0 End If If i = 0 Then Exit Function End Select Next i If j = 0 And j1 = 0 Then Pos = i: BlockParam2s = True End Function Function blockStringPOS(s$, Pos As Long) As Boolean Dim i As Long, j As Long, c As Long Dim a1 As Boolean c = Len(s$) a1 = True i = Pos If i > Len(s$) Then Exit Function Do Select Case AscW(Mid$(s$, i, 1)) Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 123 j = j - 1 Case 125 j = j + 1: If j = 1 Then Exit Do End Select i = i + 1 Loop Until i > c If j = 1 Then blockStringPOS = True Pos = i Else Pos = Len(s$) End If End Function Function block2(s$) As String Dim i As Long, j As Long, c As Long Dim a1 As Boolean Dim jump As Boolean Dim alter As Boolean If Trim$(s$) = vbNullString Then Exit Function c = Len(s$) a1 = True i = 1 Do Select Case AscW(Mid$(s$, i, 1)) Case 32 ' nothing Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 47 If Mid$(s$, i + 1, 1) = "/" Then i = i + 1: GoTo a1111 Case 39, 92 a1111: Do While i < c i = i + 1 If Mid$(s$, i, 2) = vbCrLf Then Exit Do Loop Case 61 jump = True Case 123 If jump Then jump = False ' we have a multiline text Dim target As Long target = j Do Select Case AscW(Mid$(s$, i, 1)) Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 123 j = j - 1 Case 125 j = j + 1: If j = target Then Exit Do End Select i = i + 1 Loop Until i > c If j <> target Then Exit Do Else j = j - 1 End If Case 125 j = j + 1: If j = 1 Then Exit Do Case Else jump = False End Select i = i + 1 Loop Until i > c If j = 1 Then block2 = Left$(s$, i - 1) s$ = Mid$(s$, i) 'DoEvents Else block2 = vbNullString End If End Function Function blockString(s$, endstr As Long, Optional i As Long = 1) As String ' endstr 34 or 125 Dim j As Long, c As Long, start As Long start = i Dim a1 As Boolean c = Len(s$) If i > c Then Exit Function If c < 1 Then Exit Function a1 = True Do Select Case AscW(Mid$(s$, i, 1)) Case 13 If endstr = 34 Then blockString = vbNullString: Exit Function Case 34 If endstr = 34 Then If i = 1 Then i = 2 j = 1: Exit Do Else Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop End If Case 123 j = j - 1 Case 125 j = j + 1: If j = 1 And endstr = 125 Then Exit Do End Select i = i + 1 Loop Until i > c If j = 1 Then blockString = Mid$(s$, start, i - start) s$ = Mid$(s$, i) Else s$ = Mid$(s$, i) blockString = "Error " + Chr(34) + "missing " + Chr$(endstr) + Chr(34) End If If endstr = 125 Then If Right$(blockString, 1) = " " Then i = Len(blockString) - MyTrimRStr(blockString) If i > 0 Then blockString = Replace$(blockString, Chr$(10) + space(i), Chr$(10)) ElseIf MyTrimRStr(Right$(blockString, 1)) = 1 Then i = Len(blockString) - MyTrimRNoCr(blockString) If i > 0 Then blockString = Replace$(blockString, Chr$(10) + Right$(blockString, i), Chr$(10)) End If End If End Function Public Function MyTrimRStr(s$) As Long Dim i&, l As Long Dim P2 As Long, P1 As Integer, p4 As Long l = Len(s): If l = 0 Then MyTrimRStr = 1: Exit Function P2 = StrPtr(s): l = l - 1 p4 = P2 + l * 2 For i = p4 To P2 Step -2 GetMem2 i, P1 Select Case P1 Case 32 Case Else MyTrimRStr = (i - P2) \ 2 + 1 Exit Function End Select Next i MyTrimRStr = l + 2 End Function Public Function MyTrimRNoCr(s$) As Long Dim i&, l As Long Dim P2 As Long, P1 As Integer, p4 As Long l = Len(s): If l = 0 Then MyTrimRNoCr = 1: Exit Function P2 = StrPtr(s): l = l - 1 p4 = P2 + l * 2 For i = p4 To P2 Step -2 GetMem2 i, P1 Select Case P1 Case 32, 160, 9 Case Else MyTrimRNoCr = (i - P2) \ 2 + 1 Exit Function End Select Next i MyTrimRNoCr = l + 2 End Function Sub SetNextLine(c$) Dim i i = InStr(c$, vbCrLf) If i = 0 Then c$ = vbNullString Else c$ = Mid$(c$, i + 2) End Sub Function SetNextLineCLR(c$) As Long SetNextLineCLR = InStr(c$, vbCrLf) If SetNextLineCLR > 0 Then Mid$(c$, 1, SetNextLineCLR + 1) = space(SetNextLineCLR + 1): SetNextLineCLR = SetNextLineCLR + 1 End Function Function CopyUntilEndOfLine(a$) As String Dim i As Long i = InStr(a$, vbCrLf) If i = 0 Then CopyUntilEndOfLine = a$ Else CopyUntilEndOfLine = Left$(a$, i - 1) End Function Sub SetNextLineNL(c$) Dim i i = InStr(c$, vbCrLf) If i = 0 Then c$ = vbNullString Else c$ = Mid$(c$, i) End Sub Function GetNextLine(c$) As String Dim i, j$ i = InStr(c$, vbCrLf) If i = 0 Then GetNextLine = NLtrim$(c$): c$ = vbNullString Else GetNextLine$ = NLtrim$(Left$(c$, i - 1)): c$ = Mid$(c$, i) End Function Sub NoLines(c$) Dim i c$ = Trim$(c$) Do While Left$(c$, 2) = vbCrLf c$ = Trim$(Mid$(c$, 3)) Loop End Sub Sub RTarget(DDD As Object, tar As target) ' RENDER TARGET Dim xl&, yl&, b As Long, f As Long, Tag$, id& Dim X&, Y&, ox&, oy& Dim prive As basket, D As Object Dim c2&, V1&, V2&, vert&, mem As MemBlock Dim zoom As Single Set D = DDD.Owner prive = players(GetCode(D)) With tar id& = .id Tag$ = .Tag X& = .Lx Y& = .lY xl& = .tx + 1 yl& = .ty b = .back f = .fore c2& = .barC V1& = .topval V2& = .botval vert& = .Vertical prive.mypen = .pen zoom = .imagesize / 100 Dim half As Long half = 1 - (.ty - .lY + 1) Mod 2 Dim dd As Object If .layer = 0 Then Set dd = Form1.DIS ElseIf .layer = -1 Then Set dd = Form1 ElseIf .layer > 0 And .layer < 33 Then Set dd = Form1.dSprite(.layer) Else Set dd = D End If prive.Xt = .Xt prive.Yt = .Yt prive.uMineLineSpace = .sUAddTwipsTop prive.mX = 100 prive.mY = 100 prive.SZ = .SZ Set mem = .drawimage End With dd.FontSize = prive.SZ LCTbasket dd, prive, Y&, X& If f <> &H81000000 Then BoxBigNew dd, prive, xl& - 1, yl&, f If b <> &H81000000 Then BoxColorNew dd, prive, xl& - 1, yl&, b If Not mem Is Nothing Then If mem.SubType > 0 Then Dim upleft As Long, Up As Long, downright As Long, down As Long Dim fx&, fy& If zoom < 0 Then If c2& <> &H81000000 Then If vert& = 0 Then BoxColorNewBarHor D, prive, xl& - 1, yl&, c2&, V2&, V1& Else BoxColorNewBarVer D, prive, xl& - 1, yl&, c2&, V2&, V1& End If End If c2& = &H81000000 zoom = -zoom End If upleft = (prive.curPos * prive.Xt) \ dv15 downright = (xl& * prive.Xt) \ dv15 Up = (prive.currow * prive.Yt) \ dv15 down = ((yl& + 1) * prive.Yt) \ dv15 fx& = (xl& - prive.curPos) * prive.Xt \ dv15 fy& = (yl& - prive.currow + 1) * prive.Yt \ dv15 If zoom = 0 Then ' expand to target width mem.DrawImageToHdc dd, upleft, Up, fx&, fy& Else Select Case id Mod 10 Case 4, 1, 7 If fx& < fy& Then mem.DrawImageToHdc dd, upleft + (fx& - fx& * zoom) \ 2, down - fx& * zoom, fx& * zoom, fx& * zoom Else mem.DrawImageToHdc dd, downright - fy& * zoom - (fy& - fy& * zoom) \ 2, Up + (fy& - fy& * zoom) \ 2, fy& * zoom, fy& * zoom End If Case 6, 3, 9 If fx& < fy& Then mem.DrawImageToHdc dd, upleft + (fx& - fx& * zoom) \ 2, Up + (fx& - fx& * zoom) \ 2, fx& * zoom, fx& * zoom Else mem.DrawImageToHdc dd, upleft + (fy& - fy& * zoom) \ 2, Up + (fy& - fy& * zoom) \ 2, fy& * zoom, fy& * zoom End If Case 8 If fx& < fy& Then mem.DrawImageToHdc dd, upleft + (fx& - fx& * zoom) \ 2, Up + prive.uMineLineSpace \ dv15, fx& * zoom, fx& * zoom Else mem.DrawImageToHdc dd, upleft + (fx& - fy&) \ 2 + (fy& - fy& * zoom) \ 2, Up + (fy& - fy& * zoom) \ 2, fy& * zoom, fy& * zoom End If Case 5 If fx& < fy& Then mem.DrawImageToHdc dd, upleft + (fx& - fx& * zoom) \ 2, Up + (fy& - fx&) \ 2 + (fx& - fx& * zoom) \ 2, fx& * zoom, fx& * zoom Else mem.DrawImageToHdc dd, upleft + (fx& - fy&) \ 2 + (fy& - fy& * zoom) \ 2, Up + (fy& - fy& * zoom) \ 2, fy& * zoom, fy& * zoom End If Case 2 If fx& < fy& Then mem.DrawImageToHdc dd, upleft + (fx& - fx& * zoom) \ 2, down - fx& * zoom - prive.uMineLineSpace \ dv15, fx& * zoom, fx& * zoom Else mem.DrawImageToHdc dd, upleft + (fx& - fy&) \ 2 + (fy& - fy& * zoom) \ 2, Up + (fy& - fy& * zoom) \ 2, fy& * zoom, fy& * zoom End If End Select End If End If End If If c2& <> &H81000000 Then If vert& = 0 Then BoxColorNewBarHor D, prive, xl& - 1, yl&, c2&, V2&, V1& Else BoxColorNewBarVer D, prive, xl& - 1, yl&, c2&, V2&, V1& End If End If If id& < 100 Then half = 0 Tag$ = Left$(Tag$, xl& - X&) If Tag$ <> "" Then '1 Select Case id& Mod 10 Case 4, 5, 6 Y& = (yl& + Y&) \ 2 Case 7, 8, 9 Y& = yl& Case Else End Select Select Case id& Mod 10 Case 2, 5, 8 X& = (xl& + X& - Len(Tag$)) \ 2 Case 3, 6, 9 X& = xl& - Len(Tag$) Case Else End Select If (id& Mod 10) > 0 Then LCTbasket dd, prive, Y&, X& dd.FontTransparent = True dd.ForeColor = mycolor(prive.mypen) PlainBaSket dd, prive, Tag$, True, True End If End If Else If Tag$ <> "" Then id& = id& Mod 100 Select Case id& Mod 10 Case 4, 5, 6 Y& = (yl& + Y&) \ 2 Case 7, 8, 9 half = 0 Y& = yl& Case Else half = 0 End Select f = 3 Select Case id& Mod 10 Case 2, 5, 8 f = 2 Case 3, 6, 9 f = 1 Case Else End Select If (id& Mod 10) > 0 Then LCTbasket dd, prive, Y&, X& dd.FontTransparent = True dd.currentX = dd.currentX - dv15 * 2 If half = 1 Then dd.currentY = dd.currentY + prive.Yt \ 2 '+ mybasket.uMineLineSpace \ 2 End If dd.ForeColor = mycolor(prive.mypen) If Not D Is dd Then Set DDD.Owner = dd wwPlain2 DDD, prive, Tag$, xl& - X&, 10000, , True, f, , , True Set DDD.Owner = D Else wwPlain2 DDD, prive, Tag$, xl& - X&, 10000, , True, f, , , True End If End If End If End If PlaceBasket dd, players(GetCode(dd)) End Sub Public Sub DropLeft(ByVal uStr As String, fromstr As String) Dim i As Long i = InStr(fromstr, uStr) If i > 0 Then fromstr = Mid$(fromstr, i + Len(uStr)) Else fromstr = vbNullString End If End Sub Public Function GetStrUntil(ByVal sStr As String, fromstr As String, Optional RemoveSstr As Boolean = True) As String Dim i As Long If fromstr = vbNullString Then GetStrUntil = vbNullString: Exit Function i = InStr(fromstr, sStr) If i < 2 Then GetStrUntil = vbNullString fromstr = vbNullString Else GetStrUntil = Left$(fromstr, i - 1) If RemoveSstr Then fromstr = Mid$(fromstr, Len(sStr) + i) Else fromstr = Mid$(fromstr, i) End If End If End Function Function NeoGetArrayItem(pp As iBoxArray, bstack As basetask, v$, Offset As Long, rst$, Optional noObject As Boolean = False, Optional closepar As Boolean = True, Optional fromstr As Boolean, Optional rightexpr As Boolean = False, Optional idx As mIndexes) As Boolean If pp Is Nothing Then MyEr "Internal Error: NeoGetArrayItem", "εσωτερικό λάθος: NeoGetArrayItem": Exit Function End If If noObject And pp.IhaveClass Then Exit Function Dim dn As Long, dd As Long, w3 As Long, sp$, lim As Long, usehandler As mHandler, usehandler1 As mHandler Dim p As Variant, pppp As mArray, mylist As FastCollection, myobject As Object If Len(v$) > 0 Then sp$ = ")" again123: dd = 0 dn = 0 If Not pp.arr Then Dim ppp$ If TypeOf pp.GroupRef Is mHandler Then Set usehandler = pp.GroupRef If usehandler.t1 <> 1 Then Expected "Inventory", "Κατάσταση": Exit Function If TypeOf usehandler.objref Is mHandler Then Set usehandler1 = usehandler.objref Set usehandler.objref = usehandler1.objref End If Set mylist = usehandler.objref If IsExp(bstack, rst$, p) Then With mylist If Not FastSymbol(rst$, "!") Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then p = bstack.lastobj.AnyBaseOuput(10) End If Set bstack.lastobj = Nothing End If If Not .Find(p) Then If Not rightexpr Then MyEr "Key not exist", "Δεν υπαρχει το κλειδί" NeoGetArrayItem = False Exit Function Else .AddKey p Offset = -.index - 100 End If Else Offset = -.index - 100 End If Else Set bstack.lastobj = Nothing p = MyRound(p) If Abs(p) < .Count Then If p < 0 Then .index = .Count + Int(p) Else .index = Int(p) End If .index = p Offset = -.index - 100 .Done = True Else MyEr "Index out of limits", "Δείκτης εκτός ορίων" End If End If If Typename(.ValueObj) = mGroup Then If .ValueObj.HasParametersSet Or .ValueObj.HasParameters Then NeoGetArrayItem = True End If ElseIf FastSymbol(rst, ")(", , 2) Then GoTo CheckThis Else .Done = True End If End With ElseIf IsStrExp(bstack, rst$, ppp$) Then contlabel1: With mylist If Not .Find(ppp$) Then If Not rightexpr Then MyEr "Key not exist", "Δεν υπαρχει το κλειδί" NeoGetArrayItem = False Exit Function Else .AddKey ppp$ Offset = -.index - 100 End If Else Offset = -.index - 100 End If If Typename(.ValueObj) = mGroup Then If .ValueObj.HasParametersSet Or .ValueObj.HasParameters Then NeoGetArrayItem = True End If ElseIf FastSymbol(rst, ")(", , 2) Then GoTo CheckThis Else .Done = True End If End With End If ElseIf TypeOf pp.GroupRef Is Group Then If Not fromstr Then If rightexpr Then ElseIf pp.GroupRef.HasParameters Then If Not pp.GroupRef.HasStrValue Then If Len(rst$) > 0 Then bstack.tmpstr = v$ + Left$(rst$, 1) ppp$ = Left$(rst$, 1) 'BackPort rst$ If Len(rst$) = 0 Then rst$ = Chr(8) Else Mid$(rst$, 1, 1) = Chr(8) If IsNumberNew(bstack, rst$, p, False) Then If Not bstack.lastpointer Is Nothing Then If bstack.lastpointer.IamApointer Then Set pp.GroupRef = bstack.lastpointer Else Set pp.GroupRef = bstack.lastobj End If ElseIf Not bstack.lastobj Is Nothing Then If TypeOf pp.GroupRef Is Group Then Set pp.GroupRef = bstack.lastobj End If End If Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing Else If Len(rst$) > 0 Then Mid$(rst$, 1, 1) = ppp$ End If End If End If End If End If Offset = -2 NeoGetArrayItem = True Exit Function Else contprop: Dim aProp As PropReference Set aProp = pp.GroupRef dn = 0 If idx Is Nothing Then Set idx = New mIndexes againprop: If IsExp(bstack, rst$, p) Then idx(dn) = p aProp.index = p ElseIf IsStrExp(bstack, rst$, ppp$) Then idx(dn) = ppp$ aProp.index = ppp$ Else idx.IndexOpt dn aProp.IndexOpt End If If FastSymbol(rst$, ",") Then dn = dn + 1: GoTo againprop If FastSymbol(rst$, ")=>", , 3) Then closepar = False If IsLabelObj(rst$, v$) Then aProp.PushIndexes idx Set idx = Nothing Set myobject = aProp.ValueObj Set aProp = New PropReference dd = FindDISPID(myobject, v$) If FastSymbol(rst$, ".") Then Set myobject = ReadPropIndexObjObj(myobject, dd, idx, True) Else aProp.ConstructObj myobject, dd, True Set pp.GroupRef = aProp End If End If End If Set aProp = Nothing End If conthere: If closepar Then If Not FastSymbol(rst$, ")") Then MyEr "missing )", "λείπει )": Exit Function NeoGetArrayItem = True Else If TypeOf pp Is tuple Then If IsExp(bstack, rst$, p, flatobject:=True, nostring:=True) Then If Not FastSymbol(rst$, ")") Then MyEr "missing )", "λείπει )": Exit Function If p >= pp.Count Then GoTo toohigh ElseIf p < 0 Then GoTo toolow Else Offset = p NeoGetArrayItem = True End If End If Else Set pppp = pp If pppp.SerialItem((0), dd, 5) Then dd = dd - 1 Offset = 0 If dd < 0 Then If VarTypeName(pppp.GroupRef) = mProp Then GoTo contprop Do While dn <= dd pppp.GetDnum dn, w3, lim If IsExp(bstack, rst$, p, flatobject:=True, nostring:=True) Then If dn < dd Then If Not FastSymbol(rst$, ",") Then MyEr "need index for " + v$ + sp$, "χρειάζομαι δείκτη για το πίνακα " + v$ + sp$: Exit Function Else If FastSymbol(rst$, ",") Then MyEr "too many indexes for array " + v$ + sp$, "πολλοί δείκτες για το πίνακα " + v$ + sp$: Exit Function If Not FastSymbol(rst$, ")") Then MyEr "missing )", "λείπει )": Exit Function End If On Error Resume Next If p < -lim Then toolow: MyEr "index too low for array " + v$ + sp$, "χαμηλός δείκτης στο πίνακα " + v$ + sp$: Exit Function End If If pppp.PushOffset(Offset, dn, CLng(p)) Then NeoGetArrayItem = True Else toohigh: MyEr "index too high for array " + v$ + sp$, "δείκτης υψηλός για το πίνακα " + v$ + sp$: Exit Function End If Else If Not LastErNum = -2 Then MyEr "missing index for array " + v$ + sp$, "χάθηκε δείκτης για το πίνακα " + v$ + sp$ End If Exit Function End If dn = dn + 1 Loop End If End If End If If lookOne(rst, "(") Then CheckThis: ppp$ = VarTypeName(pp.item(Offset)) If ppp$ = myArray Then FastSymbol rst$, "(" Set pp = pp.item(Offset) NeoGetArrayItem = False GoTo again123 ElseIf ppp$ = "ppppLight" Then FastSymbol rst$, "(" Set pp = pp.item(Offset) NeoGetArrayItem = False GoTo again123 ElseIf ppp$ = mHdlr Then FastSymbol rst$, "(" Set usehandler = pp.item(Offset) If usehandler.t1 = 3 Then Set pp = usehandler.objref Set usehandler = Nothing Else Set pp = New ppppLight pp.arr = False Set pp.GroupRef = usehandler End If p = vbEmpty NeoGetArrayItem = pp.arr GoTo again123 ElseIf VarTypeName(pp.item(Offset)) = mGroup Then NeoGetArrayItem = True End If End If End Function Public Sub MusicMasterTick() ' This is the TimerFunction that will be ' called when SetTimer times out. musicstamp = MemLong(VarPtr(basictimer)) MusicMaster.TimerTick End Sub Public Sub TaskMasterTick() ' This is the TimerFunction that will be ' called when SetTimer times out. Static once As Boolean If once Then Exit Sub If Not TaskMaster Is Nothing Then Call GetSystemTimeAsFileTime(basictimer) If Abs(MasterTimer - basictimer > 0.025@) Then If Not extreme Then MusicMaster.tickdrop = 1 once = True DoEvents once = False MusicMaster.tickdrop = 0 End If Call GetSystemTimeAsFileTime(basictimer) MasterTimer = basictimer End If ' Form1.Caption = MasterTimer On Error Resume Next TaskMaster.TimerTick End If End Sub Public Function VALIDATEmStiva(bs As basetask, p$, s$) As Boolean Dim st As mStiva, ss$, sw$, j As Long, anything As Object, usehandler As mHandler Set st = bs.soros Dim i As Long, r$ If p$ <> "" Then ''s$ = VbNullString If st.Total < Len(p$) Then Exit Function Do While i < Len(p$) i = i + 1 j = AscW(st.StackItemType(i)) If j <> 62 Then Select Case AscW(Mid$(p$, i, 1)) Case 62 ' OPTIONAL IS OK ?? Case 66, 98, 916, 948 If j <> 42 Then Exit Function If VarTypeName$(st.StackItem(i)) = mHdlr Then If st.StackItem(i).t1 <> 2 Then Exit Function Else Exit Function End If Case 73, 105, 922, 954 If j <> 42 Then Exit Function If VarTypeName$(st.StackItem(i)) = mHdlr Then Set usehandler = st.StackItem(i) If usehandler.t1 = 3 Then Set anything = usehandler.objref If CheckDeepAny(anything) Then If VarTypeName$(anything) = "FastCollection" Then If anything.structLen <> 0 Then Exit Function Else Exit Function End If Else Exit Function End If ElseIf usehandler.t1 <> 1 Then Exit Function End If Else Exit Function End If Set usehandler = Nothing Case 67, 99, 931, 963 If j <> 42 Then Exit Function If VarTypeName$(st.StackItem(i)) = mHdlr Then Set usehandler = st.StackItem(i) If usehandler.t1 = 3 Then Set anything = usehandler.objref If CheckDeepAny(anything) Then If VarTypeName$(anything) = "mStiva" Then Else Exit Function End If Else Exit Function End If Else Exit Function End If Else Exit Function End If Set usehandler = Nothing Case 925, 957, 913, 945, 78, 110 '' number - use spellunicode to make it If j = 42 Then If VarTypeName(st.StackItem(i)) = mHdlr Then Set usehandler = st.StackItem(i) If usehandler.t1 <> 4 Then Exit Function Set usehandler = Nothing ElseIf VarTypeName(st.StackItem(i)) = "BigInteger" Then Else Exit Function End If ElseIf j <> 78 Then Exit Function End If Case 923, 955, 70, 102 ' change from L l to F f form lambda If j = 42 Then j = AscW(Mid$(Typename(st.StackItem(i)), 1)) If j <> 108 Then Exit Function Case 915, 947, 83, 115 '' string If j <> 83 Then Exit Function Case 928, 960, 65, 97 '' array If j = 42 Then j = AscW(Mid$(Typename(st.StackItem(i)), 2)) If j <> 65 Then If IsmHandler(st.StackItem(i)) Then Set usehandler = st.StackItem(i) If usehandler.t1 = 3 Then Set anything = usehandler.objref If CheckDeepAny(anything) Then If IsobjArray(anything) Then Else Exit Function End If Else Exit Function End If Else Exit Function End If Set usehandler = Nothing ElseIf IsobjAndArray(st.StackItem(i)) Then Else Exit Function End If End If Case 917, 69 If j = 42 Then j = AscW(Mid$(Typename(st.StackItem(i)), 2)) If j <> 69 Then Exit Function Case 927, 959, 954, 71, 103, 67, 99 If j = 42 Then j = AscW(Mid$(Typename(st.StackItem(i)), 1)) If j <> 71 Then Exit Function Case 76, 924 If j <> 76 Then Exit Function Case Else Exit Function End Select End If Loop s$ = " " VALIDATEmStiva = True Exit Function Else Do i = i + 1 If st.Total < i Then Exit Do ss$ = st.StackItemType(i) If ss$ = "*" Then sw$ = Typename(st.StackItem(i)) checkagain: If sw$ = "mArray" Or sw$ = "tuple" Then ss$ = "A" If sw$ = "mEvent" Then ss$ = "E" If sw$ = "Group" Then ss$ = "G" If sw$ = "lambda" Then ss$ = "F" If sw$ = "mStiva" Then ss$ = "C" If sw$ = "BigInteger" Then ss$ = "N" If sw$ = "mHandler" Then Set usehandler = st.StackItem(i) ch2: Select Case usehandler.t1 Case 1 ss$ = "I" Case 2 ss$ = "B" Case 3 Set anything = usehandler.objref If CheckDeepAny(anything) Then sw$ = Typename(anything) If sw$ = "mHandler" Then Set usehandler = anything: GoTo ch2 Set usehandler = Nothing GoTo checkagain End If Set usehandler = Nothing ss$ = "U" ' "Undefined" Case 4 ss$ = "N" Case Else ss$ = "U" ' "Undefined" End Select End If End If r$ = r$ + Right$("?" + ss$, 1) Loop s$ = r$ End If VALIDATEmStiva = r$ <> "" End Function Public Function VALIDATE(st$, p$, s$) As Boolean Dim dummy As Double Dim i As Long, j As Long, ok As Boolean If Len(st$) = 0 Then VALIDATE = True End If ' NORMALIZE s$ = vbNullString ok = True i = 1 Do While i <= Len(st$) Select Case Mid$(st$, i, 1) Case " ", ",", ChrW(160) Case Is = Chr(34) j = InStr(i + 1, st$, Chr(34), vbBinaryCompare) If j = 0 Then Exit Do s$ = s$ + "S" i = j + 1 If p$ <> "" Then Select Case AscW(p$) Case 915, 947, 83, 115 '' string Case Else ok = False: Exit Do End Select p$ = Mid$(p$, 2) If p$ = vbNullString Then Exit Do End If Case Is = Chr$(2) If Len(Mid$(st$, i + 1, 8)) = 8 Then i = i + CLng("&H" + Mid$(st$, i + 1, 8)) + 8 s$ = s$ + "S" If p$ <> "" Then Select Case AscW(p$) Case 915, 947, 83, 115 '' string Case Else ok = False: Exit Do End Select p$ = Mid$(p$, 2) If p$ = vbNullString Then Exit Do End If Else Exit Do End If Case Else If IsNumberD3(st$, i, j) Then If j = 1 Then Exit Do i = i + (j - 1) - 1 If i < 1 Then i = 0 s$ = s$ + "N" If p$ <> "" Then Select Case AscW(p$) Case 925, 957, 913, 945, 78, 110 '' number Case Else ok = False: Exit Do End Select p$ = Mid$(p$, 2) If p$ = vbNullString Then Exit Do End If Else Exit Do End If End Select i = i + 1 Loop ' TO P$ ΘΑ ΠΑΡΕΙ ΤΟ ΥΠΟΛΟΙΠΟ p$ = Mid$(st$, i + 1) st$ = Left$(st$, i) VALIDATE = ok End Function Public Function VALIDATEpart(st$, p$) As Boolean Dim dummy As Double Dim i As Long, j As Long, ok As Boolean, s$ If Len(st$) = 0 Then VALIDATEpart = False ' reverse logic here... End If ' NORMALIZE s$ = vbNullString ok = True For i = 1 To Len(st$) If Mid$(st$, i, 1) = Chr$(2) Then If Len(Mid$(st$, i + 1, 8)) = 8 Then i = i + CLng("&H" + Mid$(st$, i + 1, 8)) + 8 Else Exit For End If ElseIf IsNumberD3(st$, i, j) Then i = j + i - 2 Else i = i - 1 Exit For End If Next i p$ = Left$(st$, i) st$ = " " + Mid$(st$, i + 1) VALIDATEpart = p$ <> "" End Function Private Function UnsignedSub(a As Long, b As Long) Static ua, UB If ua = Empty Then MemInt(VarPtr(ua)) = 20 MemInt(VarPtr(UB)) = 20 End If MemLong(VarPtr(ua) + 8) = a MemLong(VarPtr(UB) + 8) = b ua = ua - UB UnsignedSub = MemLong(VarPtr(ua) + 8) End Function Sub mywait(bstack As basetask, pp As Variant, Optional SLEEPSHORT As Boolean = False) Static ua, UB If ua = Empty Then MemInt(VarPtr(ua)) = 20 MemInt(VarPtr(UB)) = 20 End If Dim p As Boolean, e As Boolean On Error Resume Next If bstack Is Nothing Then If pp = 0 Then Exit Sub End If If bstack.Process Is Nothing Then Else Err.Clear p = bstack.Process.Done If Err.Number = 0 Then e = True If p <> 0 Then Exit Sub End If End If End If Dim dt As Long MemLong(VarPtr(UB) + 8) = timeGetTime If pp < 1 Then dt = 1 Else dt = CLng(pp) If TaskMaster Is Nothing Then Set TaskMaster = New TaskMaster Dim oldRR As Currency oldRR = RRCOUNTER Do If TaskMaster.Processing And Not bstack.TaskMain Then If Not bstack.toprinter Then bstack.Owner.Refresh TaskMaster.TimerTick MyDoEvents1 Form1 If SLEEPSHORT Then Sleep 1 MemLong(VarPtr(ua) + 8) = timeGetTime ua = ua - UB If MemLong(VarPtr(ua) + 8) >= dt Then Exit Do Else MemLong(VarPtr(ua) + 8) = timeGetTime ua = ua - UB If MemLong(VarPtr(ua) + 8) >= dt Then Exit Do MyDoEvents1 Form1 If SLEEPSHORT Then Sleep 3 ElseIf oldRR <> RRCOUNTER Then Sleep 1: oldRR = RRCOUNTER End If End If If e Then p = bstack.Process.Done If Err.Number = 0 Then If p <> 0 Then Exit Do End If End If End If Loop Until NOEXECUTION If exWnd <> 0 Then MyTitle$ bstack End Sub Sub ProcTask(bstack As basetask) Sleep 1 If IsWine Then DoEvents Else SleepWaitEdit2 10 End If End Sub Sub ProcTask2(bstack As basetask) On Error GoTo procbliah2 If bstack.IamThread And trace Then If MusicMaster.PlayMusic Then MusicMaster.TimerTick If SLOW Or IsWine Then Sleep 1 TaskMaster.rest If IsWine Then DoEvents Else SleepWaitEdit2 1 End If TaskMaster.RestEnd Exit Sub ElseIf TaskMaster Is Nothing Then If SLOW Or IsWine Then Sleep 1 End If DoEvents Else If TaskMaster.Processing Then TaskMaster.RestEnd1 TaskMaster.TimerTickNow ElseIf SLOW Or IsWine Then Sleep 1 End If TaskMaster.rest If IsWine Then DoEvents Else SleepWaitEdit2 1 End If TaskMaster.RestEnd End If Exit Sub procbliah2: DoEvents Sleep 1 End Sub Sub ResetBreak() Do While KeyPressedLong(&H13) <> 0 MyDoEvents Loop End Sub Private Sub MyDoEvents() On Error GoTo there If TaskMaster Is Nothing Then GoTo cont1 ElseIf Not TaskMaster.Processing And TaskMaster.QueueCount = 0 Then cont1: If MusicMaster.PlayMusic Then MusicMaster.StopProcess MusicMaster.TimerTick DoEvents MusicMaster.StartProcess Else DoEvents End If Exit Sub Else If MusicMaster.PlayMusic Then MusicMaster.StopProcess TaskMaster.StopProcess TaskMaster.TimerTick DoEvents TaskMaster.StartProcess MusicMaster.StartProcess Else TaskMaster.StopProcess TaskMaster.TimerTick DoEvents TaskMaster.StartProcess End If End If Exit Sub there: If Not TaskMaster Is Nothing Then TaskMaster.RestEnd1 End Sub Function myexit(bstack As basetask) As Boolean On Error Resume Next If extreme Then Else If escok Then If KeyPressed(&H1B) Then If Modalid <> 0 Then Modalid = 0 ShutEnabledGuiM2000 MyDoEvents While KeyPressed(&H1B) MyDoEvents Wend Else NOEXECUTION = True ShutEnabledGuiM2000 True MyDoEvents If AVIRUN Then AVI.GETLOST NOEXECUTION = True While KeyPressed(&H1B) MyDoEvents Wend myexit = True Exit Function End If ElseIf NOEXECUTION Then ShutEnabledGuiM2000 True MyDoEvents End If End If End If If bstack Is Nothing Then myexit = True: Exit Function If MusicMaster.PlayMusic Then MusicMaster.TimerTickNow End If If TaskMaster Is Nothing Then Exit Function If bstack.IamThread Then myexit = bstack.Process.Done Else myexit = False End Function Function myexit2(bstack As basetask) As Boolean If KeyPressed(&H1B) Then If Modalid <> 0 Then Modalid = 0 ShutEnabledGuiM2000 MyDoEvents While KeyPressed(&H1B) MyDoEvents Wend Else NOEXECUTION = True ShutEnabledGuiM2000 True MyDoEvents If AVIRUN Then AVI.GETLOST NOEXECUTION = True While KeyPressed(&H1B) MyDoEvents Wend myexit2 = True Exit Function End If ElseIf NOEXECUTION Then ShutEnabledGuiM2000 True MyDoEvents End If End Function Sub closeAll() Dim i As Long CloseAllHandlers CloseAllConnections End Sub Function MakeitObjectGeneric(Number As Long) As Object Dim aa As New mHandler, k As Long aa.t1 = 3 On Error GoTo there If Not MyIsObject(var(Number)) Then Set var(Number) = aa aa.t1 = 0 Else If var(Number) Is Nothing Then Number = -1 Else Do While TypeOf var(Number) Is mHandler If var(Number).indirect < 0 Then Exit Do If k > 20 Then MyEr "too many references", "πολλές αναφορές": Exit Do Number = var(Number).indirect k = k + 1 Loop End If there: aa.indirect = Number End If Set aa.objref = Nothing Set MakeitObjectGeneric = aa End Function Sub PlaceIteratorData(bstack As basetask, anything As Variant, st, en) Dim usehandler As mHandler, usehandler1 As mHandler Set usehandler = bstack.lastobj If MyIsObject(anything) Then Set usehandler1 = anything Set usehandler.objref = usehandler1.objref End If With usehandler.objref If st < 0 Then st = .Count + st Else st = st - 1 If en < 0 Then en = .Count + en Else en = en - 1 If st < 0 Then st = 0: en = -2 '0 If en < 0 Then en = -1 '0 If st >= .Count Then en = -1: st = .Count - 1 If en >= .Count Then en = -1 ' .count - 1 End With With usehandler .t1 = 3 .indirect = -1 .index_start = st .index_End = en .index_cursor = st .UseIterator = True End With If MyIsObject(anything) Then If TypeOf usehandler.objref Is FastCollection Then usehandler.t1 = 1 Set usehandler.objref = anything ElseIf TypeOf usehandler.objref Is StructCollection Then usehandler.t1 = 5 Set usehandler.objref = anything ElseIf TypeOf usehandler.objref Is Enumeration Then Set usehandler.objref = New mHandler Set usehandler = usehandler.objref Set usehandler1 = anything Set usehandler.objref = usehandler1.objref usehandler.t1 = 4 usehandler.index_cursor = st End If End If End Sub Sub MakeitObjectInventory(var As Variant, Optional queue As Boolean) Dim aa As New mHandler aa.t1 = 1 ' 1 for Inventory Set aa.objref = New FastCollection If queue Then aa.objref.AllowAnyKey Set var = aa End Sub Sub MakeitObjectBuffer(var As Variant) Dim aa As New mHandler aa.t1 = 2 ' 2 for Buffer Set aa.objref = New MemBlock Set var = aa End Sub Sub MakeitObjectLong(var As Variant) Dim aa As Long var = aa End Sub Sub MakeitObjectEvent(var As Variant) Dim aa As New mEvent Set var = aa End Sub Sub MakeitObject(var As Variant) Dim aa As New Document Set var = aa var.textDoc = vbNullString End Sub Sub MakeitPropReference(var As Variant) Dim aa As New PropReference Set var = aa End Sub Sub CreateFormObject(var As Variant, id As Long) Dim aa As Object Select Case id 'Case 0 'Set aa = New Server ' next time... Case 1 Set aa = New GuiM2000 Case 2 ' Set aa = New GuiButton Case 3 Set aa = New GuiTextBox Case 4 Set aa = New GuiCheckBox Case 5 Set aa = New GuiEditBox Case 6 Set aa = New GuiListBox Case 7 Set aa = New GuiDropDown Case 8 Set aa = New GuiImage Case 9 Set aa = New ExtControl End Select Set var = aa End Sub Sub CreateFormOtherObject(var As Variant, THISOBJECT As Object) Set var = THISOBJECT End Sub Sub CreateitObject(var As Variant, THISOBJECT As String, Optional ByVal cc As Variant) Dim aa As Object Dim nVal As String If IsMissing(cc) Then If Left$(THISOBJECT, 1) = "{" Then nVal = strProgIDfromSrting(THISOBJECT) If Len(nVal) > 0 Then THISOBJECT = nVal End If On Error Resume Next Set aa = CreateObject(THISOBJECT) If Err Then Err.Clear Set aa = CreateObject(App.EXENAME + "." + THISOBJECT) If Err Then MyEr Err.Description, Err.Description End If Else Set aa = CreateObject(THISOBJECT, CStr(cc)) End If Set var = aa End Sub Function CheckVarGroup(basestack As basetask, var As Variant, s As String, Optional Final As Boolean = False) As Long Dim D As Document, c As Constant If VarTypeName(var) = doc Then Set D = var D.FasttextDoc = s ElseIf VarTypeName(var) = "lambda" Then If Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is lambda Then Set var = basestack.lastobj End If End If ElseIf Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is lambda Then Set var = basestack.lastobj Set basestack.lastobj = Nothing CheckVarGroup = 1 ' means make function for lambda for group End If Else MoveStringToVariant s, var End If If Final Then Set c = New Constant c.DefineOnce var Set var = c End If Set basestack.lastobj = Nothing End Function Sub CheckVar(var As Variant, s As String, Optional Append As Boolean, Optional onlyString As Boolean) If VarTypeName(var) = doc Then If var.IsEmpty Then var.FasttextDoc = s Else Dim kk As Document Set kk = var kk.InsertDoc kk.LastParagraph, kk.TextParagraphLen(kk.LastParagraph) + 1, s End If Else If onlyString Then If MemInt(VarPtr(var)) <> vbString Then onlyString = False Exit Sub End If End If If Append Then If LenB(var) = 0 Then MoveStringToVariant s, var Else var = var + s End If Else MoveStringToVariant s, var End If End If End Sub Function CheckVarOnlyNo(var As Variant, s As String, Optional checktype As Boolean = True) As Boolean If VarTypeName(var) = doc Then If var.IsEmpty Then var.textDoc = s Else var.InsertDoc var.LastParagraph, var.TextParagraphLen(var.LastParagraph) + 1, s End If ElseIf MyIsObject(var) Then CheckVarOnlyNo = True ' this is an error Else If MemInt(VarPtr(var)) = vbString Then MoveStringToVariant s, var ElseIf checktype Then WrongType CheckVarOnlyNo = True ' this is an error Else var = "" MoveStringToVariant s, var End If End If End Function Sub MakeitObject2(var As Variant) Dim aa As Object Set aa = New Group Set var = aa End Sub Sub prepareGroup(bstack As basetask, ByVal ohere$, vvv As Long, Optional Glob As Boolean = False, Optional isAstr As Boolean = False, Optional alocal As Boolean = False) Dim hv As Boolean If Not Glob Then If alocal Then Else If here$ = vbNullString Then hv = GetVar(bstack, bstack.GroupName + ohere$, vvv, True) Else hv = GetlocalVar(bstack.GroupName + ohere$, vvv) End If End If End If If hv Then If Not MyIsObject(var(vvv)) Then MakeitObject2 var(vvv) ElseIf VarTypeName(var(vvv)) <> mGroup Then MakeitObject2 var(vvv) GoTo conthere ElseIf var(vvv).IamApointer Then PushStage bstack, False Dim myobject As Object Set myobject = var(vvv) UnFloatGroup bstack, ohere$, vvv, myobject, var(vvv).IamGlobal Set myobject = Nothing End If Else vvv = GlobalVarRefOnly(bstack.GroupName + ohere$, Glob) MakeitObject2 var(vvv) conthere: If isAstr Then GlobalVarRefLink bstack.GroupName + ohere$ + "$", vvv, Glob End If 'If Not glob Then var(vvv).GroupName = ohere$ + "." var(vvv).HasStrValue = isAstr End If var(vvv).edittag = vbNullString End Sub Public Function CleanStr(sStr As String, noValidcharList As String) As String Dim a$, i As Long '', ddt As Boolean If noValidcharList <> "" Then ''If Len(sStr) > 20000 Then ddt = True If Len(sStr) > 0 Then For i = 1 To Len(sStr) ''If ddt Then If i Mod 321 = 0 Then Sleep 20 If InStr(noValidcharList, Mid$(sStr, i, 1)) = 0 Then a$ = a$ + Mid$(sStr, i, 1) Next i End If Else a$ = sStr End If CleanStr = a$ End Function Sub CallByObject(bstack As basetask, ret As Boolean, that As stdCallFunction) Dim Up As Long, getparam As Boolean, pp As Long Dim k As Long, p As Variant, Final(0 To 63) As Variant Dim x1 As Long, what$, curtype As Long, s$, link$, rtype As Variant Dim thisref(0 To 63) As Long Dim usehandler As mHandler If that.ReadType(that.Count - 1) = -100 Then Up = that.Count - 1 getparam = True Else Up = that.Count End If For k = 1 To Up If that.IsByRef(k - 1) Then ' look for label..and check it If bstack.IsInStackString(what$) Then ' 1 any value as is ' 2 long ' 3 string ' 4 ??? WHY If that.ReadType(k - 1) <= 4 Then If GetGlobalVar(bstack.GroupName + what$, x1) Then thisref(k - 1) = x1 ' so that is used to restore value If that.ReadType(k - 1) = 2 Then Final(k - 1) = CLng(VarPtr(var(x1)) + 8) ElseIf MyIsObject(var(x1)) Then Final(k - 1) = CLng(VarPtr(var(x1)) + 8) ElseIf MyIsUnknown(var(x1)) Then Final(k - 1) = CLng(VarPtr(var(x1)) + 8) Else Final(k - 1) = var(x1) End If Else ' no such variable End If ElseIf that.ReadType(k - 1) = 64 Then If GetGlobalVar(bstack.GroupName + what$, x1) Then If MemInt(VarPtr(var(x1))) = vbDouble Then Final(k - 1) = CLng(VarPtr(var(x1)) + 8) Else WrongType Exit Sub End If End If End If Else ' type mismatch ' exit - error End If Else Dim ii As Long Select Case that.ReadType(k - 1) Case 2 If Not bstack.IsInStackNumber(p) Then If Not bstack.IsInStackLong(ii) Then If bstack.soros.StackItemTypeIsObject(1) Then If bstack.soros.StackItemTypeObjectType(1) = "*[Enumeration]" Then Set usehandler = bstack.soros.PopObj If MyIsNumeric(usehandler.index_cursor) Then ii = usehandler.index_cursor * usehandler.sign Else Exit For End If Else Exit For End If ElseIf bstack.IsInStackNumber(p) Then If MemInt(VarPtr(p)) = vbCurrency Then ' FOR ULONG WE CAN PASS CURRENCY If p < 0 Then MyEr "Only zero or positive number", "Μόνο μηδέν ή θετικό αριθμό" Else Final(k - 1) = CLng(signlong(p)) End If Else Exit For End If End If Else Exit For End If Final(k - 1) = ii Else If VarType(p) = 20 Then Final(k - 1) = p Else Final(k - 1) = CLng(p) End If End If Case 20 If Not bstack.IsInStackNumber(p) Then If Not bstack.IsInStackLong(ii) Then Exit For Final(k - 1) = cInt64(CVar(ii)) Else Final(k - 1) = cInt64(p) End If Case 1, 5 If Not bstack.IsInStackNumber(p) Then If Not bstack.IsInStackLong(ii) Then Exit For Final(k - 1) = ii Else Final(k - 1) = p End If Case 4, 7 If Not bstack.IsInStackNumber(p) Then If Not bstack.IsInStackLong(ii) Then Exit For Final(k - 1) = ii Else Final(k - 1) = MyRound(p) End If Case 64 If Not bstack.IsInStackNumber(p) Then If Not bstack.IsInStackLong(ii) Then Exit For Final(k - 1) = CDbl(ii) Else Final(k - 1) = CDbl(p) End If Case Else If Not bstack.IsInStackString(s$) Then Exit For Final(k - 1) = s$ End Select End If Next k If getparam Then Do If bstack.IsInStackLong(pp) Then Final(k - 1) = pp k = k + 1 ElseIf bstack.IsInStackNumber(p) Then Final(k - 1) = p k = k + 1 ElseIf bstack.IsInStackString(s$) Then Final(k - 1) = s$ k = k + 1 Else Exit Do End If Loop Until bstack.soros.IsEmpty Or k = 63 Up = k - 1 End If If k > Up Then 'all is ok ' make your call If that.RetType = 0 Then rtype = vbLong Else rtype = that.RetType End If If that.CallAddr = 0 Then If Left$(that.func, 1) = "#" Then that.CallAddr = GetFuncPtrOrd(that.LIB, that.func) Else that.CallAddr = GetFuncPtr(that.LIB, that.func) End If End If If that.CallAddr = 0 Then Exit Sub On Error GoTo there Select Case rtype Case 9, 13 If that.CallType = 0 Then Set rtype = Fast_stdCallW(that.CallAddr, rtype, Final(), Up) Else Set rtype = Fast_cdeclCallW(that.CallAddr, rtype, Final(), Up) End If If ret Then bstack.soros.PushObj rtype ' FEEDBACK TO STACK End If Case Else If that.CallType = 0 Then rtype = Fast_stdCallW(that.CallAddr, rtype, Final(), Up) Else rtype = Fast_cdeclCallW(that.CallAddr, rtype, Final(), Up) End If If ret Then If that.RetType <> vbString Then bstack.soros.PushVal rtype ' FEEDBACK TO STACK Else bstack.soros.PushStr GetBStrFromPtr(x1) End If End If End Select Else 'error message Exit Sub End If For k = 1 To that.Count If that.IsByRef(k - 1) Then ' RESTORE VALUES... If that.ReadType(k - 1) < 5 Then If that.ReadType(k - 1) <> 2 Then var(thisref(k - 1)) = Final(k - 1) End If End If Next k Exit Sub there: MyEr Err.Description, Err.Description Err.Clear End Sub Sub CallGlobal(s$) Dim ohere$ ohere$ = here$ here$ = "@" Execute Basestack1, s$, False s$ = vbNullString here$ = ohere$ End Sub Public Sub ProcProperty(bstack As basetask, v(), vIndex As Long, FN$, rest$, language As Long, Optional hardlink As Boolean = False, Optional usethis As Long) Dim var1() As Variant, s$, r As Variant, l As Long, NewRef As Long, many As Long, y1 As Boolean, x1 As Long, y2 As Boolean, y3 As Long Dim var2() As String, ss$, sp As Variant, indirect As Boolean, s1$, newvar As Boolean Dim vvOriginal As Object, vv As Object, handlerFLAG As Boolean, usehandler As mHandler, ExtControlFlag As Boolean Dim oo As Object, myVar As Variant Set vvOriginal = v(vIndex) Dim pppp As iBoxArray If TypeOf vvOriginal Is mHandler Then Set usehandler = vvOriginal If usehandler.indirect >= 0 Then vIndex = usehandler.indirect Set vv = var(usehandler.indirect) Else If usehandler.UseIterator Then ElseIf usehandler.IamEnum Then handlerFLAG = True Else Set vvOriginal = usehandler.objref End If End If indirect = True End If If TypeOf vvOriginal Is ExtControl Then If Left$(FN$, 1) = "*" Then FN$ = Mid$(FN$, 2) ExtControlFlag = True Set vv = vvOriginal Else Set vv = vvOriginal.Value End If ElseIf TypeOf vvOriginal Is PropReference Then Dim aProp As PropReference Set aProp = vvOriginal myVar = aProp.Value If aProp.LastHasObject Then Set vv = aProp.lastobj aProp.clearlastobject Else NoObjectFound Exit Sub End If Else Set vv = vvOriginal End If Do ReDim var1(0 To 0) Erase var2() Set pppp = Nothing If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, r) Then If VarType(r) = vbString Then SwapString2Variant s$, r GoTo contSrt End If If FastSymbol(rest$, "@") Then Set oo = bstack.lastobj Set bstack.lastobj = Nothing ReDim var1(0 To 1) If IsExp(bstack, rest$, sp) Then If bstack.lastobj Is Nothing Then var1(0) = sp Else Set var1(0) = bstack.lastobj If TypeOf var1(0) Is mHandler Then Set var1(0) = bstack.lastobjIndirect(var()) End If Set bstack.lastobj = Nothing End If ElseIf LastErNum1 Then Exit Sub ElseIf IsStrExp(bstack, rest$, ss$) Then var1(0) = ss$ ' never ElseIf LastErNum1 Then Exit Sub End If If oo Is Nothing Then var1(1) = r Else If TypeOf oo Is mHandler Then Set bstack.lastobj = oo Set var1(1) = bstack.lastobjIndirect(var()) Else Set var1(1) = oo End If Set oo = Nothing End If CallByNameFixParamArray vv, FN$, VbLet, var1(), var2(), 2, UseExtControl:=ExtControlFlag Else If bstack.lastobj Is Nothing Then conthere: var1(0) = r If FN$ = vbNullString Then Exit Sub CallByNameFixParamArray vv, FN$, VbLet, var1(), var2(), 1, UseExtControl:=ExtControlFlag Else Set var1(0) = bstack.lastobj If TypeOf var1(0) Is mHandler Then Set usehandler = var1(0) If usehandler.t1 = 4 Then Set bstack.lastobj = Nothing GoTo conthere End If End If Set bstack.lastobj = Nothing CallByNameFixParamArray vv, FN$, VbSet, var1(), var2(), 1, UseExtControl:=ExtControlFlag End If End If ElseIf IsStrExp(bstack, rest$, s$) Then contSrt: If FastSymbol(rest$, "@") Then ReDim var1(0 To 1) If IsExp(bstack, rest$, sp) Then If bstack.lastobj Is Nothing Then var1(0) = sp Else Set var1(0) = bstack.lastobj If TypeOf var1(0) Is mHandler Then Set var1(0) = bstack.lastobjIndirect(var()) End If Set bstack.lastobj = Nothing End If ElseIf LastErNum1 Then Exit Sub ElseIf IsStrExp(bstack, rest$, ss$) Then var1(0) = ss$ ElseIf LastErNum1 Then End If var1(1) = s$ CallByNameFixParamArray vv, FN$, VbLet, var1(), var2(), 2, UseExtControl:=ExtControlFlag Else var1(0) = s$ CallByNameFixParamArray vv, FN$, VbLet, var1(), var2(), 1, UseExtControl:=ExtControlFlag End If End If ElseIf IsLabelSymbolNew(rest$, "ΩΣ", "AS", language) Then ' WE MAKE A NEW OBJECT If TypeOf var(vIndex) Is GuiM2000 Then If UCase(FN$) = "VISIBLE" Then FN$ = "TrueVisible" If FN$ = vbNullString Then l = usethis ElseIf handlerFLAG Then Set usehandler = vv l = FindDISPID(usehandler.objref, FN$) Set usehandler = Nothing Else l = FindDISPID(vv, FN$) End If If l <> -1 Then ' we have vv, fn$, l and we are looking for a label to make an object to that y1 = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΟ", "GLOBAL", language) If Not y1 Then y2 = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", language) Else y2 = False x1 = Abs(IsLabel(bstack, rest$, s$)) If x1 < 5 Then If y1 Or y2 Then GoTo jumpthere If GetlocalVar(s$, NewRef) Then ' so it is an object now If Not MyIsObject(var(NewRef)) Then MakeitPropReference var(NewRef) GoTo jumpheretoo ElseIf VarTypeName(var(NewRef)) <> mProp Then If VarTypeName(var(NewRef)) = mHdlr Then GoTo contenum Else MakeitPropReference var(NewRef) End If GoTo jumpheretoo End If Else jumpthere: If y1 Then NewRef = GlobalVarRefOnly(s$, y1) Else NewRef = GlobalVarRefOnly(bstack.GroupName + s$) End If contenum: If l = -4 Then ' get now object sp = vbEmpty If ReadPropObj(vv, -4, sp, ExtControlFlag) Then Set usehandler = New mHandler Set var(NewRef) = usehandler usehandler.ConstructEnumerator sp Set usehandler = Nothing Else NoEnumerator End If Else MakeitPropReference var(NewRef) jumpheretoo: If hardlink Then Set oo = v(vIndex) If TypeOf oo Is mHandler Then Set usehandler = oo Set oo = usehandler.objref If usehandler.t1 <> 1 Then GoTo there End If End If var(NewRef).ConstructObj oo, l, ExtControlFlag Set oo = Nothing Else If vv Is var(vIndex) Then var(NewRef).Construct vIndex, l, indirect, ExtControlFlag ' this is the link vindex is an index to var() Else var(NewRef).ConstructObj vv, l, ExtControlFlag End If End If End If End If Else If y2 Then If FastSymbol(rest$, ")") Then GoTo contherenew End If If neoGetArray(bstack, s$, pppp, Len(here$) = 0, , Len(here$) > 0, noobj:=True) Then If NeoGetArrayItem(pppp, bstack, s$, NewRef, rest$) Then With pppp MakeitPropReference myVar If .arr Then Set .item(NewRef) = myVar If hardlink Then Set oo = v(vIndex) If TypeOf oo Is mHandler Then Set usehandler = oo With usehandler If .indirect < 0 Then Set oo = .objref End If End With End If myVar.ConstructObj oo, l, ExtControlFlag Set oo = Nothing Else myVar.Construct vIndex, l, ExtControlFlag ' this is the link vindex is an index to var() End If Set myVar = Nothing End With Set usehandler = Nothing End If ElseIf FastSymbol(rest$, ")") Then contherenew: If pppp Is Nothing Then Set pppp = GlobalArrProp(bstack, s$, y1) End If MakeitPropReference myVar If hardlink Then Set oo = v(vIndex) If TypeOf oo Is mHandler Then Set usehandler = oo Set oo = usehandler.objref Set usehandler = Nothing End If myVar.ConstructObj oo, l, ExtControlFlag Set oo = Nothing Else myVar.Construct vIndex, l, ExtControlFlag ' this is the link vindex is an index to var() End If myVar.UseIndex = True pppp.PushProp myVar End If End If End If ElseIf IsLabelSymbolNew(rest$, "ΠΑΡΕ", "GET", language) Then y1 = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΟ", "GLOBAL", language) If Not y1 Then newvar = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", language) y3 = IsLabelSymbolNew(rest$, "ΜΕΓΕΓΟΝΟΤΑ", "WITHEVENTS", language) l = FindDISPID(vv, FN$) FN$ = UCase(FN$) x1 = Abs(IsLabel(bstack, rest$, s$)) If ReadOneParameter(vv, l, s$, myVar) Then GoTo jumpFromGet End If ElseIf IsLabelSymbolNew(rest$, "ΘΕΣΕ", "SET", language) Then y1 = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΟ", "GLOBAL", language) l = FindDISPID(vv, FN$) FN$ = UCase(FN$) If l <> -1 Then x1 = Abs(IsLabel(bstack, rest$, s$)) If x1 < 5 Then If Not FastSymbol(rest$, "(") Then If Not ReadOneParameter(vv, l, s$, myVar) Then If MyIsObject(myVar) Then If myVar Is Err Then Set errbag = New ErrorBag errbag.CopyErr Set myVar = errbag Set errbag = Nothing Err.Clear End If Else MyEr s$, s$ GoTo there End If End If Else GoTo contindex End If Else contindex: If IsExp(bstack, rest$, sp) Then contIndexParam: Err.Clear Set myVar = ReadOneIndexParameter(vv, l, s1$, sp, False) If Err.Number Then If MyIsObject(myVar) Then If myVar Is Err Then Set errbag = New ErrorBag errbag.CopyErr Set myVar = errbag Set errbag = Nothing End If End If Err.Clear Set myVar = ReadOneIndexParameter(vv, l, s1$, sp, True) If MyIsObject(myVar) Then If myVar Is Err Then Set errbag = New ErrorBag errbag.CopyErr Set myVar = errbag Set errbag = Nothing End If End If Err.Clear End If ElseIf IsStrExp(bstack, rest$, ss$) Then sp = vbNullString SwapString2Variant ss$, sp GoTo contIndexParam End If If Not FastSymbol(rest$, ")") Then GoTo there If x1 > 4 Then s$ = Left$(s$, Len(s$) - 1) End If jumpFromGet: Dim ev As ComShinkEvent If newvar Then GoTo jumpnewvar ElseIf GetlocalVar(s$, NewRef) Then If IsObject(myVar) Then Set var(NewRef) = myVar If y3 Then If GetShink(ev, NewRef, s$) Then If Not GetVar(bstack, ChrW(&HFFBF) + "_" + s$, y3) Then y3 = globalvarGroup(ChrW(&HFFBF) + "_" + s$, CVar(vbNullString), , y1) End If Set var(y3) = ev Else MyEr "Can't handle events here", "Δεν μπορώ να χειριστώ γεγονότα" GoTo there End If End If Else var(NewRef) = myVar End If Else jumpnewvar: NewRef = GlobalVarRefOnly(s$, y1) If IsObject(myVar) Then Set var(NewRef) = myVar If y3 Then If GetShink(ev, NewRef, s$) Then y3 = globalvarGroup(ChrW(&HFFBF) + "_" + s$, CVar(vbNullString), , y1) Set var(y3) = ev Else MyEr "Can't handle events here", "Δεν μπορώ να χειριστώ γεγονότα" GoTo there End If End If Else var(NewRef) = myVar End If End If End If End If If FastSymbol(rest$, ",") Then ExtControlFlag = False If Not IsFlatStringExpr(bstack, rest$, FN$) Then Exit Do If TypeOf vv Is ExtControl Then If Left$(FN$, 1) = "*" Then FN$ = Mid$(FN$, 2) ExtControlFlag = True Set vv = vvOriginal Else Set vv = vvOriginal.Value End If End If Else Exit Do End If Loop there: Set oo = Nothing Set pppp = Nothing Set vv = Nothing End Sub Sub ProcMethod(bstack As basetask, v(), vIndex As Long, FN$, rest$, language As Long, ok As Boolean, groupok As Boolean, prive As Boolean) Dim var1() As Variant, s$, r As Double, l As Long, NewRef As Long, Glob As Boolean, newvar As Boolean Dim vv As Object, result As Variant, retobject As Object, usehandler As mHandler, oUnk As stdole.IUnknown Dim namarg As Long, x1 As Long ok = True Set vv = v(vIndex) If TypeOf vv Is mHandler Then Set usehandler = vv If usehandler.indirect >= 0 Then vIndex = usehandler.indirect If var2used < usehandler.indirect Then MyEr "weak reference out of scope", "η αναφορά είναι εκτός σκοπού" ok = False Exit Sub End If Set vv = var(usehandler.indirect) Else Set vv = usehandler.objref End If End If Set usehandler = Nothing If vv Is Nothing Then Exit Sub If TypeOf vv Is ExtControl Then Set vv = vv.Value ElseIf TypeOf vv Is PropReference Then Dim aProp As PropReference Set aProp = vv result = aProp.Value result = Empty If aProp.LastHasObject Then Set vv = aProp.lastobj aProp.clearlastobject Else ok = False: NoObjectFound: Exit Sub End If End If ReDim var1(0 To 0) Dim var2() As String ReDim var2(0 To 0) ' expression or label:=expression' ''Exit Sub Dim what$, it As Long, items As Long, y3 As Long, ok1 As Boolean ' we have parameters..(by value) If FastSymbol(rest$, "(") Then ' we have "(par1, par2...) as result" RealMeth bstack, rest$, var1(), var2(), items, namarg, ok1 If Not ok1 Then Exit Sub If Not FastSymbol(rest$, ")", True) Then Exit Sub result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), items, retobject, namarg, bstack.IamAnEvent, oUnk) ElseIf FastSymbol(rest$, ",") Then RealMeth bstack, rest$, var1(), var2(), items, namarg, ok1 ' if we have as result then we get an error... If Not ok1 Then Exit Sub result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), items, retobject, namarg, bstack.IamAnEvent, oUnk) Else result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), 0, retobject, namarg, bstack.IamAnEvent, oUnk) End If If Not retobject Is Nothing Then y3 = IsLabelSymbolNew(rest$, "ΜΕΓΕΓΟΝΟΤΑ", "WITHEVENTS", language) If groupok And y3 Then MyEr "not withevents as group member", "όχι με γεγονότα σε μέλος ομάδας" Exit Sub End If If IsLabelSymbolNew(rest$, "ΩΣ", "AS", language) Then Glob = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΗ", "GLOBAL", language) If groupok And Glob Then MyEr "not GLOBAL for group member", "όχι ΓΕΝΙΚΗ για μέλος ομάδας" Exit Sub End If newvar = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", language) If groupok And newvar Then MyEr "not new for group member", "όχι νέο για μέλος ομάδας" Exit Sub End If If Abs(IsLabel(bstack, rest$, what$)) = 1 Then If groupok Then ElseIf prive Then what$ = bstack.GroupName + ChrW(&HFFBF) + what$ Else what$ = bstack.GroupName + what$ End If If newvar Then it = globalvar(what$, 0, , Glob) Set var(it) = retobject ElseIf GetVar(bstack, what$, it) Then Set var(it) = retobject Else it = globalvar(what$, 0, , Glob) Set var(it) = retobject End If If y3 <> 0 Then Dim ev As ComShinkEvent If GetShink(ev, it, what$) Then ' private ' no need for a name, we do not address it in any way. ' ev knows how to call handler If newvar Then it = globalvarGroup(ChrW(&HFFBF) + "_" + what$, s$, , Glob) ElseIf Not GetVar(bstack, ChrW(&HFFBF) + "_" + what$, it) Then it = globalvarGroup(ChrW(&HFFBF) + "_" + what$, s$, , Glob) End If Set var(it) = ev Else MyEr "Can't handle events here", "Δεν μπορώ να χειριστώ γεγονότα" ok = False ' End Sub End If End If End If End If Else If MemInt(VarPtr(oUnk)) <> 0 Then Set result = oUnk End If If IsLabelSymbolNew(rest$, "ΩΣ", "AS", language) Then Glob = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΗ", "GLOBAL", language) If groupok And Glob Then MyEr "not GLOBAL for group member", "όχι ΓΕΝΙΚΗ για μέλος ομάδας" Exit Sub End If newvar = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", language) If groupok And newvar Then MyEr "not new for group member", "όχι νέο για μέλος ομάδας" Exit Sub End If Dim rA As refArray x1 = Abs(IsLabel(bstack, rest$, what$)) If Not groupok Then ElseIf prive Then what$ = bstack.GroupName + ChrW(&HFFBF) + what$ Else what$ = bstack.GroupName + what$ End If Select Case x1 Case 1 If newvar Then globalvar what$, result, , Glob ElseIf GetVar(bstack, what$, it) Then var(it) = result Else If (MemInt(VarPtr(result)) And vbArray) <> 0 Then If (MemInt(ArrPtr(result))) = 1 Then Set rA = New refArray rA.Value(0) = result 'ra.flat = True Set result = rA End If End If globalvar what$, result, , Glob End If Case 4 If newvar Then globalvar what$, Int(result), , Glob ElseIf GetVar(bstack, what$, it) Then var(it) = Int(result) Else globalvar what$, Int(result), , Glob End If Case 3 If newvar Then globalvar what$, result, , Glob ElseIf GetVar(bstack, what$, it) Then var(it) = result Else globalvar what$, result, , Glob End If Case 5 If newvar Then MyEr "not new for arrays", "όχι νεο για πίνακες" Exit Sub End If bstack.soros.PushVal result s$ = BlockParam(rest$) l = Len(s$) MyRead 6, bstack, what$ + s$ + ")", language, what$, x1 Mid$(rest$, 1, l) = space(l) FastSymbol rest$, ")", True Case 8 If newvar Then MyEr "not new for RefArrays", "όχι νεο για πίνακες με []" Exit Sub End If bstack.soros.PushVal result again1: s$ = BlockParamSq(rest$) l = Len(s$) Mid$(rest$, 1, l) = space(l) FastSymbol rest$, "]", True what$ = what$ + "[" + s$ + "]" If FastSymbol(rest$, "[") Then GoTo again1 MyRead 6, bstack, what$, language, what$, x1 End Select End If End If End Sub Sub ProcMethodAsap(bstack As basetask, vv As Object, FN$, rest$, ok As Boolean, groupok As Boolean, prive As Boolean) Dim var1() As Variant, s$, r As Double, l As Long, NewRef As Long, Glob As Boolean, newvar As Boolean Dim result As Variant, retobject As Object, usehandler As mHandler, oUnk As stdole.IUnknown Dim namarg As Long, x1 As Long, f As Long, language As Long Const b = vbCr + ",'\/:}" ok = True If vv Is Nothing Then Exit Sub If TypeOf vv Is ExtControl Then Set vv = vv.Value ElseIf TypeOf vv Is PropReference Then Dim aProp As PropReference Set aProp = vv result = aProp.Value result = Empty If aProp.LastHasObject Then Set vv = aProp.lastobj aProp.clearlastobject Else ok = False: NoObjectFound: Exit Sub End If End If ReDim var1(0 To 0) Dim var2() As String ReDim var2(0 To 0) Dim what$, it As Long, items As Long, y3 As Long, ok1 As Boolean rest$ = NLtrim(rest$) If FastSymbol(rest$, "(") Then ' we have "(par1, par2...) as result" RealMeth bstack, rest$, var1(), var2(), items, namarg, ok1 If Not ok1 Then Exit Sub If Not FastSymbol(rest$, ")", True) Then Exit Sub result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), items, retobject, namarg, bstack.IamAnEvent, oUnk) Else f = 1 f = MyTrimLi(rest$, f) If Len(rest$) < f Then result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), 0, retobject, namarg, bstack.IamAnEvent, oUnk) ElseIf InStr(b, Mid$(rest$, f, 1)) = 0 Then RealMeth bstack, rest$, var1(), var2(), items, namarg, ok1 ' if we have as result then we get an error... If Not ok1 Then Exit Sub result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), items, retobject, namarg, bstack.IamAnEvent, oUnk) Else result = CallByNameFixParamArray(vv, FN$, VbMethod, var1(), var2(), 0, retobject, namarg, bstack.IamAnEvent, oUnk) End If End If If Not retobject Is Nothing Then y3 = Fast2VarNoTrim(rest$, "ΜΕΓΕΓΟΝΟΤΑ", 10, "WITHEVENTS", 10, 10, f) If groupok And y3 Then MyEr "not withevents as group member", "όχι με γεγονότα σε μέλος ομάδας" Exit Sub End If If Fast2VarNoTrim(rest$, "ΩΣ", 2, "AS", 2, 3, f) Then language = f - 1 Glob = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΗ", "GLOBAL", language) If groupok And Glob Then MyEr "not GLOBAL for group member", "όχι ΓΕΝΙΚΗ για μέλος ομάδας" Exit Sub End If newvar = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", language) If groupok And newvar Then MyEr "not new for group member", "όχι νέο για μέλος ομάδας" Exit Sub End If If Abs(IsLabel(bstack, rest$, what$)) = 1 Then If groupok Then ElseIf prive Then what$ = bstack.GroupName + ChrW(&HFFBF) + what$ Else what$ = bstack.GroupName + what$ End If If newvar Then it = globalvar(what$, 0, , Glob) Set var(it) = retobject ElseIf GetVar(bstack, what$, it) Then Set var(it) = retobject Else it = globalvar(what$, 0, , Glob) Set var(it) = retobject End If If y3 <> 0 Then Dim ev As ComShinkEvent If GetShink(ev, it, what$) Then If newvar Then it = globalvarGroup(ChrW(&HFFBF) + "_" + what$, s$, , Glob) ElseIf Not GetVar(bstack, ChrW(&HFFBF) + "_" + what$, it) Then it = globalvarGroup(ChrW(&HFFBF) + "_" + what$, s$, , Glob) End If Set var(it) = ev Else MyEr "Can't handle events here", "Δεν μπορώ να χειριστώ γεγονότα" ok = False End If End If End If End If Else If MemInt(VarPtr(oUnk)) <> 0 Then Set result = oUnk End If If Fast2VarNoTrim(rest$, "ΩΣ", 2, "AS", 2, 3, f) Then language = f - 1 Glob = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΗ", "GLOBAL", language) If groupok And Glob Then MyEr "not GLOBAL for group member", "όχι ΓΕΝΙΚΗ για μέλος ομάδας" Exit Sub End If newvar = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", language) If groupok And newvar Then MyEr "not new for group member", "όχι νέο για μέλος ομάδας" Exit Sub End If Dim rA As refArray x1 = Abs(IsLabel(bstack, rest$, what$)) If Not groupok Then ElseIf prive Then what$ = bstack.GroupName + ChrW(&HFFBF) + what$ Else what$ = bstack.GroupName + what$ End If Select Case x1 Case 1 If newvar Then globalvar what$, result, , Glob ElseIf GetVar(bstack, what$, it) Then var(it) = result Else If (MemInt(VarPtr(result)) And vbArray) <> 0 Then If (MemInt(ArrPtr(result))) = 1 Then Set rA = New refArray rA.Value(0) = result Set result = rA End If End If globalvar what$, result, , Glob End If Case 3 If newvar Then globalvar what$, result, , Glob ElseIf GetVar(bstack, what$, it) Then var(it) = result Else globalvar what$, result, , Glob End If Case 4 If newvar Then globalvar what$, Int(result), , Glob ElseIf GetVar(bstack, what$, it) Then var(it) = Int(result) Else globalvar what$, Int(result), , Glob End If Case 5 If newvar Then MyEr "not new for arrays", "όχι νεο για πίνακες" Exit Sub End If bstack.soros.PushVal result s$ = BlockParam(rest$) l = Len(s$) MyRead 6, bstack, what$ + s$ + ")", language, what$, x1 Mid$(rest$, 1, l) = space(l) FastSymbol rest$, ")", True Case 8 If newvar Then MyEr "not new for RefArrays", "όχι νεο για πίνακες με []" Exit Sub End If bstack.soros.PushVal result again1: s$ = BlockParamSq(rest$) l = Len(s$) Mid$(rest$, 1, l) = space(l) FastSymbol rest$, "]", True what$ = what$ + "[" + s$ + "]" If FastSymbol(rest$, "[") Then GoTo again1 MyRead 6, bstack, what$, language, what$, x1 End Select End If End If End Sub Sub RealMeth(bstack As basetask, rest$, var2() As Variant, var3() As String, NoNameditems As Long, namedargument As Long, ok As Boolean) ' testmeth "122,&beta,121,alfa:=a+4, beta:=122" Dim s$ Dim mm As mArray, usehandler As mHandler Dim trap As Long, ss$, p As Variant, items As Long, ref As Boolean, i As Long, z As Variant, c As Long ok = True Do again: If FastSymbol(rest$, ",") Then ' second, or more is optional items = items + 1 If UBound(var2()) < items Then ReDim Preserve var2(items + 1) OptVariant var2(items - 1) If namedargument = 0 Then NoNameditems = NoNameditems + 1 GoTo again End If i = 1 If MaybeIsSymbol2(rest$, "&", i) Then If Not Mid$(rest$, i + 1, 2) Like "[hH][0123456789abcdefABCDEF]" Then ref = FastSymbol(rest$, "&") End If End If s$ = aheadstatus(rest$) + " " Select Case Left$(s$, 1) Case "S" If (trap Mod 2 = 0) And namedargument > 0 Then Exit Do ' is a fault If ref Then i = IsLabel(bstack, rest$, ss$) If i > 0 Then If i > 4 Then If Not FastSymbol(rest$, ")", True) Then Exit Sub GetVar bstack, ss$, i c = 1 again2: If MyIsObject(var(i)) Then If TypeOf var(i) Is mHandler Then Set usehandler = var(i) If usehandler.indirect <> -1 Then i = usehandler.indirect c = c + 1 If c < 20 Then Set usehandler = Nothing: GoTo again2 Else InternalError: Exit Sub End If If usehandler.t1 = 3 Then If IsobjmArray(usehandler.objref) Then Set mm = usehandler.objref mm.ExportStringArrayNow mm.refArray = vbNullString Set var2(items) = mm Set mm = Nothing Else WrongType ok = False Exit Sub End If Else VarByRef VarPtr(var2(items)), var(i) End If Set usehandler = Nothing ElseIf TypeOf var(i) Is mArray Then Set mm = var(i) mm.ExportStringArrayNow mm.refArray = vbNullString Set var2(items) = var(i) Set mm = Nothing Else VarByRef VarPtr(var2(items)), var(i) End If ElseIf VarType(var(i)) = vbDecimal Then VarByRefDecimal VarPtr(var2(items)), var(i) Else VarByRef VarPtr(var2(items)), var(i) End If If namedargument = 0 Then NoNameditems = NoNameditems + 1 Else NoReference ok = False Exit Sub End If ElseIf IsStrExp(bstack, rest$, ss$) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mArray Then Set mm = bstack.lastobj If mm.arr Then mm.ExportStringArrayNow mm.refArray = 0& End If Set var2(items) = mm Set mm = Nothing Else var2(items) = ss$ End If Else var2(items) = ss$ End If If namedargument = 0 Then NoNameditems = NoNameditems + 1 Else var2(items) = vbNullString s$ = vbNullString End If If trap > 0 Then trap = trap + 1 items = items + 1 If UBound(var2()) < items Then ReDim Preserve var2(items + 1) Case "N" ' maybe is a named argument c = 1 i = FastPureLabel(rest$, ss$, c, , , , False) If i > 0 Then If Mid$(rest$, c, 2) = ":=" Then i = IsLabel(bstack, rest$, ss$) rest$ = Mid$(rest$, 3) namedargument = namedargument + 1 If UBound(var3()) < namedargument Then ReDim Preserve var3(namedargument + 1) var3(namedargument) = ss$ trap = 1 GoTo again Else If ref Then i = IsLabel(bstack, rest$, ss$) If i > 4 Then If Not FastSymbol(rest$, ")", True) Then Exit Sub GetVar bstack, ss$, i c = 1 again3: If varhash.vType(varhash.index) = False Then VarByRefVariant VarPtr(var2(items)), var(i) ElseIf MyIsObject(var(i)) Then If TypeOf var(i) Is mHandler Then Set usehandler = var(i) If usehandler.indirect <> -1 Then i = var(i).indirect c = c + 1 If c < 20 Then Set usehandler = Nothing: GoTo again3 Else InternalError: Exit Sub End If If usehandler.t1 = 3 Then If IsobjmArray(usehandler.objref) Then Set mm = usehandler.objref mm.ExportArrayNow Set var2(items) = mm Set mm = Nothing Else WrongType ok = False Exit Sub End If ElseIf usehandler.t1 = 4 Then ' usehandler.sign * usehandler.index_cursor var2(items) = usehandler.sign * usehandler.index_cursor Else VarByRef VarPtr(var2(items)), var(i) End If Set usehandler = Nothing ElseIf TypeOf var(i) Is mArray Then Set mm = var(i) mm.ExportArrayNow Set var2(items) = var(i) Set mm = Nothing Else VarByRef VarPtr(var2(items)), var(i) End If ElseIf VarType(var(i)) = vbDecimal Then VarByRefDecimal VarPtr(var2(items)), var(i) Else VarByRef VarPtr(var2(items)), var(i) End If If namedargument = 0 Then NoNameditems = NoNameditems + 1 ElseIf Not ((trap Mod 2 = 0) And namedargument > 0) Then If IsExp(bstack, rest$, p) Then If bstack.lastobj Is Nothing Then var2(items) = p Else If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If usehandler.t1 = 4 Then var2(items) = p ElseIf usehandler.t1 = 3 Then If IsobjmArray(usehandler.objref) Then Set mm = usehandler.objref Set var2(items) = mm Set mm = Nothing Else WrongType ok = False Exit Sub End If Else Set var2(items) = bstack.lastobjIndirect(var()) End If ElseIf TypeOf bstack.lastobj Is mArray Then Set mm = bstack.lastobj mm.refArray = 0& mm.IsByValue = True Set var2(items) = mm Set mm = Nothing Else Set var2(items) = bstack.lastobj End If Set bstack.lastobj = Nothing End If If namedargument = 0 Then NoNameditems = NoNameditems + 1 If trap > 0 Then trap = trap + 1 End If Else Exit Do End If End If Else If Not ((trap Mod 2 = 0) And namedargument > 0) Then If IsExp(bstack, rest$, p) Then If Not bstack.lastobj Is Nothing Then Set var2(items) = bstack.lastobj Set bstack.lastobj = Nothing Else var2(items) = p End If If namedargument = 0 Then NoNameditems = NoNameditems + 1 If trap > 0 Then trap = trap + 1 Else Exit Do End If Else Exit Do End If End If items = items + 1 If UBound(var2()) < items Then ReDim Preserve var2(items + 1) End Select If Not FastSymbol(rest$, ",") Then Exit Do Loop Until s$ = vbNullString End Sub Function ReadProp(fromIndex As Long, ByVal propIndex As Long, RETVAR As Variant, _ skipExtControl As Boolean) As Boolean Dim o As Object, er$, usehandler As mHandler On Error GoTo there Set o = var(fromIndex) If o Is Nothing Then Exit Function End If If TypeOf o Is mHandler Then 0 Set usehandler = o propIndex = -propIndex If usehandler.UseIterator Then Else Set o = usehandler.objref End If Set usehandler = Nothing End If If o Is Nothing Then Exit Function If TypeOf o Is PropReference Then If o.IsObj Then Set o = o.Value End If If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If er$ = vbNullString RETVAR = Empty ReadProp = ReadOneParameter(o, propIndex, er$, RETVAR) If MyIsObject(RETVAR) Then If RETVAR Is Err Then Set errbag = New ErrorBag errbag.CopyErr Set RETVAR = errbag Set errbag = Nothing Err.Clear End If End If If er$ <> "" Then there: BadGetProp End If End Function Function ReadPropIndex(fromIndex As Long, ByVal propIndex As Long, myIndex As Variant, skipExtControl As Boolean, _ Optional maybeObject As Boolean, Optional retObj _ ) As Variant Dim o As Object, er$, check As Boolean, usehandler As mHandler On Error GoTo there Set o = var(fromIndex) If o Is Nothing Then Exit Function If TypeOf o Is mHandler Then propIndex = -propIndex Set usehandler = o Set o = usehandler.objref Set usehandler = Nothing End If er$ = vbNullString check = True If TypeOf o Is PropReference Then Dim aProp As PropReference Dim pp Set aProp = o pp = aProp.Value If aProp.LastHasObject Then Set o = aProp.lastobj aProp.clearlastobject Else Exit Function End If End If If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If ReadPropIndex = ReadOneIndexParameter(o, propIndex, er$, myIndex, , check) If Not check Then maybeObject = True ReadPropIndex = 0 Set retObj = o End If If er$ <> "" Then there: BadGetProp End If End Function Sub WriteProp(fromIndex As Long, ByVal propIndex As Long, Anyval As Variant, skipExtControl As Boolean) Dim o As Object, er$, usehandler As mHandler Set o = var(fromIndex) If o Is Nothing Then Exit Sub If TypeOf o Is mHandler Then propIndex = -propIndex Set usehandler = o If usehandler.UseIterator Then Else Set o = usehandler.objref End If Set usehandler = Nothing End If 'ChangeOneIndexParameter If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If ChangeOneParameter o, propIndex, Anyval, er$ If er$ <> "" Then BadLetProp End If End Sub Sub WritePropIndex(fromIndex As Long, ByVal propIndex As Long, Anyval As Variant, myIndex, skipExtControl As Boolean) Dim o As Object, er$, usehandler As mHandler Set o = var(fromIndex) If o Is Nothing Then Exit Sub If TypeOf o Is mHandler Then propIndex = -propIndex Set usehandler = o Set o = usehandler.objref Set usehandler = Nothing End If If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If ChangeOneIndexParameter o, propIndex, Anyval, er$, myIndex If er$ <> "" Then BadLetProp End If End Sub Function ReadPropIndexObj(o As Object, ByVal propIndex As Long, myIndex, skipExtControl As Boolean) As Variant Dim er$ er$ = vbNullString If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If Dim check As Boolean Dim oo As Object Set oo = o On Error GoTo 100 ReadPropIndexObj = ReadOneIndexParameter(oo, propIndex, er$, myIndex, , check) If er$ <> "" Then 100 If check = True Then MyEr "use ^ to get the object", "χρησιμοποίησε το ^ για να πάρει το αντικείμενο" Else BadGetProp End If End If End Function Function ReadPropIndexObjObj(o As Object, ByVal propIndex As Long, myIndex, skipExtControl As Boolean) As Object Dim er$ er$ = vbNullString If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If On Error Resume Next Set ReadPropIndexObjObj = ReadOneIndexParameter(o, propIndex, er$, myIndex) If Err Then BadGetProp Err.Clear ElseIf er$ <> "" Then BadGetProp End If End Function Function ReadPropObj(o As Object, ByVal propIndex As Long, RETVAR As Variant, skipExtControl As Boolean, Optional objectonly As Boolean = False) As Boolean Dim er$ If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If er$ = vbNullString ReadPropObj = ReadOneParameter(o, propIndex, er$, RETVAR) If MyIsObject(RETVAR) Then If RETVAR Is Err Then Set errbag = New ErrorBag errbag.CopyErr Set RETVAR = errbag Set errbag = Nothing Err.Clear End If ElseIf objectonly Then BadGetProp Exit Function End If If er$ <> "" Then BadGetProp End If End Function Sub WritePropObj(o As Object, ByVal propIndex As Long, Anyval As Variant, skipExtControl As Boolean) Dim er$ If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If ChangeOneParameter o, propIndex, Anyval, er$ If er$ <> "" Then BadLetProp End If End Sub Sub WritePropIndexObj(o As Object, ByVal propIndex As Long, Anyval As Variant, myIndex, skipExtControl As Boolean) Dim er$ If Not skipExtControl Then If TypeOf o Is ExtControl Then Set o = o.Value End If End If ChangeOneIndexParameter o, propIndex, Anyval, er$, myIndex If er$ <> "" Then BadLetProp End If End Sub Sub MakeThisSub(ThatStack As basetask, rest$) If Left$(rest$, 5) = "THIS." Then Dim s$ If ThatStack.GetDotNew(s$, 1) Then rest$ = s$ + Mid$(rest$, 6) ElseIf ThatStack.GroupName = vbNullString Then rest$ = ThatStack.UseGroupname + Mid$(rest$, 6) Else rest$ = ThatStack.GroupName + Mid$(rest$, 6) End If ElseIf Left$(rest$, 5) = "ΑΥΤΟ." Then If ThatStack.GetDotNew(s$, 1) Then rest$ = s$ + Mid$(rest$, 6) ElseIf ThatStack.GroupName = vbNullString Then rest$ = ThatStack.UseGroupname + Mid$(rest$, 6) Else rest$ = ThatStack.GroupName + Mid$(rest$, 6) End If Else End If End Sub Sub MakeThisSub1(ThatStack As basetask, rest$) Dim s$ If Len(rest$) < 7 Then Exit Sub s$ = myUcase(Left$(rest$, 5), AscW(rest$) < 128) If s$ = "THIS." Then s$ = vbNullString If ThatStack.GetDotNew(s$, 1) Then rest$ = s$ + Mid$(rest$, 6) ElseIf ThatStack.GroupName = vbNullString Then rest$ = ThatStack.UseGroupname + Mid$(rest$, 6) Else rest$ = ThatStack.GroupName + Mid$(rest$, 6) End If ElseIf s$ = "ΑΥΤΟ." Then s$ = vbNullString If ThatStack.GetDotNew(s$, 1) Then rest$ = s$ + Mid$(rest$, 6) ElseIf ThatStack.GroupName = vbNullString Then rest$ = ThatStack.UseGroupname + Mid$(rest$, 6) Else rest$ = ThatStack.GroupName + Mid$(rest$, 6) End If End If End Sub Sub MakeThisSubNum(ThatStack As basetask, rest$) If Left$(rest$, 1) = "T" Then If Left$(rest$, 5) = "THIS." Then If Len(ThatStack.UseGroupname) > 0 Then rest$ = ThatStack.UseGroupname + Mid$(rest$, 6) Else rest$ = ThatStack.GroupName + Mid$(rest$, 6) End If End If ElseIf Left$(rest$, 1) = "Α" Then If Left$(rest$, 5) = "ΑΥΤΟ." Then If Len(ThatStack.UseGroupname) > 0 Then rest$ = ThatStack.UseGroupname + Mid$(rest$, 6) Else rest$ = ThatStack.GroupName + Mid$(rest$, 6) End If End If End If End Sub Function ColorHSL(bstack As basetask, n$, r As Variant) As Boolean Dim R2 As Variant, R3 As Variant, ss$, par As Boolean ColorHSL = True If IsExp(bstack, n$, r, , True) Then If FastSymbol(n$, ",") Then If IsExp(bstack, n$, R2, , True) Then If R2 < 0 Then R2 = 0 If R2 > 100 Then R2 = 100 If FastSymbol(n$, ",") Then If IsExp(bstack, n$, R3, , True) Then If R3 < 0 Then R3 = 0 If R3 > 100 Then R3 = 100 par = True r = HSL(r, R2, R3) End If End If End If End If End If If Not par Then ColorHSL = False: MissNumExpr: Exit Function End Function Function ColorRGB(bstack As basetask, n$, r As Variant) As Boolean Dim R2 As Variant, R3 As Variant, ss$, par As Boolean ColorRGB = True If IsExp(bstack, n$, r, , True) Then par = True If FastSymbol(n$, ",") Then par = IsExp(bstack, n$, R2, , True) If par And FastSymbol(n$, ",") Then par = IsExp(bstack, n$, R3, , True) End If r = rgb(Abs(r Mod 256), Abs(R2 Mod 256), Abs(R3 Mod 256)) Else r = mycolor(r) End If If Not par Then ColorRGB = False: Exit Function ElseIf IsStrExp(bstack, n$, ss$) Then ' value in hexadecimal input as in html RGB ' we have to make BGR ss$ = Right$("00000000" + ss$, 8) r = CDbl(UNPACKLNG(Right$(ss$, 2)) * 65536#) + CDbl(UNPACKLNG(Mid$(ss$, 5, 2)) * 256#) + CDbl(UNPACKLNG(Mid$(ss$, 3, 2))) Else ColorRGB = False End If End Function Function globalArrByPointer(bs As basetask, basestack As basetask, what$, Optional newonly As Boolean = False, Optional checkforglobal As Boolean) As Boolean Dim pppp As mArray, ppppAny As iBoxArray, myobject As Object, wasAglobal As Boolean Dim pp1 As tuple Dim ar As refArray If bs.IsObjectRef(myobject) Then If newonly Then GoTo there1 If neoGetArray(basestack, what$, ppppAny, , , , , wasAglobal) Then If Not checkforglobal Then If wasAglobal Then GoTo there1 If Not ppppAny Is Nothing Then If TypeOf myobject Is mHandler Then If CheckAnyArray(myobject) Then If TypeOf myobject Is tuple Then Set pppp = ppppAny myobject.CopyTuple2Array pppp Set myobject = pppp Else ' myobject.CopyArray pppp ' Set myobject = pppp End If Set var(varhash.lastNDX) = myobject var(varhash.lastNDX).common = ppppAny.common Else NotArray Exit Function End If ElseIf TypeOf myobject Is mArray Then Set pppp = ppppAny myobject.CopyArray pppp ElseIf TypeOf myobject Is tuple Then Set pppp = ppppAny Set pp1 = myobject pp1.CopyTuple2Array pppp ' Set var(varhash.lastNDX) = pppp Else NotArray globalArrByPointer = False Set myobject = Nothing Exit Function End If Set myobject = Nothing globalArrByPointer = True End If Else there1: GlobalArr basestack, basestack.GroupName + what$, "", 0, -1 If neoGetArray(basestack, what$, ppppAny) Then ''basestack.GroupName & If TypeOf myobject Is mHandler Then If CheckAnyArray(myobject) Then If TypeOf myobject Is tuple Then Set pppp = ppppAny myobject.CopyTuple2Array pppp Set myobject = pppp End If Set var(varhash.lastNDX) = myobject Else NotArray Exit Function End If ElseIf TypeOf myobject Is refArray Then Set ar = myobject Set ar = ar.Copy() If ar.Count = 1 Then pppp.MyTypeToBe = ar.vtType(0) pppp.PushDim ar.Count(0) ar.Value = ar.Value(0) ar.flat = True pppp.PushEnd ar Else MyEr "RefArray has more dimensions than one", "Ο RefArray έχει περισσότερες διαστάσεις από μια" Exit Function End If ElseIf TypeOf myobject Is mArray Then Set pppp = ppppAny myobject.CopyArray pppp ElseIf TypeOf myobject Is tuple Then Set pppp = ppppAny Set pp1 = myobject pp1.CopyTuple2Array pppp Set var(varhash.lastNDX) = pppp Else NotArray globalArrByPointer = False Set myobject = Nothing Exit Function End If globalArrByPointer = True Set myobject = Nothing End If End If End If End Function Public Sub CopyHandler(f As Variant, bstack As basetask) Dim aa As mHandler, bb As mHandler Set aa = f aa.CopyTo bb Set bstack.lastobj = bb Set aa = Nothing Set bb = Nothing End Sub Public Function CopyHandlerObj(f As Variant) As Object Dim aa As mHandler, bb As mHandler Set aa = f aa.CopyTo bb Set CopyHandlerObj = bb Set aa = Nothing Set bb = Nothing End Function Public Sub CopyLambdaAny(f As Variant, obj As Object) Dim aa As lambda, bb As lambda Set aa = f aa.CopyTo bb, var() Set obj = bb Set aa = Nothing Set bb = Nothing End Sub Public Sub CopyLambda(f As Variant, bstack As basetask) Dim aa As lambda, bb As lambda Set aa = f aa.CopyTo bb, var() Set bstack.lastobj = bb Set aa = Nothing Set bb = Nothing End Sub Public Sub CopyGroup2(mg As Variant, bstack As basetask) Dim myGroup As Group Set myGroup = mg If myGroup.IamSuperClass Or myGroup.IamApointer Then Set bstack.lastobj = mg Exit Sub End If Dim k As Group, i As Long, j As Long, s$, w3 As Long, w1 As Integer Dim b$(), vvl As Variant, delme As Document, myfirstArray As mArray, mySecondArray As mArray Set k = New Group Dim BI As Long BI = 1 i = myGroup.FieldsCount k.BeginFloat i + 2 k.PokeItem 0, "Variables-Arrays" k.PokeItem 1, i Dim usevariant As Boolean For j = 2 To i * 2 + 1 Step 2 b$() = Split(myGroup.ReadField(BI), " ") w3 = Abs(val(b$(1))) w1 = AscW(Right$(b$(0), 1)) If w1 = 41 Then b$(0) = Left$(b$(0), Len(b$(0)) - 1) End If If w1 <> 40 Then s$ = VarTypeName(var(w3)) k.PokeItem j, b$(0) If s$ = doc Then 'preserve Documents MakeitObject vvl vvl.EmptyDoc vvl.textDoc = var(w3).textDoc k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty ElseIf s$ = mGroup Then vvl = -1 CopyGroup2 var(w3), bstack Set vvl = bstack.lastobj Set bstack.lastobj = Nothing k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty ElseIf s$ = mHdlr Then Set vvl = CopyHandlerObj(var(w3)) k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty Else k.PokeItem j + 1, var(w3) End If Else If w3 = 0 Then Set vvl = New mArray '' empty array Else s$ = VarTypeName(var(w3)) If s$ = "Empty" Then ElseIf s$ = myArray Then Set myfirstArray = var(w3) If Not myfirstArray.common Then Set mySecondArray = New mArray myfirstArray.CopyArray mySecondArray Set myfirstArray = Nothing Set vvl = mySecondArray Set mySecondArray = Nothing Else Set vvl = myfirstArray End If Else If MyIsObject(var(w3)) Then Set vvl = var(w3) End If End If k.PokeItem j, b$(0) + ")" k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty End If BI = BI + 1 Next j With myGroup k.PokeItem j, myGroup.localList k.PokeItem j + 1, GetFunctionList(.FuncList) k.oldFuncRef = vbNullString k.HasStrValue = .HasStrValue k.HasValue = .HasValue k.HasSet = .HasSet k.HasParameters = .HasParameters k.HasParametersSet = .HasParametersSet k.HasRemove = .HasRemove Set k.SuperClassList = .SuperClassList Set k.Events = .Events k.highpriorityoper = .highpriorityoper k.HasUnary = .HasUnary k.PointerPtr = ObjPtr(mg) k.ToDelete = True 'Set k.mytypes = .mytypes k.mergeTypes .mytypes End With Set bstack.lastobj = k End Sub Public Function CopyGroupObj(mg As Variant, Optional nofunc As Boolean = False, Optional thisLink) As Object Dim myGroup As Group If Not myVarType(mg, vbObject) Then Exit Function If mg Is Nothing Then Exit Function If Not TypeOf mg Is Group Then Set CopyGroupObj = mg: Exit Function End If Set myGroup = mg If myGroup.IamSuperClass Or myGroup.IamApointer Then Set CopyGroupObj = myGroup Exit Function End If If myGroup.IamFloatGroup Then Set CopyGroupObj = myGroup Exit Function End If Dim Name$, k As Group, i As Long, j As Long, s$, w3 As Long, w1 As Integer Dim b$(), vvl As Variant Set k = New Group 'Set k.Sorosref = myGroup.soros.Copy Dim BI As Long BI = 1 i = myGroup.FieldsCount 'myGroup.soros.Total k.BeginFloat i + 2 k.PokeItem 0, "Variables-Arrays" k.PokeItem 1, i For j = 2 To i * 2 + 1 Step 2 b$() = Split(myGroup.ReadField(BI), " ") w3 = Abs(val(b$(1))) w1 = AscW(Right$(b$(0), 1)) If w1 = 41 Then b$(0) = Left$(b$(0), Len(b$(0)) - 1) End If If w1 <> 40 Then k.PokeItem j, b$(0) s$ = VarTypeName(var(w3)) If s$ = doc Then 'preserve Documents MakeitObject vvl vvl.EmptyDoc vvl.textDoc = var(w3).textDoc k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty ElseIf s$ = mGroup Then vvl = -1 Set vvl = CopyGroupObj(var(w3)) k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty ElseIf s$ = mHdlr Then Set vvl = CopyHandlerObj(var(w3)) k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty Else k.PokeItem j + 1, var(w3) End If Else If w3 = 0 Then Set vvl = New mArray '' empty array Else If myVarType(var(w3), vbEmpty) Then Else Set vvl = var(w3) End If k.PokeItem j, b$(0) + ")" k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty End If End If BI = BI + 1 Next j With myGroup k.PokeItem j, myGroup.localList If nofunc Then If Not IsMissing(thisLink) Then Set k.LinkRef = thisLink End If Else If ChangedFunctionList(.FuncList) Then k.PokeItem j + 1, GetFunctionList(.FuncList) Else If .oldFuncRef <> vbNullString Then k.PokeItem j + 1, .oldFuncRef k.oldFuncRef = vbNullString Else k.PokeItem j + 1, GetFunctionList(.FuncList) End If End If End If k.HasStrValue = .HasStrValue k.HasValue = .HasValue k.HasSet = .HasSet k.HasParameters = .HasParameters k.HasParametersSet = .HasParametersSet k.HasRemove = .HasRemove Set k.SuperClassList = .SuperClassList Set k.Events = .Events k.highpriorityoper = .highpriorityoper k.HasUnary = .HasUnary k.PointerPtr = ObjPtr(mg) k.ToDelete = False Set k.mytypes = .mytypes End With Set CopyGroupObj = k End Function Public Function CopyGroup0Obj(mg As Variant, usethisk As Variant) As Object Dim myGroup As Group, grgroup As Group Set myGroup = mg Dim Name$, k As Group, BI As Long, j As Long, s$, w3 As Long, w1 As Integer Dim b$(), vvl As Variant If TypeOf usethisk Is Group Then Set k = usethisk Else Set k = New Group End If BI = 1 If Not k.IamFloatGroup Then Exit Function k.PokeItem 0, "Variables-Arrays" For j = 2 To myGroup.FieldsCount * 2 + 1 Step 2 b$() = Split(myGroup.ReadField(BI), " ") w3 = Abs(val(b$(1))) w1 = AscW(Right$(b$(0), 1)) If w1 = 41 Then b$(0) = Left$(b$(0), Len(b$(0)) - 1) End If If w1 <> 40 Then s$ = VarTypeName(var(w3)) If s$ = doc Then 'preserve Documents ElseIf s$ = mGroup Then vvl = -1 k.PeekItem j + 1, vvl CopyGroup0Obj var(val(b$(1))), vvl Set vvl = Nothing vvl = Empty ElseIf s$ = mHdlr Then Set vvl = CopyHandlerObj(var(w3)) k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty Else k.PokeItem j + 1, var(w3) End If Else If w3 = 0 Then Set vvl = New mArray Else If myVarType(var(w3), vbEmpty) Then Else Set vvl = var(w3) End If k.PokeItem j, b$(0) + ")" k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty End If End If BI = BI + 1 Next j Set CopyGroup0Obj = k End Function Public Function CopyGroup1(mg As Variant, usethisk As Variant) As Object Dim myGroup As Group, grgroup As Group Set myGroup = mg Dim Name$, k As Group, j As Long, s$, v As Variant, w3 As Long, w1 As Integer Dim b$(), vvl As Variant If TypeOf usethisk Is Group Then Set k = usethisk Else Set k = New Group End If Dim BI As Long BI = 1 If Not k.IamFloatGroup Then Exit Function k.PokeItem 0, "Variables-Arrays" For j = 2 To myGroup.FieldsCount * 2 + 1 Step 2 b$() = Split(myGroup.ReadField(BI), " ") w3 = Abs(val(b$(1))) w1 = AscW(Right$(b$(0), 1)) If w1 = 41 Then b$(0) = Left$(b$(0), Len(b$(0)) - 1) End If If w1 <> 40 Then s$ = VarTypeName(var(w3)) If s$ = doc Then 'preserve Documents ElseIf s$ = mGroup Then vvl = -1 k.PeekItem j + 1, vvl Set CopyGroup1 = CopyGroup1(var(w3), vvl) Set vvl = Nothing vvl = Empty ElseIf s$ = mHdlr Then Set vvl = CopyHandlerObj(var(w3)) k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty Else k.PokeItem j + 1, var(w3) End If Else If w3 = 0 Then Set vvl = New mArray '' empty array Else If myVarType(var(w3), vbEmpty) Then Else Set vvl = var(w3) End If k.PokeItem j, b$(0) + ")" k.PokeItem j + 1, vvl Set vvl = Nothing vvl = Empty End If End If BI = BI + 1 Next j Set CopyGroup1 = k End Function Sub UnFloatGroup(bstack As basetask, what$, i As Long, myobject1 As Object, Optional Glob As Boolean = False, Optional temp As Boolean = False, Optional MakeNew As Boolean) Dim ThisGroup As Group, myobject As Group, it As Long If (myobject1 Is Nothing) Then Exit Sub If Not TypeOf myobject1 Is Group Then Exit Sub Set myobject = myobject1 If myobject.IamApointer Then Set var(i) = myobject Exit Sub End If While Right$(what$, 1) = "." what$ = Left$(what$, Len(what$) - 1) Wend If Len(what$) = 0 Then Exit Sub Dim v As Long, s$, frm$, vvl As Variant, x1 As Long, ss$, frmarr$, sss$, j As Long Dim grtype As Variant, ps2push As String, uni As Boolean, uni1 As Boolean, other As Group Dim UnhidePrivate As Boolean If bstack.tpointer <> 0 Then x1 = bstack.tpointer If MyIsObject(var(x1)) Then If TypeOf var(x1) Is Group Then Set other = myobject Set ThisGroup = var(x1) UnhidePrivate = other.MatchTypes(ThisGroup.mytypes) Set other = Nothing End If End If x1 = 0 End If Set var(i) = New Group Set ThisGroup = var(i) ThisGroup.IamGlobal = Glob ' check this again ThisGroup.ToDelete = myobject.ToDelete If Not myobject.SuperClassList Is Nothing Then Set ThisGroup.SuperClassList = myobject.SuperClassList If myobject Is Nothing Then Exit Sub If myobject.IamSuperClass Then Set myobject = myobject.SuperClassList: uni = True End If 'Set ps = ThisGroup.soros Dim subgroup As Object, pppp As mArray Dim ohere$, oldgroupname$ ohere$ = here$ oldgroupname$ = bstack.GroupName If bstack.GroupName <> "" Then If Len(ohere$) = 0 Then ThisGroup.Patch = what$ Else ThisGroup.Patch = ohere$ + "." + what$ End If bstack.GroupName = bstack.GroupName + what$ + "." Else bstack.GroupName = what$ + "." If Glob Or Len(ohere$) = 0 Then ThisGroup.Patch = what$ Else ThisGroup.Patch = ohere$ + "." + what$ End If End If Dim usevariant As Boolean With myobject ThisGroup.HasRemove = .HasRemove If .IamFloatGroup Then .PeekItem 0, grtype .PeekItem 1, vvl For x1 = 2 To 1 + vvl * 2 Step 2 .PeekItem x1, vvl 'here is the name s$ = vvl If s$ = vbNullString Then InternalError: s$ = "asap" usevariant = False If Left$(s$, 1) = "#" Then s$ = Mid$(s$, 2): usevariant = True If temp Then If Left$(s$, 1) = "@" Then s$ = Mid$(s$, 2) If uni Then uni1 = Left$(s$, 1) = "@" If temp And uni1 Then uni1 = False: s$ = Mid$(s$, 2) End If End If If uni1 Then GoTo cont1010 .PeekItem x1 + 1, vvl 'here is the value frm$ = VarTypeName(vvl) If frm$ = myArray Then s$ = Left$(s$, Len(s$) - 1) ss$ = vbNullString j = -1 If temp Then GlobalArr bstack, ThisGroup.Patch + "." + s$, ss$, 0, j, True Set var(j) = vvl Else Set subgroup = vvl GlobalArr bstack, ThisGroup.Patch + "." + s$, ss$, 0, j, True Set pppp = var(j) subgroup.CopyArray pppp Set subgroup = Nothing End If ' If AscW(s$) = -65 And UnhidePrivate Then varhash.ItemCreator ThisGroup.Patch + "." + Mid$(s$, 2), j, True, , True End If If usevariant Then 'ps.DataStr "#" + s$ + " " + str(-j) ThisGroup.Add2Field "#" + s$ + " " + str(-j) Else 'ps.DataStr s$ + str(j) ThisGroup.Add2Field s$ + str(j) End If ElseIf frm$ = "lambda" Then v = globalvarGroup(ThisGroup.Patch + "." + s$, 0, , True) isalambda: If AscW(s$) = -65 And UnhidePrivate Then varhash.ItemCreator ThisGroup.Patch + "." + Mid$(s$, 2), v, True, , True it = GlobalSub(ThisGroup.Patch + "." + Mid$(s$, 2) + "()", "", ThisGroup.Patch + ".", , v) Else it = GlobalSub(ThisGroup.Patch + "." + s$ + "()", "", ThisGroup.Patch + ".", , v) End If sbf(it).tpointer = i GoTo conthere2 ElseIf frm$ = mHdlr Then Set vvl = CopyHandlerObj(vvl) GoTo conthere1 ElseIf frm$ = "mEvent" Then CopyEvent vvl, bstack Set vvl = bstack.lastobj Set bstack.lastobj = Nothing If here$ = vbNullString Then vvl.Upgrade bstack.GroupName Else vvl.Upgrade here$ + "." + bstack.GroupName End If GoTo conthere1 Else ' is not array so... If frm$ = mGroup Then Set other = vvl Dim spare As Object If Left$(s$, 1) = "*" Then v = globalvarGroup(ThisGroup.Patch + "." + Mid$(s$, 2), 0, , True) If AscW(Mid$(s$, 2, 1)) = -65 And UnhidePrivate Then globalvarGroup ThisGroup.Patch + "." + Mid$(s$, 3), v, True, True End If If other.IamApointer Then If ThisGroup.ToDelete Then myobject.PokeItem x1 + 1, 0 other.ToDelete = True End If Set var(v) = vvl Else Set spare = vvl here$ = ThisGroup.Patch ' check this too other.ToDelete = ThisGroup.ToDelete If AscW(Mid$(s$, 2, 1)) = -65 And UnhidePrivate Then UnFloatGroup bstack, Mid$(s$, 3), v, spare, Glob, temp, MakeNew Else UnFloatGroup bstack, Mid$(s$, 2), v, spare, Glob, temp, MakeNew End If here$ = ohere$ Set other = Nothing Set spare = Nothing End If 'ps.DataStr s$ + str(v) ThisGroup.Add2Field s$ + str(v) Else v = globalvarGroup(bstack.GroupName + s$, 0) Set spare = vvl here$ = ThisGroup.Patch UnFloatGroup bstack, s$, v, spare, Glob, temp, MakeNew here$ = ohere$ Set spare = Nothing 'ps.DataStr "*" + s$ + str(v) ThisGroup.Add2Field "*" + s$ + str(v) End If Else If Right$(s$, 2) = "()" Then s$ = Left$(s$, Len(s$) - 1) End If conthere1: v = globalvarGroup(ThisGroup.Patch + "." + s$, 0, , True, , Not usevariant) If UnhidePrivate And AscW(s$) = -65 Then globalvarGroup ThisGroup.Patch + "." + Mid$(s$, 2), v, True, True, , Not usevariant End If conthere2: If MyIsObject(vvl) Then Set var(v) = vvl If Not vvl Is Nothing Then If TypeOf vvl Is Constant Then If myVarType(vvl.Value, vbObject) Then Set vvl = vvl.Value If Not vvl Is Nothing Then If TypeOf vvl Is lambda Then GoTo isalambda End If End If End If End If End If Else var(v) = vvl End If If usevariant Then 'ps.DataStr "#" + s$ + " " + str(-v) ThisGroup.Add2Field "#" + s$ + " " + str(-v) Else 'ps.DataStr s$ + str(v) ThisGroup.Add2Field s$ + str(v) End If End If End If cont1010: Next x1 If ohere$ = vbNullString Or Len(bstack.UseGroupname) > 0 Or Glob Then here$ = vbNullString Else here$ = ohere$ End If If MyIsObject(vvl) Then Set vvl = Nothing End If .PeekItem x1, vvl If Trim$(vvl) <> "" Then s$ = CStr(vvl) ExecuteGroupStruct bstack, what$, (i), s$, 0, 1 End If .PeekItem x1 + 1, vvl ' save definitions ThisGroup.oldFuncRef = vvl If Trim$(vvl) <> "" Then s$ = CStr(vvl) bstack.GroupName = vbNullString While Len(s$) > 0 ' do not fix we want a loop with " " here$ = ThisGroup.Patch x1 = IsLabelA1("", s$, ss$) If x1 <> 0 Then sss$ = s$ If Len(ss$) > 6 Then j = 0 x1 = IsLabelA1("", s$, ss$) If UnhidePrivate And AscW(ss$) = -65 Then Mid$(sss$, Len(sss$) - Len(s$) - Len(ss$) + 1, 1) = " " End If frm$ = vbNullString If MyFunction(-2 * (&H1FFF = AscW(ss$)), bstack, sss$, 1, True, MakeNew) Then '' >6 len for function x1 = bstack.IndexSub If FastSymbol(sss$, ChrW(&H1FFD)) Then sbf(x1).locked = True frm$ = " " + str$(-x1) Else frm$ = str$(x1) End If If Asc(s$) <> 32 Then If InStr(s$, " ") = 2 Then ss$ = ss$ + Left$(s$, 1) s$ = Mid$(s$, 2) Else ss$ = ss$ + Left$(s$, 2) s$ = Mid$(s$, 3) End If End If If sbf(x1).sbgroup = here$ + "." Then If InStr(ThisGroup.FuncList, Chr$(2) + ss$ + "() ") = 0 Then ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + "()" + frm$ + Chr$(1) + ThisGroup.FuncList End If Else ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + "()" + frm$ + Chr$(1) + ThisGroup.FuncList sbf(x1).sbgroup = here$ + "." sbf(x1).tpointer = i End If Else x1 = 0 End If Else x1 = IsLabelA1("", s$, ss$) If UnhidePrivate And AscW(ss$) = -65 Then Mid$(sss$, Len(sss$) - Len(s$) - Len(ss$) + 1, 1) = " " End If If MyModule(bstack, sss$, 1, True, MakeNew) Then x1 = bstack.IndexSub sbf(x1).sbc = 1 If FastSymbol(sss$, ChrW(&H1FFD)) Then sbf(x1).locked = True frm$ = " " + str$(-x1) Else frm$ = str$(x1) End If If sbf(x1).sbgroup = here$ + "." Then If InStr(ThisGroup.FuncList, Chr$(2) + ss$ + "() ") = 0 Then ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + str(x1) + Chr$(1) + ThisGroup.FuncList End If Else If sbf(x1).locked Then ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + frm$ + Chr$(1) + ThisGroup.FuncList Else ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + frm$ + Chr$(1) + ThisGroup.FuncList End If sbf(x1).sbgroup = here$ + "." sbf(x1).tpointer = i End If Else x1 = 0 End If End If sss$ = NLtrim$(sss$) + " " While AscW(sss$) = 13 SetNextLine sss$ sss$ = NLtrim$(sss$) + " " Wend If Len(bstack.UseGroupname) > 0 Or Glob Then here$ = vbNullString Else here$ = ohere$ End If s$ = sss$ Else s$ = vbNullString End If Wend End If End If End With With ThisGroup .GroupName = what$ + "." .FloatGroupName = myobject.FloatGroupName If myobject.HasStrValue Then GlobalVarRefLink2 here$ + "$", i, Glob End If .HasStrValue = myobject.HasStrValue .HasValue = myobject.HasValue .HasSet = myobject.HasSet .HasParameters = myobject.HasParameters .HasParametersSet = myobject.HasParametersSet Set .Events = myobject.Events .highpriorityoper = myobject.highpriorityoper .HasUnary = myobject.HasUnary .HasRemove = myobject.HasRemove Or .HasRemove Set .mytypes = myobject.mytypes End With SwapStrings here$, ohere$ bstack.GroupName = oldgroupname$ End Sub Sub UnFloatGroupReWriteVars(bstack As basetask, what$, i As Long, myobject1 As Object, Optional mergesuper As Boolean = False, Optional MakeNew As Boolean, Optional bypassnew As Boolean = False) Dim ThisGroup As Group, ohere$, addon As Boolean, myobject As Group If myobject1 Is Nothing Then Exit Sub If Not TypeOf myobject1 Is Group Then Exit Sub Set myobject = myobject1 Set ThisGroup = var(i) If myobject.IamApointer Then If ThisGroup.IamApointer Then Set var(i) = myobject: Exit Sub If myobject.link.IamFloatGroup And ThisGroup.FieldsCount = 0 Then Set var(i) = myobject Exit Sub ElseIf myobject.link.IamFloatGroup Then If myobject.link Is NullGroup Then Set myobject = New Group myobject.BeginFloat 0 myobject.EndFloat Else Set myobject = CopyGroupObj(myobject.link) End If Else SwapStrings ohere$, here$ here$ = myobject.lasthere If GetVar(bstack, myobject.GroupName, i, , , True) Then CopyGroup2 myobject.link, bstack End If SwapStrings here$, ohere$ If bstack.lastobj Is Nothing Then Exit Sub If Not TypeOf bstack.lastobj Is Group Then Exit Sub Set myobject = bstack.lastobj Set bstack.lastobj = Nothing End If End If If ThisGroup.IamApointer Then If ThisGroup.link.IamFloatGroup Then Set var(i).link = myobject Else SyntaxError End If Exit Sub End If While Right$(what$, 1) = "." what$ = Left$(what$, Len(what$) - 1) Wend If Len(what$) = 0 Then Exit Sub If Not bypassnew Then If Len(ThisGroup.Patch) > 0 Then If Len(bstack.UseGroupname) > 0 Then If bstack.tpointer = i Then bypassnew = bstack.ErrVars > bstack.tpointer Else bypassnew = (Left(ThisGroup.Patch, Len(bstack.UseGroupname)) = bstack.UseGroupname And Not bstack.nokillvars) End If End If End If End If Dim v As Long, s$, frm$, vvl As Variant, x1 As Long, ss$, frmarr$, sss$, j As Long Dim grtype As Variant, ps2push As String, ff$, uni As Boolean, limit As Long ' TT As Long Dim usevariant As Boolean 'Set ps = var(i).soros Dim subgroup As Object, pppp As mArray Dim oldgroupname$, Glob As Boolean ohere$ = here$ ' get a backup Glob = ThisGroup.IamGlobal uni = myobject.IamSuperClass If Not myobject.SuperClassList Is Nothing Then Set ThisGroup.SuperClassList = myobject.SuperClassList If myobject.IamSuperClass Then Set myobject = myobject.SuperClassList End If If Len(bstack.UseGroupname) > 0 Or Glob Then If Not Glob Then Else here$ = vbNullString End If 'If glob Then here$ = VbNullString End If oldgroupname$ = bstack.GroupName If bstack.GroupName <> "" Then bstack.GroupName = bstack.GroupName + what$ + "." Else bstack.GroupName = what$ + "." End If If myobject Is Nothing Then GoTo exithere1 With myobject ThisGroup.HasRemove = .HasRemove Or ThisGroup.HasRemove If Not .IamFloatGroup Then GoTo exithere1 If .IamFloatGroup Then addon = bstack.ErrVars < i Or Not Glob .PeekItem 0, grtype .PeekItem 1, vvl For x1 = 2 To 1 + vvl * 2 Step 2 .PeekItem x1, vvl 'here is the name s$ = vvl If uni Then If Left$(s$, 1) = "@" Then If mergesuper Then s$ = Mid$(s$, 2) Else GoTo cont1010 End If End If End If If Left$(s$, 1) = "#" Then s$ = Mid$(s$, 2): usevariant = True Else usevariant = False .PeekItem x1 + 1, vvl 'here is the value If MyIsObject(vvl) Then If vvl Is Nothing Then GoTo cont1010 ElseIf TypeOf vvl Is mArray Then s$ = Left$(s$, Len(s$) - 1) ss$ = vbNullString If here$ = vbNullString And Len(bstack.UseGroupname) > 0 Then If neoGetArrayLinkOnly(bstack, bstack.UseGroupname + s$, j) Then GoTo conthere1111 End If If Not neoGetArrayLinkOnly(bstack, ThisGroup.Patch + "." + s$, j) Then If bypassnew Then GoTo cont1010 j = -1 Set subgroup = vvl GlobalArr bstack, ThisGroup.Patch + "." + s$, ss$, 0, j, True Set pppp = var(j) subgroup.CopyArray pppp Set subgroup = Nothing Else conthere1111: Set subgroup = vvl Set pppp = var(j) subgroup.CopyArray pppp Set subgroup = Nothing End If If addon Then If usevariant Then ' PS.DataStrUn "#" + s$ + " " + str$(-j) ThisGroup.MergeField "#" + s$ + " " + str$(-j) Else ' PS.DataStrUn s$ + str$(j) ThisGroup.MergeField s$ + str$(j) End If End If ElseIf TypeOf vvl Is lambda Then If GetVar1(bstack, bstack.GroupName + s$, v) And here$ = vbNullString Then ElseIf Not GetVar1(bstack, s$, v) Then isalambda: If bypassnew Then GoTo cont1010 v = globalvarGroup(bstack.GroupName + s$, 0) If here$ = vbNullString Then GlobalSub bstack.GroupName + s$ + "()", "", bstack.GroupName, , v Else GlobalSub here$ + "." + bstack.GroupName + s$ + "()", "", here$ + "." + bstack.GroupName, , v End If End If Set var(v) = vvl If addon Then ' PS.DataStrUn s$ + str(v) ThisGroup.MergeField s$ + str(v) End If Else ' is not array so... '' drop * If AscW(s$) = 42 Then s$ = Mid$(s$, 2) ps2push = bstack.GroupName + s$ If GetVar1(bstack, ps2push, v) Then ElseIf GetVar1(bstack, here$ + "." + ps2push, v) Then ElseIf Not GetVar1(bstack, s$, v) Then If bypassnew Then GoTo cont1010 v = globalvarGroup(ps2push, 0) End If If TypeOf vvl Is Group Then Dim spare As Object Set spare = vvl If MyIsObject(var(v)) Then If Typename(var(v)) = mGroup Then UnFloatGroupReWriteVars bstack, s$, v, spare, , MakeNew, bypassnew Else GoTo cont1928374 End If Else cont1928374: ss$ = here$ If Len(bstack.GroupName) > 1 Then here$ = bstack.GroupName here$ = Left$(here$, Len(here$) - 1) End If UnFloatGroup bstack, s$, v, spare, , , MakeNew here$ = ss$ End If Set spare = Nothing If addon Then ' PS.DataStrUn "*" + s$ + str(v) ThisGroup.MergeField "*" + s$ + str(v) End If GoTo cont1010 ElseIf TypeOf vvl Is mHandler Then Set vvl = CopyHandlerObj(vvl) ElseIf TypeOf vvl Is mEvent Then CopyEvent vvl, bstack Set vvl = bstack.lastobj Set bstack.lastobj = Nothing If here$ = vbNullString Then vvl.Upgrade bstack.GroupName Else vvl.Upgrade here$ + "." + bstack.GroupName End If ElseIf TypeOf vvl Is Constant Then If VarTypeName(var(v)) = "Constant" Then GoTo cont1010 ElseIf VarTypeName(vvl.Value) = "lambda" Then If MemInt(VarPtr(var(v))) = 2 Then GoTo isalambda End If End If End If Set var(v) = vvl If addon Then ' ps.DataStrUn s$ + Str(v) If usevariant Then ' PS.DataStrUn "#" + s$ + " " + str$(-v) ThisGroup.MergeField "#" + s$ + " " + str$(-v) Else ' PS.DataStrUn s$ + str$(v) ThisGroup.MergeField s$ + str$(v) End If End If End If Else If AscW(s$) = 42 Then s$ = Mid$(s$, 2) ' CHECK THIS FOR ERROR ps2push = bstack.GroupName + s$ If GetVar1(bstack, ps2push, v) Then ElseIf GetVar1(bstack, here$ + "." + ps2push, v) Then ElseIf Not GetVar1(bstack, s$, v) Then If bypassnew Then GoTo cont1010 v = globalvarGroup(ps2push, 0) End If var(v) = vvl If addon Then If usevariant Then ' PS.DataStrUn "#" + s$ + " " + str$(-v) ThisGroup.MergeField "#" + s$ + " " + str$(-v) Else ' PS.DataStrUn s$ + str$(v) ThisGroup.MergeField s$ + str$(v) End If End If End If cont1010: Next x1 End If If ohere$ = vbNullString Or Glob Then here$ = vbNullString Else here$ = ohere$ End If .PeekItem x1, vvl If Trim$(vvl) <> "" Then s$ = CStr(vvl) ExecuteGroupStruct bstack, what$, (i), s$, 0, 1 End If .PeekItem x1 + 1, vvl If Trim$(vvl) <> "" Then s$ = CStr(vvl) bstack.GroupName = vbNullString While s$ <> "" If ohere$ = vbNullString Or Glob Then here$ = oldgroupname$ + what$ Else here$ = ohere$ + "." + oldgroupname$ + what$ End If x1 = IsLabelA1("", s$, ss$) If x1 <> 0 Then sss$ = s$ If Len(ss$) > 6 Then x1 = IsLabelA1("", s$, ss$) frm$ = vbNullString If MyFunction(-2 * (&H1FFF = AscW(ss$)), bstack, sss$, 1, True, MakeNew, , bypassnew) Then '' >6 len for function If Asc(s$) <> 32 Then If InStr(s$, " ") = 2 Then ss$ = ss$ + Left$(s$, 1) s$ = Mid$(s$, 2) Else ss$ = ss$ + Left$(s$, 2) s$ = Mid$(s$, 3) End If End If x1 = bstack.IndexSub sbf(x1).Changed = True If FastSymbol(sss$, ChrW(&H1FFD)) Then sbf(x1).locked = True frm$ = " " + str$(-x1) Else frm$ = str$(x1) End If If Not sbf(x1).sbgroup = here$ + "." Then If addon Then ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + "()" + frm$ + Chr$(1) + ThisGroup.FuncList sbf(x1).sbgroup = here$ + "." sbf(x1).tpointer = i End If Else x1 = 0 End If Else x1 = IsLabelA1("", s$, ss$) If MyModule(bstack, sss$, 1, True, MakeNew, , , bypassnew) Then x1 = bstack.IndexSub sbf(x1).sbc = 1 sbf(x1).Changed = True If FastSymbol(sss$, ChrW(&H1FFD)) Then sbf(x1).locked = True frm$ = " " + str$(-x1) Else frm$ = str$(x1) End If If Not sbf(x1).sbgroup = here$ + "." Then If addon Then ThisGroup.FuncList = Chr$(1) + Chr$(2) + ss$ + frm$ + Chr$(1) + ThisGroup.FuncList sbf(x1).sbgroup = here$ + "." sbf(x1).tpointer = i End If Else x1 = 0 End If End If sss$ = NLtrim$(sss$) + " " While AscW(sss$) = 13 SetNextLine sss$ sss$ = NLtrim$(sss$) + " " Wend If Len(bstack.UseGroupname) > 0 Or Glob Then here$ = vbNullString Else here$ = ohere$ End If s$ = sss$ Else s$ = vbNullString End If Wend End If End With With ThisGroup .IamCleared = False .HasValue = myobject.HasValue Or .HasValue .HasSet = myobject.HasSet Or .HasSet .HasStrValue = myobject.HasStrValue Or .HasStrValue .HasParameters = myobject.HasParameters Or .HasParameters .HasParametersSet = myobject.HasParametersSet Or .HasParametersSet If Not myobject.Events Is Nothing Then If .Events Is Nothing Then Set .Events = myobject.Events End If End If .highpriorityoper = MergeOperators(myobject.highpriorityoper, .highpriorityoper) .HasUnary = myobject.HasUnary Or .HasUnary .HasRemove = myobject.HasRemove Or .HasRemove If Not bypassnew Then .mergeTypes myobject.mytypes End If End With exithere1: SwapStrings here$, ohere$ bstack.GroupName = oldgroupname$ End Sub Function ChangedFunctionList(ByVal s$) As Boolean ChangedFunctionList = True Exit Function Dim c$, k$(), Final As Long Do While s$ <> "" And Not ChangedFunctionList If ISSTRINGA(s$, c$) Then ChangedFunctionList = sbf(Abs(val(Split(c$, " ")(1)))).Changed Loop End Function Function GetFunctionList(ByVal s$) As String Dim c$, f$, k$(), qq$, Final As Long, tmp$, oldl As Long, mtrim As Long Dim final2 As Long While s$ <> "" If ISSTRINGA(s$, c$) Then k$() = Split(c$, " ") Final = val(k$(1)) If Not Right$(sbf(Abs(Final)).sb, 2) = vbCrLf Then qq$ = vbCrLf End If final2 = Final < 0 If Right$(k$(0), 1) = ")" Then If UBound(k$) = 2 Then f$ = "Function " + Mid$(k$(0), 2, Len(k$(0)) - 3) + " {" + sbf(Abs(Final)).sb + qq$ + "}" + ChrW(&H1FFD) + ChrW(&H1FFD) + f$ Else If final2 Then f$ = "Function " + Mid$(k$(0), 2, Len(k$(0)) - 3) + " {" + sbf(Abs(Final)).sb + qq$ + "}" + ChrW(&H1FFD) + f$ Else f$ = "Function " + Mid$(k$(0), 2, Len(k$(0)) - 3) + " {" + sbf(Abs(Final)).sb + qq$ + "}" + f$ End If End If Else If final2 Then f$ = "Module " + Mid$(k$(0), 2, Len(k$(0)) - 1) + " {" + sbf(Abs(Final)).sb + qq$ + "}" + ChrW(&H1FFD) + f$ Else f$ = "Module " + Mid$(k$(0), 2, Len(k$(0)) - 1) + " {" + sbf(Abs(Final)).sb + qq$ + "}" + f$ End If End If End If Wend GetFunctionList = f$ End Function Sub ResetFunctionList(s$) Dim c$, k$(), Final As Long While s$ <> "" If ISSTRINGA(s$, c$) Then k$() = Split(c$, " ") Final = val(k$(1)) With sbf(Abs(Final)) .sb = vbNullString .sbc = 0 .sbgroup = vbNullString .goodname = vbNullString .locked = False .tpointer = 0 .IamAClass = False Set .subs = Nothing Set .Pad = Nothing End With End If Wend End Sub Function SBcode(i As Long) As String If i < 0 Then SBcode = var(-i).Code$ Else SBcode = sbf(i).sb End If End Function Function GlobalHandler(basestack As basetask, rest$, Lang As Long, typeHandler As Long) As Boolean Dim x1 As Long, ss$, i As Long, s$, what$, par As Boolean Do x1 = Abs(IsLabel(basestack, rest$, what$)) If x1 <> 1 Then GlobalHandler = False: Exit Function ss$ = here$ here$ = vbNullString i = globalvar(basestack.GroupName + what$, Empty, , True) Select Case typeHandler Case 1 MakeitObjectInventory var(i) here$ = ss$ If FastSymbol(rest$, "=") Then Set basestack.lastobj = var(i) GlobalHandler = AddInventory(basestack, rest$) Exit Function End If Case 2 MakeitObjectBuffer var(i) here$ = ss$ Case 3 MakeitObjectInventory var(i), True here$ = ss$ If FastSymbol(rest$, "=") Then Set basestack.lastobj = var(i) GlobalHandler = AddInventory(basestack, rest$) Exit Function End If Case Else here$ = ss$ End Select Loop Until Not FastSymbol(rest$, ",") If rest$ <> "" Then If Not MaybeIsSymbol(rest$, ":" + vbCr) Then SyntaxError Else GlobalHandler = True End If Else GlobalHandler = True End If End Function Function GlobalEVENT(basestack As basetask, rest$, Lang As Long) As Boolean Dim x1 As Long, ss$, i As Long, s$, what$ x1 = Abs(IsLabel(basestack, rest$, what$)) If x1 <> 1 Then GlobalEVENT = False: Exit Function ss$ = here$ here$ = vbNullString i = globalvar(basestack.GroupName + what$, Empty, , True) MakeitObjectEvent var(i) here$ = ss$ GlobalEVENT = ProcEvent(basestack, rest$, Lang, i) End Function Function dimString(typo$) As String Dim pppp As mArray, pp, i As Long, p, lim As Long Dim b$(), vl$ b$() = Split(typo$, " ") Set pppp = var(val(b$(1))) pppp.SerialItem pp, CLng(p), 5 Dim a$() If pp < 1 Then dimString$ = b$(0) + ")": Exit Function ReDim a$(pp - 1) For i = 0 To pp - 1 pppp.GetDnum i, p, lim 'pppp.SerialItem p, i, 6 a$(i) = Trim$(str$(-lim)) + " TO " + Trim$(str$(p - lim - 1)) Next i pppp.SerialItem p, 0&, 2 If InStr(b$(0), "$") > 0 Then vl$ = "{" & (p) & "} " Else If IsNumeric(p) Then vl$ = "=" & (p) & " " Else vl$ = "=0 " End If End If If pp > 1 Then dimString = b$(0) + Join(a$(), ",") + ")" + vl$ Else dimString = b$(0) + a$(0) + ")" + vl$ End If End Function Sub LogGroup(bstack As basetask, vvv As Long, ohere$, OvarnameLen As Long, lcl As Boolean, ByPass As Boolean, Unique As Boolean) If ByPass Then GoTo bye 'unique = False ' Dim ss$, W$, i As Long, nm$, nt$, CM$, nt1$, j As Long, k As Long, dropit As Long Dim s() As String, eGroup As Group Set eGroup = var(vvv) With eGroup If here$ <> "" Then W$ = UCase(here$ + "." + ohere$ + ".") Else W$ = UCase(ohere$ + ".") End If If OvarnameLen <= varhash.Count Then For i = OvarnameLen To varhash.Count ' or not varhash.ReadVar i - 1, ss$, dropit If Left(ss$, Len(W$)) = W$ Then j = dropit nt$ = VarTypeName(var(j)) If Not lcl Then If nt$ = mGroup Then If Right$(ss$, 1) <> "$" Then '.soros.DataStr "*" + Mid$(ss$, Len(W$) + 1) + str(j) .Add2Field "*" + Mid$(ss$, Len(W$) + 1) + str(j) Else End If Else If varhash.vType(i - 1) = False Then If Unique Then '.soros.DataStr "#@" + Mid$(ss$, Len(W$) + 1) + " " + str(-j) .Add2Field "#@" + Mid$(ss$, Len(W$) + 1) + " " + str(-j) Else '.soros.DataStr "#" + Mid$(ss$, Len(W$) + 1) + " " + str(-j) .Add2Field "#" + Mid$(ss$, Len(W$) + 1) + " " + str(-j) End If Else If Unique Then '.soros.DataStr "@" + Mid$(ss$, Len(W$) + 1) + str(j) .Add2Field "@" + Mid$(ss$, Len(W$) + 1) + str(j) Else '.soros.DataStr Mid$(ss$, Len(W$) + 1) + str(j) .Add2Field Mid$(ss$, Len(W$) + 1) + str(j) End If End If End If Else nm$ = Mid$(ss$, Len(W$) + 1) If nt1$ <> nt$ Then .localList = .localList + vbCrLf: CM$ = vbNullString If i = OvarnameLen Then CM$ = "Local " Else CM$ = ", " If nt$ = "Long" Then If CM$ = "," Then nt1$ = vbNullString Else nt1$ = nt$ + " " .localList = .localList & CM$ & nt1$ & nm$ + "=" & var(j) ElseIf nt$ = myArray Then .localList = .localList + vbCrLf + "local DIM " + dimString(nm$ + str$(j)) + vbCrLf ElseIf nt$ = doc Then If CM$ = "," Then nt1$ = vbNullString Else nt1$ = nt$ + " " .localList = .localList & CM$ & nt1$ & nm$ & "={" & (var(j)) & "}" ElseIf InStr(nm$, "$") Then .localList = .localList & CM$ & nm$ & "={" & (var(j)) & "}" Else .localList = .localList + CM$ + nm$ + "=" + str(var(j)) End If nt1$ = nt$ End If End If Next i If lcl Then .localList = .localList + vbCrLf End If ' End With bye: OvarnameLen = varhash.Count + 1 'Len(VarName$) + 1 'we record ...AGAIN End Sub Function FindNameForGroup(bstack As basetask, W$) As Boolean Dim ss() As String, w2 As Long If InStr(W$, ChrW(&H1FFF)) > 0 Then If InStr(W$, ".") > 0 Then ss() = Split(W$, ".") If GetVar(bstack, ss(0), w2) Then If VarTypeName(var(w2)) = mGroup Then If var(w2).FloatGroupName <> "" Then ss(0) = var(w2).FloatGroupName: FindNameForGroup = True W$ = Join(ss(), ".") If InStr(W$, ChrW(&H1FFF)) > 0 Then W$ = vbNullString Else FindNameForGroup = True End If Else W$ = vbNullString End If Else W$ = vbNullString End If Else W$ = vbNullString End If End If End Function Function procTestMe(bstack As basetask, rest$, what$) As Boolean Dim ss$ procTestMe = True If Not Form1.Visible Then newshow Basestack1 k1 = 0 End If If FastSymbol(rest$, "!") Then untest: If trace Then With Form2 If .Busy Then Do Sleep 10 Loop Until Not .Busy End If .Busy = True If pagio$ = "GREEK" Then .gList2.HeadLine = "Έλεγχος" Else .gList2.HeadLine = "Control" End If If TestShowCode And here$ <> "" Then Form2.gList3(2).BackColor = &H606060 Else Form2.gList3(2).BackColor = &H3B3B3B End If .label1(0) = vbNullString .label1(1) = vbNullString .label1(2) = vbNullString .Hide Set .Process = Nothing STq = False STEXIT = False STbyST = False trace = False .Busy = False End With End If Exit Function End If With Form2 If .Busy Then Do Sleep 10 If Form2.Visible = False Then .Busy = False ' new addition ver 14 Loop Until Not .Busy End If End With If bypassST Then Form2.Busy = True: GoTo bb1 STq = False STEXIT = False STbyST = True Form2.Show , Form1 Form2.Busy = True If here$ = vbNullString Then TestShowSub = vbNullString TestShowStart = 0 Form2.testpad.Text = vbNullString Form2.testpad.glistN.CapColor = rgb(128, 128, 0) Form2.testpad.Show Form2.testpad.SetRowColumn 1, 1 End If Form2.switchview = 0 Sleep 10 'MyDoEvents ' gList2.HeadLine If bstack.IamLambda Then If pagio$ = "GREEK" Then Form2.label1(0) = "ΣΥΝΑΡΤΗΣΗ ΛΑΜΔΑ" Else Form2.label1(0) = "LAMBDA FUNCTION" End If Else Form2.label1(0) = GetName$(here$) End If Form2.label1(1) = what$ Form2.label1(2) = GetStrUntil(vbCrLf, rest$ + vbCrLf, False) Dim back$ bb1: If ISSTRINGA(rest$, ss$) Then IsSymbol rest$, "," If ss$ <> "" Then With Form2 If pagio$ = "GREEK" Then .gList2.HeadLine = "Έλεγχος: " + ss$ Else .gList2.HeadLine = "Control: " + ss$ End If If Not bypassST Then TestShowCode = True End With If TestShowCode And here$ <> "" Then Form2.gList3(2).BackColor = &H606060 If Len(TestShowSub) >= WaitShow And WaitShow > 0 Then TestShowStart = rinstr(TestShowSub, Mid$(rest$, 2)) - 1 Else WaitShow = 0 ss$ = GetNextLine((sbf(Abs(bstack.OriginalCode)).sb)) If Left$(ss$, 10) = "'11001EDIT" Then TestShowSub = Mid$(sbf(Abs(bstack.OriginalCode)).sb, Len(ss$) + 3) Else TestShowSub = ss$ End If If bstack.addlen Then If Len(TestShowSub) - bstack.addlen - Len(rest$) > 0 Then TestShowStart = Len(TestShowSub) - bstack.addlen - Len(rest$) + 1 Else TestShowStart = 1 End If Else TestShowStart = Len(TestShowSub) - Len(rest$) + 1 End If If TestShowStart <= 0 Then TestShowStart = rinstr(TestShowSub, Mid$(rest$, 2)) - 1 End If End If Else TestShowSub = vbNullString End If Set Form2.Process = bstack stackshow bstack ' not that from version 12 'MyDoEvents Form1.Show , Form5 Form2.gList2.RefreshNow what$ = vbNullString Form2.Busy = False If FastPureLabel(rest$, what$, , , , , False) = 1 Then rest$ = ": " + rest$ If Not trace Then trace = True procTestMe = Execute(bstack, what$, True) = 1 GoTo untest Else End If ElseIf what$ <> "" Then com1020: Dim M As Long, s$ Do M = 1 what$ = aheadstatus(rest$, , M) If M > 1 Then If Asc(Left$(LTrim(Left$(rest$, M)), 1) + " ") < 32 Then Exit Do STq = True If s$ <> "" Then s$ = s$ + ", " + LTrim$(Left$(rest$, M - 1)) Else s$ = s$ + LTrim$(Left$(rest$, M - 1)) End If Mid$(rest$, 1, M - 1) = space$(M - 1) STbyST = False End If If Not FastSymbol(rest$, ",") Then Exit Do Loop Until M = 1 If Not Form2.Visible Then Form2.Show , Form1 Form2.Compute.vartext = s$ rest$ = NLtrim(rest$) trace = True TestShowCode = False Form2.gList4.ListIndex = 1 End If Else If FastPureLabel(rest$, what$, , , , , False) = 1 Then TestShowCode = True rest$ = ": " + rest$ trace = True Set Form2.Process = bstack stackshow bstack 'MyDoEvents Form1.Show , Form5 Else GoTo com1020 End If End If Form2.Busy = False End Function Function procMotionW(bstack As basetask, rest$) As Boolean Dim X As Double, Y As Double, myform As GuiM2000, where As Long Dim Scr As Object If TypeOf bstack.Owner Is GuiM2000 Then procMotionW = True Set myform = bstack.Owner myform1: where = FindFormSScreen(myform) If Not IsExp(bstack, rest$, X) Then X = myform.Left If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, Y) Then procMotionW = False: Exit Function Else Y = myform.top End If If FastSymbol(rest$, ";") Then X = ((ScrInfo(where).Width - 1) - myform.Width) / 2 + ScrInfo(where).Left Y = ((ScrInfo(where).Height - 1) - myform.Height) / 2 + ScrInfo(where).top If X < ScrInfo(where).Left Then X = ScrInfo(where).Left If Y < ScrInfo(where).top Then Y = ScrInfo(where).top End If myform.move X, Y ElseIf val("0" + bstack.Owner.Tag) > 32 Then Set Scr = bstack.Owner.Parent If Scr Is Nothing Then Exit Function While Not TypeOf Scr Is GuiM2000 Set Scr = Scr.Parent If Scr Is Nothing Then Exit Function Wend procMotionW = True Set myform = Scr GoTo myform1 ElseIf TypeOf bstack.Owner Is MetaDc Then oxiforMetaFiles Exit Function Else 'If Not Form1.Visible Then Exit Function procMotionW = True 'Form1.Visible = True 'If Form3.Visible Then Form3.skiptimer = True: Form3.WindowState = 0 Console = FindFormSScreen(Form1) If Form1.WindowState <> 0 Then Form1.WindowState = 0 ': mydoevents If IsWine Then Sleep 50: Form1.SetFocus If Form1.WindowState = 0 Then If Not IsExp(bstack, rest$, X) Then X = Form1.Left If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, Y) Then procMotionW = False: Exit Function Else Y = Form1.top End If If FastSymbol(rest$, ";") Then X = ((ScrInfo(Console).Width - 1) - Form1.Width) / 2 + ScrInfo(Console).Left Y = ((ScrInfo(Console).Height - 1) - Form1.Height) / 2 + ScrInfo(Console).top End If ' LETS MOVE If IsWine And Form1.Width = ScrInfo(Console).Width Then Form1.Width = ScrInfo(Console).Width - dv15 If Form1.top > VirtualScreenHeight() - 100 Then Form1.top = ScrInfo(Console).top If IsWine Then If X = ScrInfo(Console).Left And Y = ScrInfo(Console).top Then Form1.move X, Y 'If form5iamloaded Then Form5.RestorePos Sleep 10 End If End If Form1.move X, Y 'If form5iamloaded Then Form5.RestorePos Console = FindFormSScreen(Form1) If FastSymbol(rest$, ";") Then X = ((ScrInfo(Console).Width - 1) - Form1.Width) / 2 + ScrInfo(Console).Left Y = ((ScrInfo(Console).Height - 1) - Form1.Height) / 2 + ScrInfo(Console).top If X < ScrInfo(where).Left Then X = ScrInfo(where).Left If Y < ScrInfo(where).top Then Y = ScrInfo(where).top If Form1.top > VirtualScreenHeight() - 100 Then Form1.top = ScrInfo(Console).top Form1.move X, Y End If Form1.Up If IsWine Then Sleep 10 End If End If End Function Function procLineSpace(bstack As basetask, rest$) As Boolean Dim X As Double procLineSpace = True If IsExp(bstack, rest$, X, , True) Then If CLng(X) < 0 Or CLng(X) > 60 * dv15 Then OutOfLimit Else X = (X \ 15) * 30 X = CLng(X) / 2 SetText bstack.Owner, CLng(X) End If ElseIf FastSymbol(rest$, "!") Then SetText bstack.Owner, 4 * Screen.TwipsPerPixelY Else MissNumExpr procLineSpace = False Exit Function End If End Function Function ProcLabel(basestack As basetask, rest$) As Boolean Dim s$, frm$, p As Variant, X As Double, Y As Double, sx As Double, sy As Double Dim Scr As Object, prive As basket, Quality As Boolean Set Scr = basestack.Owner prive = players(GetCode(Scr)) ProcLabel = True Quality = FastSymbol(rest$, "!") If Not IsStrExp(basestack, rest$, s$) Then Exit Function frm$ = Replace(s$, ChrW(&HFFFFF8FB), ChrW(&H2007)) s$ = vbNullString X = 0 If FastSymbol(rest$, ",") Then If Not IsStrExp(basestack, rest$, s$) Then If TypeOf Scr Is GuiM2000 Then If Len(prive.FontName) > 0 Then s$ = prive.FontName Else s$ = Scr.Controls(1).FontName End If Else s$ = prive.FontName End If End If If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, X) Then If TypeOf Scr Is GuiM2000 Then If Len(prive.FontName) > 0 Then X = prive.SZ Else X = Scr.Controls(1).FontSize End If Else X = prive.SZ End If Else If Scr Is Form1.PrinterDocument1 Then X = X * szFactor End If End If Y = 0 If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, p) Then p = 0 If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, sy) Then nPlain basestack, frm$, s$, X, Y, CLng(-p - 1), Quality, CLng(sy \ DXP) Else nPlain basestack, frm$, s$, X, Y, CLng(-p - 1), Quality End If Else nPlain basestack, frm$, s$, X, Y, CLng(-p - 1), Quality End If Else nPlain basestack, frm$, s$, X, Y, -1, Quality End If Else nPlain basestack, frm$, s$, X, 0, -1, Quality End If Else nPlain basestack, frm$, prive.FontName, prive.SZ, X, -1, Quality End If PlaceBasket Scr, prive End Function Function ProcLegend(basestack As basetask, rest$) As Boolean Dim s$, frm$, p As Variant, X As Double, Y As Double, sx As Double, sy As Double Dim Scr As Object, prive As basket Set Scr = basestack.Owner prive = players(GetCode(Scr)) ProcLegend = True If FastSymbol(rest$, "!") Then ProcLegend = False If IsStrExp(basestack, rest$, s$, False) Then If InStr(s$, ChrW(&HFFFFF8FB)) > 0 Then s$ = Replace(s$, ChrW(&HFFFFF8FB), ChrW(&H2007)) ProcLegend = True If Not FastSymbol(rest$, ",") Then ProcLegend = False: Exit Function If IsExp(basestack, rest$, p) Then X = p If Not FastSymbol(rest$, ",") Then Y = 1 ElseIf Not IsExp(basestack, rest$, Y) Then ProcLegend = False: Exit Function End If Else X = prive.mX If Not FastSymbol(rest$, ",") Then ProcLegend = False: Exit Function If Not IsExp(basestack, rest$, Y) Then ProcLegend = False: Exit Function End If wPlain Scr, prive, s$, (X), Y - 1 End If Else If Not IsStrExp(basestack, rest$, s$, False) Then Exit Function frm$ = Replace(s$, ChrW(&HFFFFF8FB), ChrW(&H2007)) s$ = vbNullString X = 0 If FastSymbol(rest$, ",") Then If Not IsStrExp(basestack, rest$, s$, False) Then Exit Function End If If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, X) Then Exit Function If basestack.toprinter Then If szFactor = 0 Then InternalError: Exit Function X = X * szFactor End If End If If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, Y) Then Exit Function If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, p) Then Exit Function If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, sx) Then Exit Function If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, sy) Then Exit Function nPlain basestack, frm$, s$, X, Y, CLng(p), sx <> False, CLng(sy \ DXP) Else nPlain basestack, frm$, s$, X, Y, CLng(p), sx <> False End If Else nPlain basestack, frm$, s$, X, Y, CLng(p) End If Else nPlain basestack, frm$, s$, X, Y End If Else nPlain basestack, frm$, s$, X End If End If If FastSymbol(rest$, ";") Then ''NO REFRESH Else If Not extreme Then If Not basestack.toprinter Then MyRefresh basestack ' MyDoEvents1 Scr End If PlaceBasket Scr, prive End Function Function ExecuteEmfBlock(basestack As basetask, rest$, it As Long, ww, hh) As Object Dim mDC As New MetaDc, Scr As Object, prive As basket Dim oldprintFlag As Boolean, bNo&, nd&, OldGDILines As Boolean, once As Boolean Set Scr = basestack.Owner bNo = GetCode(Scr) prive = players(bNo) oldprintFlag = basestack.toprinter If oldprintFlag Then basestack.toprinter = False Dim www As Long, hhh As Long, type1 As Boolean type1 = (ww = 0) And (hh = 0) www = ww hhh = hh mDC.create prive.mypen, www, hhh ww = www hh = hhh prive.IamEmf = True Set mDC.Font = Scr.Font GetCode mDC players(mDC.prive) = prive With players(mDC.prive) If ww <> 0 Then .MAXXGRAPH = CLng(ww) If hh <> 0 Then .MAXYGRAPH = CLng(hh) mDC.Width = .MAXXGRAPH mDC.Height = .MAXYGRAPH .curPos = 0 .currow = 0 .XGRAPH = 0 .YGRAPH = 0 End With Set basestack.Owner = mDC SetText mDC If Not TaskMaster Is Nothing Then If TaskMaster.Processing Or TaskMaster.QueueCount <> 0 Then TaskMaster.StopProcess End If End If Call Module10.executeblock(it, basestack, rest$, False, once, , True) If it = 2 Then If rest$ = "" Then If once Then rest$ = ": Break": If trace Then WaitShow = 2: TestShowSub = vbNullString Else rest$ = ": Goto " + rest$ If trace Then WaitShow = 2: TestShowSub = rest$ End If it = 1 End If players(mDC.prive) = Zero players(mDC.prive).used = False Set basestack.Owner = Scr If it = 0 Then MyEr "Problem in drawing", "Πρόβλημα στο σχέδιο" End If Set ExecuteEmfBlock = mDC.getEmfObj(type1) If oldprintFlag Then basestack.toprinter = True If Not TaskMaster Is Nothing Then If TaskMaster.Processing Or TaskMaster.QueueCount <> 0 Then TaskMaster.StartProcess End If End If End Function Function ProcLayer(basestack As basetask, rest$) As Boolean Dim i As Long, p As Variant, x1 As Long, y1 As Long, X As Double, Y As Double Dim s$, f As Long, pa$, sx As Double, it As Long, w3 As Long, ya As Long, AddTwipsTopL As Long Dim Scr As Object, scr1 As Object, nd&, oldprintFlag As Boolean, oldBackFlag As Boolean Dim prive As basket, orig As Long Set Scr = basestack.Owner prive = players(GetCode(Scr)) ' backup If lookOne(rest$, "{") Then prive = players(0) p = 0 ' dis Set basestack.lastobj = Nothing ElseIf Not IsExp(basestack, rest$, p) Then MyEr "Missing the code part", "Λείπει μπλοκ κώδικα" Exit Function End If oldprintFlag = basestack.toprinter If oldprintFlag Then basestack.toprinter = False oldBackFlag = basestack.toback If oldBackFlag Then basestack.toback = False ProcLayer = True If basestack.lastobj Is Nothing Then If p > 32 Or p < 0 Then p = 0 ' dis Else If IsObjmHandler(basestack.lastobj) Then i = basestack.lastobj.indirect If i >= 0 And i <= var2used Then If MyIsObject(var(i)) Then Set scr1 = var(i) p = GetCode(scr1) If TypeOf scr1 Is GuiM2000 Then ElseIf TypeOf scr1 Is GuiImage Then Set scr1 = Scr.pbox scr1.Tag = CLng(p) End If If p = 0 Then Set scr1 = Nothing End If Else Set scr1 = Nothing p = 0 End If End If Else Set scr1 = basestack.lastobj p = GetCode(scr1) If TypeOf scr1 Is GuiM2000 Then ElseIf TypeOf scr1 Is GuiImage Then Set scr1 = scr1.pbox scr1.Tag = CLng(p) End If If p = 0 Then Set scr1 = Nothing End If End If End If Set basestack.lastobj = Nothing w3 = basestack.tolayer basestack.tolayer = CLng(p) If lookOne(rest$, "{") Then If p > 32 Then If players(p).MAXXGRAPH = 0 Then SetTextBasketBack scr1, players(0) If TypeOf scr1 Is VB.PictureBox Then scr1.Cls End If SetText scr1, prive.MineLineSpace, True With players(p) .ShowCaret = False .italics = False .bold = False .curPos = 0 .currow = 0 .mysplit = 0 .osplit = 0 .XGRAPH = 0 .YGRAPH = 0 .lastprint = True .Paper = Form1.DIS.BackColor .mypen = players(0).mypen .mypentrans = players(0).mypentrans .ReportTab = ReportTabWidth End With With Prefresh(p) Call GetSystemTimeAsFileTime(basictimer) .k1 = basictimer + REFRESHRATE: .RRCOUNTER = 1 End With scr1.BackColor = Form1.DIS.BackColor scr1.currentX = 0 scr1.currentY = 0 End If ElseIf p > 0 Then f = FindSpriteByTag(CLng(p)) If f = 0 Then f = GetNewLayerObj(CLng(p), Scr.Width, Scr.Height) SetTextBasketBack Form1.dSprite(f), prive ' load form prive to dSprite With players(p) Form1.dSprite(f).Font.Italic = .italics Form1.dSprite(f).Font.bold = .bold End With SetText Form1.dSprite(f), prive.MineLineSpace, True 'load Players() with first values With players(p) .curPos = 0 .currow = 0 .mysplit = 0 .osplit = 0 .Paper = Form1.DIS.BackColor .mypen = players(0).mypen .mypentrans = players(0).mypentrans .ReportTab = ReportTabWidth End With With Prefresh(p) Call GetSystemTimeAsFileTime(basictimer) .k1 = basictimer + REFRESHRATE: .RRCOUNTER = 1 End With Form1.dSprite(f).BackColor = Form1.DIS.BackColor End If orig = p p = f End If If p = 0 Then Set basestack.Owner = Form1.DIS ElseIf p < 33 Then Set basestack.Owner = Form1.dSprite(p) Else Set basestack.Owner = scr1 End If nd& = basestack.addlen it = Execute(basestack, rest$, False, True, , True) basestack.addlen = nd& If it = 2 Then If rest$ = "" Then rest$ = ": Break": If trace Then WaitShow = 2: TestShowSub = vbNullString Else rest$ = ": Goto " + rest$ If trace Then WaitShow = 2: TestShowSub = rest$ End If it = 1 End If MyDoEvents2 basestack.Owner GdiFlush basestack.tolayer = w3 Set basestack.Owner = Scr If it = 0 Then ProcLayer = False End If End If If oldprintFlag Then basestack.toprinter = True If oldBackFlag Then basestack.toback = True End Function Function blockStringAhead(s$, pos1 As Long) As Long Dim i As Long, j As Long, c As Long c = Len(s$) i = pos1 If i > c Then blockStringAhead = c: Exit Function Do Select Case AscW(Mid$(s$, i, 1)) Case 34 Do While i < c i = i + 1 If AscW(Mid$(s$, i, 1)) = 34 Then Exit Do If AscW(Mid$(s$, i, 1)) = 13 Then Exit Do Loop Case 123 j = j - 1 Case 125 j = j + 1: If j = 0 Then Exit Do End Select i = i + 1 Loop Until i > c If j = 0 Then pos1 = i blockStringAhead = True Else blockStringAhead = False End If End Function Function ProcEdit(basestack As basetask, rest$, Lang As Long) As Boolean Dim s$, x1 As Long, y1 As Long, o As Long, frm$, i As Long, par As Boolean, p As Variant Dim Scr As Object, ss$, prev$ ProcEdit = True If FastSymbol(rest$, "!") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then EditTabWidth = Abs(p) If Not FastSymbol(rest$, ",") Then Exit Function End If ProcEdit = False Exit Function End If If Not (basestack.IamChild Or basestack.IamAnEvent) Then abt = False: mHelp = False: lastAboutHTitle = vbNullString Set Scr = basestack.Owner If Left$(Typename(Scr), 3) = "Gui" Then oxiforforms: Exit Function If TypeOf basestack.Owner Is MetaDc Then oxiforMetaFiles: Exit Function Form1.EditTextWord = False ' edit code Form1.TEXT1.TabWidth = EditTabWidth Form1.TabControl = EditTabWidth s$ = aheadstatus(rest$, False, y1) If y1 > 2 And Left$(s$, 1) = "S" Then If Mid$(rest$, y1 - 1, 1) = "(" Or Mid$(rest$, y1 - 2, 2) = "()" Then s$ = "ok" End If If Left$(s$, 1) = "S" Then If IsStrExp(basestack, rest$, s$) Then If s$ <> "" Then If ExtractPath(s$) = vbNullString Then If CFname(s$) <> "" Then s$ = CFname(s$) ElseIf mylcasefILE(s$) = ExtractName(s$, True) Then s$ = mcd + s$ End If If ExtractType(s$) = vbNullString Then MyEr "missing file type (.gsb or .txt or .gm2)", "δεν υπάρχει τύπος αρχείου (.gsb η .txt η .gm2)" Set Scr = Nothing Exit Function End If End If s$ = ExtractPath(s$) + ExtractName(s$, True) If Dir$(ExtractPath(s$), vbDirectory) = vbNullString Then MyEr "wrong path to save", "λάθος τόπος για σώσιμο" Set Scr = Nothing Exit Function ElseIf ExtractName(s$, True) = vbNullString Then MyEr "missing file name", "χάθηκε το όνομα αρχείου" Set Scr = Nothing Exit Function End If Dim oldclid As Long oldclid = Clid If CFname(s$) <> "" Then s$ = CFname(s$) frm$ = ReadUnicodeOrANSI(s$, True, x1) ' CHECK TO SEE IF THIS IS A PASSWORD PROTECTED PROGRAMM For i = 1 To Len(frm$) If AscW(Mid$(frm$, i, 1)) < 128 Then Exit For End If Next i If i > Len(frm$) Then If Lang = 1 Then MsgBoxN "not text found", 0 Else MsgBoxN "δεν βρήκα κείμενο", 0 End If Set Scr = Nothing Exit Function End If par = x1 = 3 Else frm$ = vbNullString par = False End If Form1.EditTextWord = LCase(ExtractType(s$)) <> "gsb" Form1.TEXT1.Title = ExtractName(s$, True) + " " If x1 = 0 Then x1 = -5 Form1.TEXT1.glistN.UseTab = UseTabInForm1Text1 If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p) Then o = CLng(p) End If End If If o < 1 Then o = 0 If o > Len(frm$) Then o = Len(frm$) + 1 With players(GetCode(basestack.Owner)) ScreenEdit basestack, frm$, 0, .mysplit, .mX - 1, .mY - 1, o, x1 End With If frm$ <> "" And Abs(x1) >= 0 And Not CancelEDIT Then If par Then i = FreeFile If Not WeCanWrite(s$) Then Set Scr = Nothing: Exit Function On Error Resume Next Open GetDosPath(s$) For Output As i If Err.Number > 0 Then Err.Clear MyEr "Bad filename", "Λάθος στο όνομα αρχείου" Set Scr = Nothing Exit Function End If Print #i, frm$; Close i Else par = SaveUnicode(s$, frm$, x1) End If End If End If Set Scr = Nothing Clid = oldclid Exit Function Else Set Scr = Nothing Exit Function End If End If If s$ <> "" Then x1 = Abs(IsLabel(basestack, rest$, s$)) If x1 > 0 Then If x1 > 3 Then s$ = Replace$(s$, "(", "") If FastSymbol(rest$, ")") Then End If s$ = s$ + "()" End If Else Set Scr = Nothing Exit Function End If MakeThisSub basestack, s$ 'NO GOOD.. If GetSub(s$, x1) Then p = x1 If sbf(x1).locked Then GoTo jump11 End If jump1: If x1 < lckfrm And lckfrm <> 0 Then jump11: MyEr s$ + " is locked", s$ + " είναι κλειδωμένο" ProcEdit = False Set Scr = Nothing Exit Function End If If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then y1 = Abs(IsLabel(basestack, rest$, frm$)) If y1 <> 0 Then GetSub frm$, x1 If x1 = 0 Then If y1 > 3 Then frm$ = frm$ + ")" If FastSymbol(rest$, ")") Then End If End If GetSubFullName s$, ss$ If ss$ <> Mid$(frm$, Len(ss$) - Len(s$) + 1) Then Check2SaveModules = True subHash.RenameKey ss$, Mid$(frm$, Len(ss$) - Len(s$) + 1) x1 = p sbf(x1).goodname = subHash.LastKnown End If End If End If Set Scr = Nothing Exit Function ElseIf FastSymbol(rest$, ",") Then i = 1 If IsExp(basestack, rest$, p) Then i = Int(p) If i < 0 Then i = Len(sbf(x1).sb) + i If i < 0 Then i = 0 If i > Len(sbf(x1).sb) Then i = Len(sbf(x1).sb) + 1 End If sbf(x1).sbc = i End If If sbf(x1).sbc = 0 Then sbf(x1).sbc = -1 MakeMyTitle s$, Lang Form1.TEXT1.glistN.UseTab = UseTabInForm1Text1 With players(GetCode(basestack.Owner)) prev$ = sbf(x1).sb ScreenEdit basestack, prev$, 0, .mysplit, .mX - 1, .mY - 1, sbf(x1).sbc, , , , True End With With sbf(x1) If prev$ <> .sb Then Set .subs = Nothing Set .Pad = Nothing .sb = prev$ Check2SaveModules = True End If End With If i <> 0 Then If pagio$ = "GREEK" Then FK$(13) = "@Σ " & s$ & "," & (i) Else FK$(13) = "@EDIT " & s$ & "," & (i) End If Else If pagio$ = "GREEK" Then FK$(13) = "@Σ " & s$ Else FK$(13) = "@EDIT " & s$ End If End If Form1.StoreBookMarks Else If InStr(s$, ".") > 0 Then frm$ = s$ s$ = GetStrUntil(".", frm$) If GetSub(s$, x1) Then GoTo jump1 End If End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, , True) Then End If End If i = -1 MakeMyTitle s$, Lang Form1.TEXT1.glistN.UseTab = UseTabInForm1Text1 With players(GetCode(basestack.Owner)) ScreenEdit basestack, frm$, 0, .mysplit, .mX - 1, .mY - 1, i ', , , , Len(frm$) = 0 End With If frm$ <> "" Then MakeThisSub basestack, s$ If here$ = vbNullString And InStr(s$, "(") = 0 Then x1 = GlobalSub(s$, frm$, , s$) Else x1 = ModuleSub(s$, frm$) End If Check2SaveModules = True If x1 <> 0 Then sbf(x1).sbc = i: Set sbf(x1).subs = Nothing: Set sbf(x1).Pad = Nothing FK$(13) = "@EDIT " & s$ & "," & (i) Else FK$(13) = "@EDIT " & s$ End If End If ElseIf Not (basestack.IamChild Or basestack.IamAnEvent) Then Form1.TEXT1.glistN.UseTab = False frm$ = Mid$(Replace$(QUERYLIST, vbCr, vbCrLf), 3) Form1.ShadowMarks = True If UserCodePage = 1253 Then Form1.TEXT1.Title = "Λίστα εντολών " Else Form1.TEXT1.Title = "Command List " End If With players(GetCode(basestack.Owner)) ScreenEdit basestack, frm$, 0, .mysplit, .mX - 1, .mY - 1 End With Form1.ShadowMarks = False Form1.StoreBookMarks QUERYLIST = vbCr + Replace$(frm$, vbCrLf, vbCr) End If End Function Function ProcModuleEntry(basestack As basetask, ohere$, x1 As Long, rest$, Optional Lang As Long = -1, Optional thisIsEvent As Boolean = False) As Boolean On Error GoTo there22 If LastErNum = -1 Then GoTo there22 Dim bs As basetask, loopthis As Boolean Dim subs As Long, snames As Long, Vname As Long Dim i As Long, p As Long, S3 As Long, bb$, pa$, small$, sbi As Long Dim EXITNOW As Boolean Dim restart As Boolean Dim backup$, TSHB As Boolean If trace Then SwapStrings backup$, TestShowSub: TSHB = TestShowBypass TestShowBypass = False 'LastErName = VbNullString: LastErNameGR = VbNullString If CurrentStackSize > stacksize Then MyEr "Function's Stack is Full - 15", "Η στοίβα των συναρτήσεων έχει γεμίσει - 15" ProcModuleEntry = False: here$ = ohere$ GoTo modfun End If ' ******************************************* module entry.............. If x1 = 0 Then x1 = basestack.callx1: ohere$ = basestack.callohere: basestack.callx1 = 0 i = 1 Set bs = New basetask With bs .ByName = basestack.ByName .IamAnEvent = thisIsEvent Set .Parent = basestack Set .Sorosref = basestack.soros 'same stack Set .Owner = .Parent.Owner .originalname$ = ohere$ .SetV2 Vname = .Vname .ErrVars = .Vars basestack.ByName = 0 .ByName = 0 .commnum = comhash.Count .strfunnum = strfunid.Count .numfunnum = funid.Count .strnum = strid.Count .numnum = numid.Count If sbf(x1).sbc Then numid.pushtopGlobal funid.pushtopGlobal strfunid.pushtopGlobal strid.pushtopGlobal Else numid.pushtop funid.pushtop strfunid.pushtop strid.pushtop End If subs = sb2used: snames = subHash.Count .UseGroupname = sbf(x1).sbgroup .tpointer = sbf(x1).tpointer .OriginalCode = x1 If Not basestack.StaticCollection Is Nothing Then StaticWork basestack, bs, here$ End If .StaticInUse$ = here$ End With If SecureNames Then If basestack.IamThread Then here$ = str$(basestack.Process.id) + here$ Mid$(here$, 1, 1) = "_" End If End If If Lang <> -1 Then If IsSymbol(rest$, ";") Then Do If IsLabel(basestack, rest$, small$, True) = 1 Then If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then If Abs(IsLabelBig(basestack, rest$, pa$)) <> 1 Then GoTo myerror1 MakeThisSub1 basestack, pa$ Else pa$ = small$ End If If subHash.Find(ohere$ + "." + pa$, i) Then MyModule bs, small$ + " {}", Lang sbf(bs.IndexSub).locked = True sbf(bs.IndexSub).sb = sbf(i).sb sbf(bs.IndexSub).sbc = sbf(i).sbc sbf(bs.IndexSub).sbgroup = sbf(i).sbgroup ElseIf subHash.Find(pa$, i) Then MyModule bs, small$ + " {}", Lang sbf(bs.IndexSub).locked = True sbf(bs.IndexSub).sb = sbf(i).sb sbf(bs.IndexSub).sbc = sbf(i).sbc sbf(bs.IndexSub).sbgroup = sbf(i).sbgroup End If End If Loop Until Not IsSymbol(rest$, ",") End If End If i = 1 'If checkbreakEsc(bs) Then ' ProcModuleEntry = False: GoTo modfun 'End If restart = True S3 = x1 Do bb$ = Mid$(sbf(S3).sb, i) againmod: If LastErNum = -1 Then If bs.SubLevel > 0 Then GoTo unwindstack GoTo myerror1 End If EXITNOW = False Select Case Execute(bs, bb$, EXITNOW, False, loopthis, , restart) Case 0 myerror1: If bs.ErrorOriginal = 0 Then If sbi > 0 Then bb$ = bb$ + space$(sbi) If MOUT And Not NOEXECUTION Then MOUT = False rest$ = vbNullString: MyEr "", "" Exit Do End If If sb2used <> 0 And Not NERR Then If Len(bs.UseGroupname) > 0 Then If InStr(bs.UseGroupname, ChrW(&H1FFF)) > 0 Then pa$ = GetNextLine((sbf(Abs(bs.OriginalCode)).sb)) FK$(13) = Mid$(pa$, 7) & "-" & (Len(bb$)) MyErMacro rest$, "Problem in class in module " + GetName(here$), "Πρόβλημα στη κλάση στο τμήμα " + GetName(here$) ProcModuleEntry = True GoTo thh1 End If End If If bs.ErrorOriginal > 0 Then If bs.ErrorOriginal <> bs.OriginalCode Then If Left$(bb$, 10) <> ": Error -1" Then bb$ = ": Error -1 " + bb$ If bs.IamChild Then If bs.Parent.OriginalCode <> bs.ErrorOriginal Then bs.Parent.ErrorOriginal = bs.ErrorOriginal rest$ = bb$: ProcModuleEntry = False GoTo th0 End If End If pa$ = "EDIT " + GetModuleName(bs, here$) + "," + str$(Len(sbf(x1).sb) + 1) If ohere$ <> "" Then With sbf(x1) If Left$(.sb, 10) = "'11001EDIT" Then pa$ = Mid$(GetNextLine(.sb), 7) .sb = Mid$(.sb, 3) Set .subs = Nothing Set .Pad = Nothing If SecureNames Then MyEr "in module " + Replace(GetModuleName(bs, here$), ChrW(&HFFBF), ""), "στο τμήμα " + Replace(GetModuleName(bs, here$), ChrW(&HFFBF), "") Else MyEr "in module " + Replace(GetName(ohere$) + "." + GetName(here$), ChrW(&HFFBF), ""), "στο τμήμα " + Replace(GetName(ohere$) + "." + GetName(here$), ChrW(&HFFBF), "") End If Else MyEr "in module " + Replace(GetName(.goodname), ChrW(&HFFBF), ""), "στο τμήμα " + Replace(GetName(.goodname), ChrW(&HFFBF), "") End If End With Else If here$ = vbNullString Then MyEr "in command prompt", "στην εισαγωγή εντολών" Else MyEr "in module " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), ""), "στο τμήμα " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), "") End If End If If InStr(FK$(13), ",") > 0 Then GoTo thh End If If (Len(sbf(x1).sb) - Len(bb$)) < 0 Then FK$(13) = pa$ Else DropLeft ",", FK$(13) If FK$(13) <> "" Then FK$(13) = "+" + FK$(13) FK$(13) = pa$ + str$(-Len(bb$)) + FK$(13) End If Else If sb2used > 0 Then MyEr "in module " + GetName(here$), "στο τμημα " + GetName(here$) Else MyEr "", "" End If End If th0: bs.UseofIf = 0 GoTo thh Case 1, 3 thh: TestShowBypass = False If bs.IamChild Then If Not bs.soros Is bs.Parent.soros Then Set bs.Parent.Sorosref = bs.soros End If End If If LastErNum <> 0 And bs.ErrorOriginal = 0 Then rest$ = vbNullString bs.UseofIf = 0 End If If Not EXITNOW Then If bs.UseofIf > 0 Then MissENDIF: ProcModuleEntry = False thh1: On Error Resume Next If basestack Is Nothing Then Set basestack = Basestack1 End If If Not basestack.CopyInOutCol Is Nothing Then CopyBack basestack With bs .ThrowThreads MOUT = False var2used = .Vars varhash.ReduceHash Vname, var() If UBound(var()) <> varhash.MaxSpace Then ReDim Preserve var(varhash.MaxSpace) As Variant End If sb2used = subs subHash.ReduceHash snames, sbf() If UBound(sbf()) <> subHash.MaxSpace Then ReDim Preserve sbf(subHash.MaxSpace) As modfun End If If .commnum <> comhash.Count Then comhash.ReduceHash2 .commnum If .numfunnum <> funid.Count Then funid.ReduceHash .numfunnum If .strfunnum <> strfunid.Count Then strfunid.ReduceHash .strfunnum If .strnum <> strid.Count Then strid.ReduceHash .strnum If sbf(x1).sbc Then numid.poptopGlobal funid.poptopGlobal strfunid.poptopGlobal strid.poptopGlobal Else numid.poptop funid.poptop strfunid.poptop strid.poptop End If End With Set bs = Nothing here$ = ohere$ Exit Do Case 2 i = 1 If Len(bb$) <> 0 Then If bb$ = ChrW$(0) Then If trace Then TestShowBypass = False unwindstack: If Not bs.IsInRetStackString(small$) Then p = bs.isPop3Long(S3, sbi) If p > 0 Then If S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) Else ' lambda object in var(-S3) bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If End If bs.addlen = sbi End If PopStage bs GoTo againmod Else fulty: MyEr "Fault in Return", "Λάθος στην Επιστροφή" bs.Flush Exit Do End If Else If InStr(small$, " ") > 0 Then bs.PushSecondThird S3, sbi If searchsub(0&, x1, small$, i, S3, bb$) Then bs.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead7(bs, small$, 1) Then bb$ = " " GoTo myerror1 End If End If GoTo contSub ElseIf basestack.IamChild Then ' maybe I use this line not above If searchsub(x1, FindPrevOriginal(bs), small$, i, S3, bb$) Then bs.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead7(bs, small$, 1) Then ' do nothing ? why End If End If contSub: If Len(bb$) = 0 Then If S3 < 0 Then bb$ = Mid$(var(-S3).Code, i) Else bb$ = Mid$(sbf(S3).sb, i) End If sbi = 0 Else If S3 < 0 Then sbi = Len(var(-S3).Code) - i - Len(bb$) + 1 Else sbi = Len(sbf(S3).sb) - i - Len(bb$) + 1 End If End If If LastErNum = -1 Then GoTo unwindstack End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If End If bs.addlen = Len(TestShowSub) - i + 1 - Len(bb$) End If GoTo againmod Else therebad: If bs.callx1 < 0 Then bs.callx1 = 0 small$ = Split(small$, " ")(1) small$ = Left$(small$, Len(small$) - 1) 'If Not bs.IsDecimal Then If bs.LastIdpos > 0 Then rest$ = Right$(sbf(S3).sb, bs.LastIdpos) End If unknownModule rest$, small$ Else If Len(Split(small$, " ")(0)) = 1 Then small$ = Split(small$, " ")(1) unknownLabel rest$, small$ Else small$ = Split(small$, " ")(1) unknownSub rest$, Left$(small$, Len(small$) - 1) End If End If If bs.IsDecimal Then p = bs.Pop3Long(S3, sbi) If bs.LastIdpos > 0 Then bb$ = Right$(sbf(S3).sb, bs.LastIdpos) ElseIf S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If End If bs.LastIdpos = 0 bs.RetStackDrop 3 bs.SubLevel = bs.SubLevel - 1 GoTo myerror1 End If Else GoTo therebad End If End If End If ElseIf bb$ = "BREAK" Then GoTo thh1 Else If sbf(S3).subs Is Nothing Then Set sbf(S3).subs = New FastCollection End If If sbf(S3).subs.ExistKey(bb$) Then If IsNumeric(sbf(S3).subs.Value) Then i = sbf(S3).subs.Value x1 = S3 Else i = val(Split(sbf(S3).subs.Value)(0)) x1 = val(Split(sbf(S3).subs.Value)(1)) End If Else If InStr(bb$, vbCr) > 0 Then i = rinstr(sbf(S3).sb, bb$) If i = 0 Then i = Len(sbf(S3).sb) + 1 Else i = PosLabel(bb$, sbf(S3).sb) If i = 0 Or i > Len(sbf(S3).sb) Then rest$ = Right$(sbf(S3).sb, bs.LastIdpos - 1 - Len(bb$)) bs.LastIdpos = 0 unknownLabel rest$, bb$ SwapStrings rest$, bb$ GoTo myerror1 End If End If sbf(S3).subs.AddKey bb$, i If bs.UseofIf > 0 Then If HaveMark2(bs) Then bs.UseofIf = bs.UseofIf - 1 End If End If x1 = S3 End If If trace Then bs.addlen = 0 TestShowBypass = True TestShowSub = sbf(S3).sb End If If bs.SubLevel > 0 Then If x1 = S3 Then If Len(sbf(S3).sb) - i > sbi Then bb$ = Mid$(sbf(S3).sb, i, Len(sbf(S3).sb) - i - sbi) GoTo againmod Else sbi = 0 End If Else sbi = 0 End If Else sbi = 0 End If End If Else If Not loopthis Then GoTo thh1 loopthis = False End If Case 12 MyEr "Exit for out of for next loop", "Έξοδος για έξω από Για Επόμενο" Exit Do End Select If Not restart Then restart = True bs.IFCTRL = False bs.jump = False If bs.RetStackTotal > 0 Then bs.UseofIf = 0 bs.Flush End If End If Loop ProcModuleEntry = True modfun: If trace Then SwapStrings backup$, TestShowSub: TestShowBypass = TSHB Exit Function there22: If Err Then MyEr Err.Description, Err.Description Err.Clear If Not bs Is Nothing Then GoTo thh End If GoTo modfun End Function Function PushParamGeneralV70(basestack As basetask, rest$, rest1$) As Boolean Dim ps As mStiva Set ps = NewmStiva If Len(rest1$) > 0 Then If lookOne(rest1$, ")") Then PushParamGeneralV70 = True: GoTo conthere If Not PushParamGeneralV7(basestack, rest1$, ps) Then Exit Function End If If Len(rest$) > 0 Then If lookOne(rest$, ")") Then PushParamGeneralV70 = True: GoTo conthere If Not PushParamGeneralV7(basestack, rest$, ps) Then Exit Function End If conthere: PushParamGeneralV70 = True With basestack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps End If End With End Function Private Function PushParamSUB(basestack As basetask, rest$) As Boolean PushParamSUB = True Dim ps As mStiva, p As Variant, s$, usehandler As mHandler, usestiva As mStiva Dim what As Integer, W$, u1 As Long, flag As Boolean Set ps = NewmStiva Set basestack.lastobj = Nothing Do If FastSymbol(rest$, "?") Then ps.DataOptional ElseIf FastSymbol(rest$, "!") Then If IsExp(basestack, rest$, p, nostring:=True) Then If basestack.lastobj Is Nothing Then ps.DataValLong p ElseIf TypeOf basestack.lastobj Is mHandler Then Set usehandler = basestack.lastobj If TypeOf usehandler.objref Is mStiva Then ps.MergeBottom usehandler.objref ElseIf TypeOf usehandler.objref Is iBoxArray Then ps.MergeBottomCopyArray usehandler.objref Else PushParamSUB = False MyEr "Expected Stack Object after !", "Περίμενα αντικείμενο τύπου Σωρού μετά το !" Set basestack.lastobj = Nothing Exit Function End If Set usehandler.objref = Nothing ElseIf TypeOf basestack.lastobj Is iBoxArray Then ps.MergeBottomCopyArray basestack.lastobj End If Set basestack.lastobj = Nothing End If Else u1 = 1 aheadstatusNew rest$, u1, flag If u1 > 1 Then If Mid$(rest$, u1, 2) = ":=" Then s$ = Left$(rest$, u1 - 1) what = IsPureLabel(s$, W$) If what < 5 Then If Len(Trim$(s$)) <> 0 Then SyntaxError PushParamSUB = False Exit Function Else W$ = myUcase(W$, True) Select Case W$ Case "LIST", "QUEUE", "STACK", "ΛΙΣΤΑ", "ΟΥΡΑ", "ΣΩΡΟΣ" Case Else Mid$(rest$, 1, u1 + 1) = space$(u1 + 1) If ConstNewParam(basestack, rest$, W$) Then GoTo nextparam End If GoTo Err1 End Select End If End If End If End If aa1: If IsExp(basestack, rest$, p) Then If Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is mStiva Then Set usestiva = basestack.lastobj ps.MergeBottom usestiva Set usestiva = Nothing ElseIf Not basestack.lastpointer Is Nothing Then ps.DataObj basestack.lastobj Set basestack.lastpointer = Nothing ElseIf Not basestack.lastobj Is Nothing Then ps.DataObj basestack.lastobj End If Set basestack.lastobj = Nothing Else If myVarType(p, vbString) Then SwapString2Variant s$, p ps.DataStr s$ Else ps.DataVal p End If End If ElseIf Not LastErNum <> 0 Then If IsStrExp(basestack, rest$, s$, False) Then ' Len(basestack.tmpstr) = 0 If Not basestack.lastpointer Is Nothing Then ps.DataObj basestack.lastobj Set basestack.lastpointer = Nothing ElseIf Not basestack.lastobj Is Nothing Then ps.DataObj basestack.lastobj Else ps.DataStr s$ End If Set basestack.lastobj = Nothing ElseIf lookOne(rest$, ",") Then ps.DataOptional End If Else If LastErNum <> 0 Then PushParamSUB = False Exit Do End If End If If LastErNum <> -2 And LastErNum <> 0 Then Err1: MyEr "Error in input list", "Πρόβλημα στις παραμέτρους" PushParamSUB = False Exit Do End If End If nextparam: If Not FastSymbol(rest$, ",") Then Exit Do Loop With basestack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps ps.Recycle End If End With End Function Private Function PushParamGeneralV7(basestack As basetask, rest$, ps As mStiva) As Boolean PushParamGeneralV7 = True Dim p As Variant, s$, usehandler As mHandler, usestiva As mStiva Dim ParentStack As basetask Set ParentStack = basestack.Parent Set ParentStack.lastobj = Nothing Do If FastSymbol(rest$, "?") Then ps.DataOptional ElseIf FastSymbol(rest$, "!") Then If IsExp(ParentStack, rest$, p) Then If ParentStack.lastobj Is Nothing Then ps.DataValLong p ElseIf TypeOf ParentStack.lastobj Is mHandler Then Set usehandler = ParentStack.lastobj If TypeOf usehandler.objref Is mStiva Then ps.MergeBottom usehandler.objref ElseIf TypeOf usehandler.objref Is iBoxArray Then ps.MergeBottomCopyArray usehandler.objref Else PushParamGeneralV7 = False MyEr "Expected Stack Object after !", "Περίμενα αντικείμενο τύπου Σωρού μετά το !" Set ParentStack.lastobj = Nothing ParentStack.modfuncall = False Exit Function End If Set usehandler.objref = Nothing ElseIf TypeOf ParentStack.lastobj Is iBoxArray Then ps.MergeBottomCopyArray ParentStack.lastobj End If Set ParentStack.lastobj = Nothing End If ElseIf IsExp(ParentStack, rest$, p) Then If Not ParentStack.lastobj Is Nothing Then If TypeOf ParentStack.lastobj Is mStiva Then Set usestiva = ParentStack.lastobj ps.MergeBottom usestiva Set usestiva = Nothing ElseIf Not ParentStack.lastpointer Is Nothing Then ps.DataObj ParentStack.lastobj Set ParentStack.lastpointer = Nothing Set ParentStack.lastobj = Nothing Else ps.DataObj ParentStack.lastobj Set ParentStack.lastobj = Nothing End If Set ParentStack.lastobj = Nothing Else If myVarType(p, vbString) Then SwapString2Variant s$, p ps.DataStr s$ Else ps.DataVal p End If End If ElseIf Not LastErNum <> 0 Then ParentStack.modfuncall = True If IsStrExp(ParentStack, rest$, s$, False) Then 'Len(ParentStack.tmpstr) = 0 If Not ParentStack.lastpointer Is Nothing Then ps.DataObj ParentStack.lastobj Set ParentStack.lastpointer = Nothing Set ParentStack.lastobj = Nothing ElseIf Not ParentStack.lastobj Is Nothing Then ps.DataObj ParentStack.lastobj Set ParentStack.lastobj = Nothing Else ps.DataStr s$ End If ElseIf lookOne(rest$, ",") Then ps.DataOptional ' here End If ParentStack.modfuncall = False Else If LastErNum <> 0 Then PushParamGeneralV7 = False Exit Do End If End If If LastErNum <> -2 And LastErNum <> 0 Then MyEr "Error in input list", "Πρόβλημα στις παραμέτρους" PushParamGeneralV7 = False End If If Not FastSymbol(rest$, ",") Then Exit Do Loop Set ParentStack = Nothing End Function Function PushParamGeneral(basestack As basetask, rest$, Optional ByVal temphere$) As Boolean PushParamGeneral = True Dim ps As mStiva, p As Variant, s$, ok As Long, usehandler As mHandler, usestiva As mStiva Set ps = NewmStiva Set basestack.lastobj = Nothing Do If FastSymbol(rest$, "%") Then p = IsLabel(basestack, rest$, s$, True) ok = 1 If p < 4 Then If p = 1 Then ExecuteVar1 ok, basestack, s$, rest$, (ok), 1, True, False, 0, "", 0, (temphere), False Else ExecuteVar3 ok, basestack, s$, rest$, (ok), 1, True, False, 0, "", 0, (temphere), False End If If ok <> 1 Then PushParamGeneral = False: basestack.modfuncall = False: Exit Function ps.DataOptional Else MyEr "Array can't pass by name", "Ο πίνακας δεν μπορεί να περάσει με όνομα" PushParamGeneral = False: basestack.modfuncall = False: Exit Function End If ElseIf FastSymbol(rest$, "?") Then ps.DataOptional ElseIf FastSymbol(rest$, "!") Then If IsExp(basestack, rest$, p) Then If basestack.lastobj Is Nothing Then ps.DataValLong p ElseIf TypeOf basestack.lastobj Is mHandler Then Set usehandler = basestack.lastobj If TypeOf usehandler.objref Is mStiva Then ps.MergeBottom usehandler.objref ElseIf TypeOf usehandler.objref Is iBoxArray Then ps.MergeBottomCopyArray usehandler.objref Else PushParamGeneral = False: basestack.modfuncall = False MyEr "Expected Stack Object after !", "Περίμενα αντικείμενο τύπου Σωρού μετά το !" Set basestack.lastobj = Nothing Exit Function End If Set usehandler.objref = Nothing ElseIf TypeOf basestack.lastobj Is iBoxArray Then ps.MergeBottomCopyArray basestack.lastobj End If Set basestack.lastobj = Nothing End If ElseIf IsExp(basestack, rest$, p) Then If Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is mStiva Then Set usestiva = basestack.lastobj ps.MergeBottom usestiva Set usestiva = Nothing ElseIf Not basestack.lastpointer Is Nothing Then ps.DataObj basestack.lastobj Set basestack.lastpointer = Nothing ElseIf Not basestack.lastobj Is Nothing Then ps.DataObj basestack.lastobj End If Set basestack.lastobj = Nothing Else If myVarType(p, vbString) Then SwapString2Variant s$, p ps.DataStr s$ Else ps.DataVal p End If End If ElseIf Not LastErNum <> 0 Then basestack.modfuncall = True If IsStrExp(basestack, rest$, s$, False) Then ' Len(basestack.tmpstr) = 0 If Not basestack.lastpointer Is Nothing Then ps.DataObj basestack.lastobj Set basestack.lastpointer = Nothing ElseIf Not basestack.lastobj Is Nothing Then ps.DataObj basestack.lastobj Else ps.DataStr s$ End If Set basestack.lastobj = Nothing ElseIf lookOne(rest$, ",") Then ps.DataOptional ' here End If basestack.modfuncall = False Else If LastErNum <> 0 Then PushParamGeneral = False Exit Do End If End If If LastErNum <> -2 And LastErNum <> 0 Then MyEr "Error in input list", "Πρόβλημα στις παραμέτρους" PushParamGeneral = False End If If Not FastSymbol(rest$, ",") Then Exit Do Loop With basestack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps ps.Recycle End If End With End Function Sub PushParamStraight(basestack As basetask, rest$) Dim p As Variant, s$ Dim ps As mStiva Set ps = basestack.soros basestack.modfuncall = True Do If IsExp(basestack, rest$, p) Then If Not basestack.lastpointer Is Nothing Then ps.DataObj basestack.lastobj Set basestack.lastpointer = Nothing Set basestack.lastobj = Nothing ElseIf Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is VarItem Then ps.DataOptional Else ps.DataObj basestack.lastobj End If Set basestack.lastobj = Nothing Else If myVarType(p, vbString) Then SwapString2Variant s$, p ps.DataStr s$ Else ps.DataVal p End If End If ElseIf IsStrExp(basestack, rest$, s$, False) Then ' Len(basestack.tmpstr) = 0 If Not basestack.lastpointer Is Nothing Then ps.DataObj basestack.lastobj Set basestack.lastpointer = Nothing Set basestack.lastobj = Nothing ElseIf Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is VarItem Then ps.DataOptional Else ps.DataObj basestack.lastobj End If Set basestack.lastobj = Nothing Else ps.DataStr s$ End If ElseIf lookOne(rest$, ",") Then ps.DataOptional ElseIf lookOne(rest$, ")") Then ps.DataOptional Else Exit Do End If If Not FastSymbol(rest$, ",") Then Exit Do Loop basestack.modfuncall = False If Not ps Is Nothing Then ps.Recycle Set ps = Nothing End Sub Function searchsub(ByVal Originalwhere As Long, ByVal where As Long, W$, Final As Long, site As Long, Code$, Optional needfunc As Boolean = False) As Boolean Dim aCopy As Document Dim EndPoint As Long Dim ww$(), vv() ww$() = Split(W$) If where = 0 Or Len(W$) = 0 Then Exit Function Else If where < 0 Then With var(-where) If .subs Is Nothing Then Set .subs = New FastCollection Else If UBound(ww$()) = 0 Then W$ = ww$(0) ElseIf needfunc Then W$ = "@" + ww$(1) Else W$ = ww$(1) End If If .subs.ExistKey(UCase(W$)) Then vv = .subs.Value Final = vv(0) site = vv(1) W$ = vv(2) Code$ = vv(3) searchsub = True Exit Function End If W$ = Join(ww$) End If End With Else With sbf(where) If .subs Is Nothing Then Set .subs = New FastCollection Else If UBound(ww$()) = 0 Then W$ = ww$(0) ElseIf needfunc Then W$ = "@" + ww$(1) Else W$ = ww$(1) End If If .subs.ExistKey(UCase(W$)) Then ' EndPoint ??????????? vv = .subs.Value Final = vv(0) site = vv(1) W$ = vv(2) Code$ = vv(3) WaitShow = 0 searchsub = True Exit Function End If W$ = Join(ww$) End If End With End If End If Dim len1 As Long, there1 As Long, a$ Dim there As Long, Curs As Long, Curs2 As Long Dim a1 As Long, b As Long, c As Long, D As Long Dim ss$, Dump$ len1 = Len(ww$(0)) If len1 = 1 Then ' looking for simple sub If ww$(0) = "S" Then ' labelname: /// return (maybe more than one labels If where > 0 Then Set aCopy = sbf(where).Pad If aCopy Is Nothing Then Set aCopy = New Document Set sbf(where).Pad = aCopy With aCopy .textDocFast = sbf(where).sb .LCID = 1032 End With End If Else Set aCopy = var(-where).Pad If aCopy Is Nothing Then Set aCopy = New Document Set var(-where).Pad = aCopy With aCopy .textDocFast = var(-where).Code$ .LCID = 1032 End With End If End If With aCopy ww$(1) = ww$(1) + ":" Dim l1 As Long l1 = Len(ww$(1)) Do While .FindIdentifier(ww$(1), False, there, Curs) If NLtrim$(Left$(.TextParagraph(there), Curs - 1)) = vbNullString Then If MaybeIsSymbol3lot(.TextParagraph(there) + Chr$(13), b123, Curs + l1) Then Final = -1 .FindPos .FirstParagraphLine(there) + 2, 1, Final, a1, b, c, D Final = Final + 1 ' because mid$ starts from 1 W$ = vbNullString searchsub = True GoTo register End If End If Loop End With Else ' looking Number ///return (maybe more than one return statements) If where > 0 Then Final = PosLabel(ww$(1), sbf(where).sb) Else Final = PosLabel(ww$(1), var(-where).Code$) End If If Final <> 1 Then If where > 0 Then If Final > Len(sbf(where).sb) Then Exit Function Else If Final > Len(var(-where).Code$) Then Exit Function End If W$ = vbNullString searchsub = True GoTo register End If End If Exit Function End If ' No we have something better 'Set aCopy = New Document Dim Count As Integer If where > 0 Then Set aCopy = sbf(where).Pad If aCopy Is Nothing Then Set aCopy = New Document Set sbf(where).Pad = aCopy With aCopy .textDocFast = sbf(where).sb .LCID = 1032 End With End If Else Set aCopy = var(-where).Pad If aCopy Is Nothing Then Set aCopy = New Document Set var(-where).Pad = aCopy With aCopy .textDocFast = var(-where).Code$ .LCID = 1032 End With End If End If With aCopy paliedo: Count = Count + 1 there = 0 Curs = 0 Do If Count > 3 Then Exit Do If .FindIdentifier(ww$(0), False, there, Curs) Then ss$ = Left$(aCopy.TextParagraph(there), Curs - 1) IsNumberLabel ss$, Dump$ If Trim$(ss$) = vbNullString Then Curs2 = Curs there1 = there If .FindIdentifier(ww$(1), True, there1, Curs2) Then If there1 <> there Then Curs = 0 Else Final = -1 .FindPos .FirstParagraphLine(there1) + 2, 1, Final, a1, b, c, D Final = Final + 1 ' because mid$ starts from 1 W$ = BlockParam(Trim(Mid$(.TextParagraph(there), Curs2 + Len(ww(1))))) searchsub = True Exit Do End If End If End If Else Select Case ww$(0) Case "ΡΟΥΤΙΝΑ": ww$(0) = "ΡΟΥΤΊΝΑ": GoTo paliedo Case "ΣΥΝΑΡΤΗΣΗ": ww$(0) = "ΣΥΝΆΡΤΗΣΗ": GoTo paliedo Case "FUNCTION": ww$(0) = "ΣΥΝΑΡΤΗΣΗ": GoTo paliedo Case "ΣΥΝΆΡΤΗΣΗ": ww$(0) = "FUNCTION": GoTo paliedo Case "ΡΟΥΤΊΝΑ": ww$(0) = "SUB": GoTo paliedo Case "SUB": ww$(0) = "ΡΟΥΤΙΝΑ": GoTo paliedo End Select Exit Do End If Loop End With register: If searchsub Then If where > 0 Then site = where sitehere: If sbf(site).subs Is Nothing Then Set sbf(site).subs = New FastCollection Code$ = vbNullString If Len(ww$(0)) > 1 Then EndPoint = Final If Not aheadstatusENDSUBorFUN(sbf(where).sb, EndPoint, -(AscW(ww$(0)) < 128), needfunc) Then If needfunc Then MisEndFunc Else MisEndSub searchsub = False Exit Function End If Code$ = Mid$(sbf(where).sb, Final, EndPoint - Final) End If If needfunc Then If Not sbf(site).subs.Find("@" + UCase(ww$(1))) Then sbf(site).subs.AddKey "@" + UCase(ww$(1)), Array(Final, where, W$, Code$) If Originalwhere > 0 Then sbf(Originalwhere).subs.AddKey "@" + UCase(ww$(1)), Array(Final, where, W$, Code$) ElseIf Originalwhere < 0 Then var(-Originalwhere).subs.AddKey "@" + UCase(ww$(1)), Array(Final, where, W$, Code$) End If End If ElseIf Not sbf(site).subs.Find(UCase(ww$(1))) Then sbf(site).subs.AddKey UCase(ww$(1)), Array(Final, where, W$, Code$) If Originalwhere > 0 Then sbf(Originalwhere).subs.AddKey UCase(ww$(1)), Array(Final, where, W$, Code$) ElseIf Originalwhere < 0 Then var(-Originalwhere).subs.AddKey UCase(ww$(1)), Array(Final, where, W$, Code$) End If End If ElseIf where < 0 Then site = where sitethere: If var(-site).subs Is Nothing Then Set var(-site).subs = New FastCollection Code$ = vbNullString If Len(ww$(0)) > 1 Then EndPoint = Final If Not aheadstatusENDSUBorFUN(var(-where).Code$, EndPoint, -(AscW(ww$(0)) < 128), needfunc) Then If needfunc Then MisEndFunc Else MisEndSub searchsub = False Exit Function End If Code$ = Mid$(var(-where).Code$, Final, EndPoint - Final) End If If needfunc Then var(-site).subs.AddKey "@" + UCase(ww$(1)), Array(Final, where, W$, Code$) Else var(-site).subs.AddKey UCase(ww$(1)), Array(Final, where, W$, Code$) End If End If End If End Function Private Function executeblock(Exec As Long, bstack As basetask, subs As FastCollection, b$, once As Boolean, kolpo As Boolean, Optional ByVal stepbystep As Boolean = False, Optional skipblock As Boolean = False, Optional noblock As Boolean = True) As Boolean executeblock = True Dim i As Long, LL As Long, oldLL As Long, p As Long Dim x2 As Long, y2 As Long, monce As Long, w3 As Long Dim myLevel As Long, oldexec As Long, loopthis As Boolean, RetStackSize As Long Dim oldjump As Long, oldifctrl As Long, olduseofif As Long Dim S3 As Long, bb$, small$, ex2 As Long, sbi As Long ' save state in execution stack oldjump = bstack.jump: oldifctrl = bstack.IFCTRL: olduseofif = bstack.UseofIf RetStackSize = bstack.RetStackTotal If Exec = 0 Then Exec = 1 oldexec = Exec: myLevel = bstack.SubLevel: i = 1 If noblock Then monce = once Else monce = True If Not skipblock Then ' find block ex2 = blockLen(b$) If bstack.addlen <> 0 Then LL = bstack.addlen + Len(b$) - ex2 + 1 Else LL = Len(b$) - ex2 + 1 End If Else LL = bstack.addlen End If oldLL = bstack.addlen If ex2 > 0 Then ex2 = ex2 - 1 Else ex2 = Len(b$) sbi = ex2 Do bb$ = Mid$(b$, i, ex2 - i + 1) fromfirst0: kolpo = once: once = False bstack.addlen = LL w3 = Execute(bstack, bb$, kolpo, stepbystep, loopthis, noblock) bstack.addlen = oldLL cont111: Select Case w3 Case 0 Error1: If bstack.RetStackTotal - RetStackSize > 0 Then bstack.UseofIf = olduseofif bstack.RetStackDrop bstack.RetStackTotal - RetStackSize End If If myLevel <> bstack.SubLevel Then b$ = bb$ Exec = 0 Exit Function End If If NocharsInLine(bb$) Then b$ = vbNullString Else If LastErNum = -2 Then SwapStrings b$, bb$ ElseIf LL >= oldLL Then b$ = bb$ + space$(LL - oldLL) Else b$ = vbNullString$ End If End If Exec = 0 Exit Function Case 1 ALFA12: If LastErNum = -2 Then If NocharsInLine(bb$) Then b$ = vbNullString Else If Left$(bb$, 12) = " : ERROR -2" Then b$ = bb$ ElseIf ex2 < Len(bb$) Then b$ = vbNullString Else b$ = Mid$(b$, ex2 - Len(bb$) + 1) End If End If Exec = 0 Exit Function End If Exec = oldexec ''1 If kolpo And monce And Exec = 1 Then SwapStrings b$, bb$ once = True Exit Function ElseIf kolpo And NocharsInLine(bb$) Then If RetStackSize < bstack.RetStackTotal Then PopStagePart bstack, bstack.RetStackTotal - RetStackSize Exec = w3 Exit Do End If If stepbystep Then b$ = bb$ Else b$ = Right$(b$, Len(b$) - ex2) End If Exit Do Case 2 If bb$ = "BREAK" Then Exec = 2 If noblock Then b$ = vbNullString Else SwapStrings b$, bb$ End If once = True kolpo = True Exit Function ElseIf bb$ = "NEXT" Then SwapStrings b$, bb$ If RetStackSize < bstack.RetStackTotal Then Exec = 2 PopStagePartContinue bstack, bstack.RetStackTotal - RetStackSize Else Exec = 2 End If Exit Do End If If Not kolpo Then If Len(bb$) > 0 Then If bb$ = ChrW$(0) Then 'bstack.addlen = 0 If trace Then TestShowBypass = False If RetStackSize >= bstack.RetStackTotal Then If bstack.IsDecimal Then ' this is a return form other block Exec = 2 b$ = bb$ Exit Function End If ElseIf Not bstack.IsDecimal Then If RetStackSize < bstack.RetStackTotal Then PopStagePartContinue bstack, bstack.RetStackTotal - RetStackSize End If i = 1 from123: If Not bstack.IsInRetStackString(small$) Then p = bstack.Pop3Long(S3, sbi) If p < 0 Then Exec = 0 If RetStackSize <> bstack.RetStackTotal Then MyEr "Problem in return stack", "Πρόβλημα στο σωρό επιστροφής" End If bstack.Flush b$ = vbNullString Exit Function End If If LastErNum = -1 Then bstack.RetStack.PushLong p Exec = 0 Exit Function End If jumphere1: If S3 = 0 And sbi > 0 Then End If Exec = 1 i = ex2 - p + 1 PopStage bstack If loopthis Or stepbystep Or x2 = 2 Then bb$ = Mid$(b$, i, ex2 - i + 1) bstack.addlen = oldLL If x2 = 2 Or stepbystep Then If bb$ = vbCrLf Then bb$ = vbNullString: w3 = 1: GoTo cont111 If bb$ = " " Then bb$ = vbNullString: w3 = 1: GoTo cont111 End If GoTo fromfirst0 Else bb$ = Mid$(b$, p + 1, ex2 - p) End If If bb$ = vbCrLf Then Exit Do Else findelsesub0: If InStr(small$, " ") > 0 Then bstack.PushSecondThird S3, sbi S3 = bstack.OriginalCode If searchsub(0&, S3, small$, i, S3, bb$) Then bstack.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead7(bstack, small$, 1) Then Exec = 0 Exit Function End If End If GoTo contSub ElseIf bstack.IamChild Then If searchsub(bstack.OriginalCode, FindPrevOriginal(bstack), small$, i, S3, bb$) Then bstack.callx1 = 0 If Len(small$) <> 0 Then If Not MyRead(7, bstack, small$, 1) Then Exec = 0 Exit Function End If End If contSub: If Len(bb$) = 0 Then If S3 < 0 Then bb$ = Mid$(var(-S3).Code, i) Else bb$ = Mid$(sbf(S3).sb, i) End If sbi = 0 Else If S3 < 0 Then sbi = Len(var(-S3).Code) - i - Len(bb$) + 1 Else sbi = Len(sbf(S3).sb) - i - Len(bb$) + 1 End If End If kolpo = False If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If End If bstack.addlen = Len(TestShowSub) - i + 1 - Len(bb$) End If y2 = y2 + 1 subsub02: Exec = 0 x2 = Execute(bstack, bb$, kolpo) If x2 = 2 Then If bb$ = Chr$(0) Then If trace Then TestShowBypass = False If bstack.IsInRetStackString(small$) Then GoTo findelsesub0 y2 = y2 - 1 If y2 = 0 Then GoTo from123 'normal level p = bstack.isPop3Long(S3, sbi) If p > 0 Then If S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then GoTo jumphere1 Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If If trace Then TestShowBypass = True If TestShowBypass Then If S3 < 0 Then TestShowSub = var(-S3).Code Else TestShowSub = sbf(S3).sb End If End If bstack.addlen = sbi End If PopStage bstack Exec = 1 GoTo subsub02 Else Exit Do End If ElseIf InStr(bb$, " ") > 0 Then GoTo findelsesub0 Else If subs Is Nothing Then Set subs = New FastCollection If subs.ExistKey(bb$) Then i = subs.Value If subs.sValue = 0 Then If i = 0 Or i > ex2 Then b$ = bb$ Exec = 2 Exit Do Else bb$ = Mid$(b$, i, ex2 - i + 1) End If Else S3 = subs.sValue If S3 < 0 Then If i = 0 Or i > Len(var(-S3).Code$) Then b$ = bb$ Exec = 2 Exit Do End If GoTo AGAINGOTOLAMBDA Else If i = 0 Or i > Len(sbf(S3).sb) Then b$ = bb$ Exec = 2 Exit Do End If GoTo AGAINGOTO End If End If GoTo subsub02 Else If S3 = 0 Then ' priority in the code i = PosLabel(bb$, b$, ex2) If i = 0 Or i > ex2 Then GoTo checkother Else subs.ItemCreator2 bb$, i, 0 bb$ = Mid$(b$, i, ex2 - i + 1) GoTo subsub02 End If End If checkother: If S3 < 0 Then i = PosLabel(bb$, var(-S3).Code$) If i = 0 Or i > Len(var(-S3).Code$) Then b$ = bb$ Exec = 2 Exit Do End If AGAINGOTOLAMBDA: subs.ItemCreator2 bb$, i, S3 If Len(var(-S3).Code$) - i > sbi Then bb$ = Mid$(var(-S3).Code$, i, Len(var(-S3).Code$) - i - sbi) Else bb$ = Mid$(var(-S3).Code$, i) sbi = 0 End If ElseIf S3 > 0 Then i = PosLabel(bb$, sbf(S3).sb) If i = 0 Or i > Len(sbf(S3).sb) Then b$ = bb$ Exec = 2 Exit Do End If subs.ItemCreator2 bb$, i, S3 AGAINGOTO: If Len(sbf(S3).sb) - i > sbi Then bb$ = Mid$(sbf(S3).sb, i, Len(sbf(S3).sb) - i - sbi) Else bb$ = Mid$(sbf(S3).sb, i) sbi = 0 End If Else ' cascade to upper level b$ = bb$ Exec = 2 Exit Do End If GoTo subsub02 End If End If ElseIf x2 = 1 Then If LastErNum <> -2 Then ' not good, we have to find which blocks ' 7 to 5 reduced bstack.RetStackDrop 5 * bstack.SubLevel - myLevel ' b$ = ec$ ' why?? Exec = oldexec Exit Function End If ' NO RETURN...DROP STACK bstack.RetStackDrop 2 Exit Do ElseIf x2 = 0 Then If bstack.ErrorOriginal <> 0 Then b$ = bb$ ElseIf S3 <> 0 Then ' If bstack.OriginalCode <> S3 Then bstack.ErrorOriginal = S3 'If S3 < 0 Then ' b$ = Mid$(var(-S3).code, Len(var(-S3).code) - sbi - Len(bb$)) 'Else b$ = bb$ + space(sbi + 1) 'Mid$(sbf(S3).sb, Len(sbf(S3).sb) - sbi - Len(bb$)) 'End If 'Else 'b$ = bb$ '+ space(sbi) 'End If Else bstack.ErrorOriginal = 0 b$ = bb$ + space(sbi) End If Exec = 0 Exit Function End If Else If bstack.callx1 < 0 Then bstack.callx1 = 0 small$ = Split(small$, " ")(1) small$ = Left$(small$, Len(small$) - 1) If Not bstack.IsDecimal Then b$ = Right(b$, bstack.LastIdpos - 1 - Len(small$)) End If unknownModule b$, small$ Else If Len(Split(small$, " ")(0)) = 1 Then small$ = Split(small$, " ")(1) unknownLabel b$, small$ Else small$ = Split(small$, " ")(1) unknownSub b$, Left$(small$, Len(small$) - 1) End If End If Exec = 0 If bstack.IsDecimal Then p = bstack.Pop3Long(S3, sbi) If bstack.LastIdpos > 0 And S3 = 0 Then bb$ = Right$(b$, bstack.LastIdpos) ElseIf S3 > 0 Then bb$ = Mid$(sbf(S3).sb, Len(sbf(S3).sb) - p - sbi + 1, p) ElseIf S3 = 0 Then bb$ = Mid$(b$, p + 1, ex2 - p) Else bb$ = Mid$(var(-S3).Code$, Len(var(-S3).Code$) - p - sbi + 1, p) End If End If bstack.LastIdpos = 0 bstack.RetStackDrop 3 '5 bstack.SubLevel = bstack.SubLevel - 1 GoTo Error1 End If Else bstack.RetStackDrop 3 '5 Exit Do End If Else bstack.RetStackDrop 1 b$ = Chr$(0) Exec = 2 Exit Function End If End If ElseIf lookOne(bb$, "}") Or NocharsInLine(bb$) Then i = 1 bb$ = Left$(b$, ex2) Else If monce = True Then b$ = bb$ Exec = w3 Exit Do End If If subs Is Nothing Then Set subs = New FastCollection If subs.ExistKey(bb$) Then i = subs.Value If i = 0 Or i > ex2 Then b$ = bb$ Exec = 2 Exit Do Else bb$ = Mid$(b$, i, ex2 - i + 1) GoTo fromfirst0 End If Else i = PosLabel(bb$, b$, ex2) If i = 0 Or i > ex2 Then If skipblock Then bstack.LastIdpos = bstack.LastIdpos + oldLL Else bstack.LastIdpos = bstack.LastIdpos + LL - oldLL End If b$ = bb$ Exec = 2 Exit Do Else subs.ItemCreator2 bb$, i, 0 bb$ = Mid$(b$, i, ex2 - i + 1) GoTo fromfirst0 End If End If End If Else If noblock Then If loopthis And w3 = 2 Then oldexec = 2 If Len(NLtrim$(bb$)) > 0 Then GoTo fromfirst0 End If loopthis = False i = 1 oldexec = 1 Else i = 1 End If Else If w3 = 2 Then w3 = 6 Exec = w3 Exit Function End If End If Else If monce Then If loopthis And kolpo Then Exec = 5: b$ = bb$: Exit Function kolpo = False Else once = kolpo End If 'If checkbreakEsc(bstack) Then Exec = oldexec: Exit Do Exec = 2: b$ = bb$: Exit Function End If Case Else If w3 = 12 Then b$ = bb$ Exec = 12 Exit Do ElseIf w3 = 3 And bb$ = "CONTINUE" Then If noblock Then b$ = Mid$(b$, ex2 + 1) Else b$ = bb$ End If If RetStackSize < bstack.RetStackTotal Then PopStagePartContinue bstack, bstack.RetStackTotal - RetStackSize ' If checkbreakEsc(bstack) Then Exec = oldexec: Exit Do Exec = 3: Exit Do ElseIf w3 = 3 And NocharsInLine(bb$) Then If Not skipblock Then bb$ = "}" ' bb$ = Mid$(b$, ex2 + 1) If Exec = 2 Then Exec = 1: loopthis = False oldexec = 1 w3 = 1 If RetStackSize < bstack.RetStackTotal Then PopStagePart bstack, bstack.RetStackTotal - RetStackSize GoTo ALFA12 ' FROM REVISION 121 ElseIf w3 = 5 Then oldexec = 5 If Len(NLtrim$(bb$)) > 0 Then GoTo fromfirst0 Exec = 5 Exit Function End If If IsSymbol(b$, "}") Then Exec = 1: Exit Do If once Then Exit Do Else b$ = Right$(b$, Len(b$) - Len(bb$)) End If Exit Do End Select 'If checkbreakEsc(bstack) Then Exec = oldexec: Exit Do If monce Then Exit Do Loop If Exec > 1 Then If bstack.RetStackTotal - RetStackSize > 0 Then bstack.UseofIf = olduseofif bstack.RetStackDrop bstack.RetStackTotal - RetStackSize End If End If bstack.jump = oldjump bstack.IFCTRL = oldifctrl executeblock = False End Function Function StockValues(bstack As basetask, b$, Lang As Long) As Boolean ' Stock A[$|%| ]() in A,B$,C(3) copy values to stock array...and ' Stock A[$|%| ]() out A,B$,C(3),... copy values to variables and make empty space in stock ' Stock A[$|%| ]() keep N, B[$|%| ]() ' Stock A[$|%| ]() sweep N [, value ] fill a copy of value to n items or empty slots Dim W$, pppp As mArray, ppppAny As iBoxArray, v As Long, VN As Long, i As Long, what$, pppp1 As mArray, V1 As Long Dim bs As New basetask, p As Variant, P1 As Variant, soros As mStiva, ww$, ss$, usehandler As mHandler Dim useType As Boolean, vt As Integer i = Abs(IsLabel(bstack, b$, what$)) If i > 4 And i < 8 Then If neoGetArray(bstack, what$, ppppAny) Then If Not ppppAny.arr Then NeedAnArray1: Exit Function If NeoGetArrayItem(ppppAny, bstack, what$, v, b$) Then Set pppp = ppppAny againhere: If IsLabelSymbolNew(b$, "ΑΠΟ", "IN", Lang) Then If what$ = vbNullString Then Exit Function ' no for no named array Set soros = bstack.soros Set bstack.Sorosref = bs.soros ' Need bstack and not bs because bstack has more info inside. If MyData(bstack, b$) Then Set bstack.Sorosref = soros Set soros = Nothing VN = v + bs.soros.Total - 1 If pppp.UpperMonoLimit >= VN Then With bs.soros i = 1 For v = v To VN If Not .StackItemTypeIsObject(i) Then pppp.item(v) = .StackItem(i) Else If TypeOf .StackItem(i) Is mArray Then If .StackItem(i).arr Then Set pppp1 = New mArray .StackItem(i).CopyArray pppp1 Set pppp.item(v) = pppp1 Else Set pppp.item(v) = .StackItem(i) End If Else Set pppp.item(v) = .StackItem(i) End If End If i = i + 1 Next v End With Else MyEr "Stock out of space", "Το στοκ έμεινε από χώρο" Exit Function End If StockValues = True Exit Function End If ElseIf IsLabelSymbolNew(b$, "ΣΕ", "OUT", Lang) Then Do If MyIsObject(pppp.item(v)) Then Select Case Abs(IsLabel(bstack, b$, W$)) Case 1, 4 If GetVar(bstack, W$, i, , , , ww$) Then If Typename$(var(i)) = mGroup Then ss$ = bstack.GroupName If ww$ <> "" Then W$ = ww$ If Len(var(i).GroupName) > Len(W$) Then If var(i).IamRef Then ww$ = here$ here$ = vbNullString UnFloatGroupReWriteVars bstack, W$, i, pppp.item(v) here = ww$ Else UnFloatGroupReWriteVars bstack, W$, i, pppp.item(v) End If Else bstack.GroupName = Left$(W$, Len(W$) - Len(var(i).GroupName) + 1) W$ = Left$(var(i).GroupName, Len(var(i).GroupName) - 1) If Len(var(i).GroupName) > 0 Then ww$ = here$ here$ = vbNullString UnFloatGroupReWriteVars bstack, W$, i, pppp.item(v) here = ww$ Else bstack.GroupName = ss$ GroupWrongUse StockValues = False Exit Function End If End If bstack.GroupName = ss$ Else bs.soros.PushObj pppp.item(v) bs.soros.Copy2TopItem 1 Set var(i) = bs.soros.PopObj bs.soros.drop 1 End If Else i = globalvar(W$, 0) bs.soros.PushObj pppp.item(v) bs.soros.Copy2TopItem 1 If TypeOf pppp.itemObject(v) Is mArray Then If pppp.item(v).arr Then Set usehandler = New mHandler Set var(i) = usehandler usehandler.t1 = 3 Set usehandler.objref = bs.soros.PopObj Else Set var(i) = bs.soros.PopObj End If Else Set var(i) = bs.soros.PopObj End If bs.soros.drop 1 End If Case 3 If GetVar(bstack, W$, i, checktype:=useType) Then If useType Then If pppp.ItemType(v) = "Document" Then Set var(i) = pppp.item(v) ElseIf pppp.ItemType(v) = "lambda" Then Set var(i) = pppp.item(v) Else WrongType Exit Function End If Else Set var(i) = pppp.item(v) End If Else i = globalvar(W$, 0) Set var(i) = pppp.item(v) End If Case 5, 6, 7 If neoGetArray(bstack, W$, ppppAny) Then If Not ppppAny.arr Then NeedAnArray1: Exit Function Set pppp1 = ppppAny If IsSymbol(b$, ")") Then bs.soros.PushObj pppp.item(v) If Not globalArrByPointer(bs, bstack, W$) Then MissingArray Else If NeoGetArrayItem(ppppAny, bstack, W$, V1, b$) Then Set ppppAny.item(V1) = pppp.item(v) End If End If ElseIf IsSymbol(b$, ")") Then bs.soros.PushObj pppp.item(v) If Not globalArrByPointer(bs, bstack, W$) Then MissingArray End If End Select Else vt = Abs(IsLabel(bstack, b$, W$)) Select Case vt Case 1, 3, 4 If Not GetVar(bstack, W$, i, checktype:=useType) Then If vt = 1 Then i = globalvar(W$, 0, useType:=False) useType = False ElseIf vt = 3 Then i = globalvar(W$, CVar(vbNullString)) useType = True Else useType = True i = globalvar(W$, 0#) End If End If If MyIsObject(var(i)) Then If TypeOf var(i) Is Document Then var(i).EmptyDoc var(i).textDoc = pppp.item(v) End If Else If useType Then p = pppp.item(v) 'If myVarType(p, VarType(var(i))) Then If AssignTypeNumeric(p, VarType(var(i))) Then SwapVariant p, var(i) Else WrongType StockValues = False Exit Function End If Else var(i) = pppp.item(v) End If End If Case 5, 6, 7 If neoGetArray(bstack, W$, pppp1) Then If Not pppp1.arr Then MissingArray: Exit Function If lookOne(b$, ")") Then If Not NeoGetArrayItem(pppp1, bstack, W$ + ")", V1, "") Then i = -1 GlobalArr bstack, W$, vbNullString, 0, i Set var(i) = pppp.item(v) End If ElseIf NeoGetArrayItem(pppp1, bstack, W$, V1, b$) Then pppp1.item(V1) = pppp.item(v) End If End If Case Else SyntaxError Exit Function End Select End If v = v + 1 If pppp.UpperMonoLimit < v Then If lookOne(b$, ",") Then UpperArrayLimit Exit Function End If End If Loop Until Not FastSymbol(b$, ",") ElseIf IsLabelSymbolNew(b$, "ΓΙΑ", "KEEP", Lang) Then If IsExp(bstack, b$, p) Then If p <> MyRound(p) Or p < 0 Then MyEr "Invalid index", "Μη έγκυρος δείκτης" Exit Function End If If IsSymbol(b$, ",") Then If Abs(IsLabel(bstack, b$, W$)) > 4 Then If neoGetArray(bstack, W$, pppp1) Then If Not pppp1.arr Then NeedAnArray1: Exit Function If NeoGetArrayItem(pppp1, bstack, W$, V1, b$) Then If Not (V1 + p - 1 <= pppp1.UpperMonoLimit) Then MyEr "Invalid index", "Μη έγκυρος δείκτης" Exit Function Else If pppp1 Is pppp Then If v = V1 Then ' do nothing ElseIf Abs(v - V1) < p Then 'from top If V1 > v Then For i = p - 1 To 0 Step -1 With pppp If MyIsObject(.item(i + v)) Then If i + v < V1 Then bs.soros.PushObj .item(i + v) bs.soros.Copy2TopItem 1 Set pppp1.item(i + V1) = bs.soros.PopObj bs.soros.drop 1 Else Set pppp1.item(i + V1) = .item(i + v) End If Else pppp1.item(i + V1) = .item(i + v) End If End With Next i Else ' v > V1 For i = 0 To p - 1 With pppp If MyIsObject(.item(i + v)) Then If p + V1 <= v + i Then bs.soros.PushObj .item(i + v) bs.soros.Copy2TopItem 1 Set pppp1.item(i + V1) = bs.soros.PopObj bs.soros.drop 1 Else Set pppp1.item(i + V1) = .item(i + v) End If Else pppp1.item(i + V1) = .item(i + v) End If End With Next i End If Else For i = 0 To p - 1 With pppp If MyIsObject(.item(i + v)) Then bs.soros.PushObj .item(i + v) bs.soros.Copy2TopItem 1 Set pppp1.item(i + V1) = bs.soros.PopObj bs.soros.drop 1 Else pppp1.item(i + V1) = .item(i + v) End If End With Next i End If Else For i = 0 To p - 1 With pppp If MyIsObject(.item(i + v)) Then bs.soros.PushObj .item(i + v) bs.soros.Copy2TopItem 1 Set pppp1.item(i + V1) = bs.soros.PopObj bs.soros.drop 1 Else pppp1.item(i + V1) = .item(i + v) End If End With Next i End If StockValues = True Exit Function End If End If End If ElseIf Right$(W$, 1) = "$" Then If GetVar(bstack, W$, V1) Then var(V1) = vbNullString Else V1 = globalvar(W$, "") End If VN = Right$(what$, 3) = "$" If p - 1 + v > pppp.UpperMonoLimit Then MyEr "Invalid copy number", "Μη έγκυρος δείκτης αντιγραφής" Exit Function End If For i = 0 To p - 1 With pppp If MyIsObject(.item(i + v)) Then If VN Then var(V1) = var(V1) + Sput("") Else var(V1) = var(V1) & " 0" Else Select Case Typename(.item(i + v)) Case "Double" var(V1) = var(V1) + " " + Trim$(str(.item(i + v))) Case "String" W$ = .item(i + v) If IsNumberD2(W$, p) Then var(V1) = var(V1) + " " + .item(i + v) Else var(V1) = var(V1) + Sput(.item(i + v)) End If Case Else If VN Then var(V1) = var(V1) + Sput("") Else var(V1) = var(V1) & " 0" End Select End If End With Next i StockValues = True Exit Function End If End If End If ElseIf IsLabelSymbolNew(b$, "ΘΕΣΕ", "SWEEP", Lang) Then If what$ = vbNullString Then Exit Function ' no for no named array If IsExp(bstack, b$, p) Then If p <> MyRound(p) Or p < 0 Then MyEr "Invalid index", "Μη έγκυρος δείκτης" Exit Function End If If Not (v + p - 1 <= pppp.UpperMonoLimit) Then MyEr "Invalid index", "Μη έγκυρος δείκτης" Exit Function Else If Not IsSymbol(b$, ",") Then For i = 0 To p - 1 If MyIsObject(pppp.item(i + v)) Then Set pppp.item(i + v) = Nothing End If pppp.item(i + v) = Empty Next i Else i = 1 what$ = aheadstatus(b$, False, i) Set bstack.lastobj = Nothing If what$ <> "" Then If Left$(what$, 1) = "N" Then If IsNumber(bstack, b$, P1) Then If bstack.lastobj Is Nothing Then For i = 0 To p - 1 pppp.item(i + v) = P1 Next i Else bs.soros.PushObj bstack.lastobj Set bstack.lastobj = Nothing For i = 0 To p - 1 bs.soros.Copy2TopItem 1 Set pppp.item(i + v) = bs.soros.PopObj Next i End If End If Else If IsString(bstack, b$, what$) Then If bstack.lastobj Is Nothing Then For i = 0 To p - 1 pppp.item(i + v) = what$ Next i Else bs.soros.PushObj bstack.lastobj Set bstack.lastobj = Nothing For i = 0 To p - 1 bs.soros.Copy2TopItem 1 Set pppp.item(i + v) = bs.soros.PopObj Next i End If End If End If End If End If End If End If End If End If StockValues = True Else b$ = what$ + b$ If IsExp(bstack, b$, p) Then what$ = vbNullString If Typename(bstack.lastobj) = myArray Then Set pppp = bstack.lastobj: Set bstack.lastobj = Nothing: GoTo againhere ElseIf IsStrExp(bstack, b$, what$) Then what$ = vbNullString If Typename(bstack.lastobj) = myArray Then Set pppp = bstack.lastobj: Set bstack.lastobj = Nothing: GoTo againhere End If End If End If End Function Public Function SubsExist() As Boolean SubsExist = subHash.Count > 0 End Function Sub TraceStore(b As basetask, v As Long, c$, o&) v = b.addlen b.addlen = Len(c$) - o& + b.addlen End Sub Sub TraceRestore(b As basetask, v As Long) b.addlen = v End Sub Sub SetSizeAndHotSpot(thisbasket As basket, maxx As Long, MaxY As Long, Optional ByVal HotSpotX = 0, Optional ByVal HotSpotY = 0) With thisbasket .MAXXGRAPH = maxx .MAXYGRAPH = MaxY If Not IsMissing(HotSpotX) Then .X = CLng(HotSpotX) ' this is hotspot If Not IsMissing(HotSpotY) Then .Y = CLng(HotSpotY) End With End Sub Sub FeedBasket(DDD As Object, thisbasket As basket, alinespace As Long) With thisbasket .FontName = DDD.FontName .SZ = DDD.FontSize .charset = DDD.Font.charset .MineLineSpace = alinespace .uMineLineSpace = alinespace ''.Paper = ddd.BackColor FrameText DDD, .SZ, 0, 0, -.Paper, (DDD.Name <> "Form1") End With End Sub Sub PlaceBasketPrive(DDD As Object, thisbasket As basket) On Error Resume Next With thisbasket If Not DDD.FontName = .FontName And DDD.Font.charset = .charset And DDD.FontSize = .SZ Then DDD.Font.charset = 0 DDD.FontSize = 9 DDD.FontName = .FontName DDD.Font.charset = .charset DDD.FontSize = .SZ End If ' these I have to delete after change End With End Sub Sub PlaceBasket(DDD As Object, thisbasket As basket) On Error Resume Next With thisbasket If Not (DDD.FontName = .FontName And DDD.Font.charset = .charset And DDD.Font.Size = .SZ) Then StoreFont .FontName, .SZ, .charset DDD.Font.charset = 0 DDD.FontSize = 9 DDD.FontName = .FontName DDD.Font.charset = .charset DDD.FontSize = .SZ End If DDD.ForeColor = .mypen End With End Sub Function GetCode(dq As Object) As Long Dim u As Long If dq Is Form1.DIS Or dq Is Nothing Then GetCode = 0 ElseIf dq Is Form1 Then GetCode = -1 ElseIf dq Is Form1.PrinterDocument1 Then GetCode = -2 ElseIf (TypeOf dq Is GuiM2000) Or (TypeOf dq Is GuiImage) Then On Error Resume Next u = dq.prive ' check this again If Err > 0 Then Err.Clear: oxiforforms: GetCode = -1: Set dq = Form1: Exit Function If u = 0 Then For u = 33 To 1032 If Not players(u).used Then Exit For Next u If u = 1033 Then ResourceLimit: GetCode = -1: Set dq = Form1: Exit Function players(u) = Zero dq.prive = u players(u).used = True End If GetCode = u ElseIf TypeOf dq Is MetaDc Then On Error Resume Next u = dq.prive ' check this again If Err > 0 Then Err.Clear: oxiforMetaFiles: GetCode = -1: Set dq = Form1: Exit Function If u = 0 Then For u = 33 To 1032 If Not players(u).used Then Exit For Next u If u = 1033 Then ResourceLimit: GetCode = -1: Set dq = Form1: Exit Function dq.prive = u players(u) = Zero players(u).used = True End If GetCode = u ElseIf TypeOf dq Is PictureBox Then If dq.Name = "dSprite" Then GetCode = dq.index Else GetCode = CLng("0" & dq.Tag) End If End If End Function Static Function MyRound(a As Variant, Optional ByVal i As Integer = 0) Dim j As VbVarType j = VarType(a) If j < vbSingle Or j = 20 Or j = vbString Then MyRound = a: Exit Function Dim c As Variant Static n(1 To 28) As Single, D(1 To 28) As Double, cur(1 To 28) As Currency, dec(1 To 28) As Variant Static sg(-1 To 1) As Single, sg4(-1 To 1) As Double, sg8(-1 To 1) As Currency On Error GoTo there If n(1) = 0 Then sg(-1) = CSng(-0.5) sg(1) = CSng(0.5) sg4(-1) = -0.5 sg4(1) = 0.5 sg8(-1) = CCur(-0.5) sg8(1) = CCur(0.5) For c = 1& To 6& n(c) = CSng(10 ^ c) Next c For c = 7& To 27& n(c) = CSng(-1) Next c n(c) = CSng(10 ^ 5) n(10) = CSng(10 ^ 5) For c = 1& To 13& D(c) = CDbl(10 ^ c) Next c For c = 14& To 27& D(c) = CDbl(-1) Next c D(c) = CDbl(10 ^ 13) For c = 1& To 3& cur(c) = CCur(10 ^ c) Next c For c = 4& To 28& cur(c) = CCur(-1) Next c For c = 1& To 28& dec(c) = CDec(10 ^ c) Next c End If If i = 0 Then MyRound = Sgn(a) * Int(Abs(a) + 0.5!) Exit Function Else c = Fix(a) Select Case j Case vbSingle If n(i) > 0 Then c = sg(Sgn(a)) MyRound = Fix(a * n(i) + c) / n(i) Else MyRound = a End If Exit Function Case vbDouble c = sg4(Sgn(a)) If D(i) > 0 Then MyRound = Fix(a * D(i) + c) / D(i) Else MyRound = a End If Exit Function Case vbCurrency If cur(i) > 0 Then c = sg8(Sgn(a)) MyRound = Fix(a) + Fix((a - Fix(a)) * cur(i) + c) / cur(i) Else MyRound = a End If Exit Function Case vbDecimal c = sg8(Sgn(a)) MyRound = Fix(a) + Fix((a - Fix(a)) * dec(i) + c) / dec(i) Exit Function Case Else MyRound = a Exit Function End Select End If there: Err.Clear MyRound = a If i < 0 Or i > 28 Then MyEr "Round Place exit range 0 to 28", "Η θέση στρογγυλοποίησης εκτός περιοχής από 0 έως 28" End Function Function AllocVar() var2used = var2used + 1 If UBound(var()) <= var2used + 20 Then varhash.Expand UBound(var()) * 2 On Error Resume Next If UBound(var()) <> varhash.MaxSpace Then ReDim Preserve var(varhash.MaxSpace) As Variant End If If Err.Number > 0 Then NOEXECUTION = True MyEr Err.Description, Err.Description Err.Clear Exit Function End If End If AllocVar = var2used End Function Function AllocSub() As Long 'On Error Resume Next If UBound(sbf()) <= sb2used + 1 Then subHash.Expand UBound(sbf()) * 2 If UBound(sbf()) <> subHash.MaxSpace Then ReDim Preserve sbf(subHash.MaxSpace) As modfun End If End If sb2used = sb2used + 1 AllocSub = sb2used End Function Function ProcEventVarSet(bstack As basetask, i As Long) As mEvent If i = -1 Then ' If Typename(bstack.lastobj) = "mEvent" Then Set ProcEventVarSet = bstack.lastobj Else MyEr "Not found an object Event", "Δεν βρήκα ένα αντικείμενο Γεγονός" Exit Function End If Else Set ProcEventVarSet = var(i) End If End Function Function ProcEvent(bstack As basetask, rest$, Lang As Long, i As Long) As Boolean 'look for { }, or hold Dim aa As mEvent, s$, lastname$, dd As Long, pm As Long, pf As Long ProcEvent = True Dim ss$, rd$, ss1$ If FastSymbol(rest$, "{") Then Set aa = ProcEventVarSet(bstack, i) aa.BypassInit 10 aa.VarIndex = i If here$ = vbNullString Then aa.NoHere = bstack.GroupName Else aa.NoHere = here$ + "." + bstack.GroupName End If aa.enabled = True ss$ = NLtrim$(block(rest$)) rd$ = vbNullString While ss$ <> "" If FastSymbol(ss$, vbCrLf, , 2) Then ss$ = NLtrim(ss$) ElseIf IsLabelSymbolNew(ss$, "ΔΙΑΒΑΣΕ", "READ", Lang) Then 'If Lang = 1 Then If rd$ = vbNullString Then rd$ = neoReadEng 'Else 'If rd$ = vbNullString Then rd$ = neoReadGr 'End If Do dd = 1 s$ = aheadstatus(ss$, , dd) If s$ <> "" Then pm = pm + 1 If FastPureLabel(ss$, ss1$, , , , , False) Then If pm < 2 Then rd$ = rd$ + Left$(ss$, dd - 1) Else rd$ = rd$ + "," + Left$(ss$, dd - 1) End If ss$ = Mid$(ss$, dd) Else ProcEvent = False Exit Function End If Else Exit Do End If Loop Until Not FastSymbol(ss$, ",") ElseIf IsLabelSymbolNew(ss$, "ΣΥΝΑΡΤΗΣΗ", "FUNCTION", Lang) Then '' check only for blocks pf = pf + 1 If FastSymbol(ss$, "{") Then s$ = "{" + rd$ + vbCrLf + block(ss$) + "}" + here$ + "." + bstack.GroupName If Not FastSymbol(ss$, "}") Then ProcEvent = False: Exit Function aa.GenItemCreator LTrim$(str(pf * 123)), s$ While ss$ <> "" If FastSymbol(ss$, vbCrLf, , 2) Then ss$ = NLtrim(ss$) ElseIf IsLabelSymbolNew(ss$, "ΣΥΝΑΡΤΗΣΗ", "FUNCTION", Lang) Then If FastSymbol(ss$, "{") Then s$ = "{" + rd$ + vbCrLf + block(ss$) + "}" If Not FastSymbol(ss$, "}") Then ProcEvent = False: Exit Function ' βάλε ένα key pf = pf + 1 aa.GenItemCreator LTrim$(str(pf * 123)), s$ Else ProcEvent = False: Exit Function End If Else ProcEvent = False: Exit Function End If Wend End If Else ProcEvent = False: Exit Function End If Wend aa.ParamBlock rd$, pm Set aa = Nothing If Not FastSymbol(rest$, "}") Then ProcEvent = False: Exit Function ' do something ' find Read command and some Functions ElseIf IsLabelSymbolNew(rest$, "ΑΦΗΣΕ", "RELEASE", Lang) Then Set aa = ProcEventVarSet(bstack, i) aa.enabled = True ElseIf IsLabelSymbolNew(rest$, "ΚΡΑΤΗΣΕ", "HOLD", Lang) Then Set aa = ProcEventVarSet(bstack, i) aa.enabled = False ElseIf IsLabelSymbolNew(rest$, "ΚΑΘΑΡΟ", "CLEAR", Lang) Then Set aa = ProcEventVarSet(bstack, i) aa.enabled = False aa.BypassInit 10 ElseIf IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", Lang) Then Set aa = ProcEventVarSet(bstack, i) Do dd = 1 ss$ = aheadstatus(rest$, , dd) If ss$ = "S" Then lastname$ = here$ + "." + MyTrim(myUcase(Left(rest$, dd - 1), True)) If Not IsStrExp(bstack, rest$, s$) Then ProcEvent = False: Exit Function If Not lookOne(s$, "{") Then If GetSub(s$, pm) Then If sbf(pm).Extern > 0 Then s$ = "{CALL EXTERN" + str$(sbf(pm).Extern) + "'" + ChrW(&H1FFD) + "}" + sbf(pm).sbgroup Else s$ = "{" + sbf(pm).sb + "}" + sbf(pm).sbgroup End If Else s$ = "{CALL VOID " + s$ + "}" End If End If ElseIf ss$ = "N" Then ss$ = "&" + Left$(rest$, dd) If Not IsString(bstack, (ss$), s$) Then ProcEvent = False: Exit Function Else lastname$ = subHash.LastKnown If Len(here$) > 0 Then If Left$(lastname$, Len(here$)) = here$ Then lastname$ = Mid$(lastname$, Len(here$) + 2) End If End If End If rest$ = Mid$(rest$, dd) Else s$ = vbNullString End If If Len(s$) > 1 Then If Not aa.StandBy("(FREE)", lastname$, s$) Then aa.GenItemCreator lastname$, s$ Else ProcEvent = False Exit Function End If Loop Until Not FastSymbol(rest$, ",") Set aa = Nothing ElseIf IsLabelSymbolNew(rest$, "ΠΕΤΑ", "DROP", Lang) Then Set aa = ProcEventVarSet(bstack, i) Do dd = 1 ss$ = aheadstatus(rest$, , dd) If ss$ = "S" Then lastname$ = here$ + "." + MyTrim(myUcase(Left(rest$, dd - 1), True)) If Not IsStrExp(bstack, rest$, s$) Then ProcEvent = False: Exit Function ElseIf ss$ = "N" Then ss$ = "&" + Left$(rest$, dd) If Not IsString(bstack, (ss$), s$) Then ProcEvent = False: Exit Function Else lastname$ = subHash.LastKnown If Len(here$) > 0 Then If Left$(lastname$, Len(here$)) = here$ Then lastname$ = Mid$(lastname$, Len(here$) + 2) End If End If End If rest$ = Mid$(rest$, dd) Else s$ = vbNullString End If If Len(s$) > 1 Then aa.StandBy lastname$, "(FREE)", "" ' no erroro if not found Else ProcEvent = False Exit Function End If Loop Until Not FastSymbol(rest$, ",") Set aa = Nothing Exit Function End If Set aa = Nothing End Function Sub CopyEvent(a As Variant, bstack As basetask) Dim ALFA As New mEvent, i As Long Dim aa As mEvent Set aa = a '' now put code to copy a to alfa ALFA.BypassInit CLng(a.CurMaxSpace) Dim aaa() As GenItem, bbb() As Long, mytop As Long aa.CopySpaceUp aaa(), bbb(), mytop ALFA.CopySpaceDown aaa(), bbb(), mytop ALFA.ParamBlock aa.ParamsRead, aa.params ALFA.NoHere = aa.NoHere ALFA.enabled = aa.enabled Set bstack.lastobj = ALFA Set aa = Nothing End Sub Function CallEvent(bstack As basetask, rest$, Lang As Long, ByVal i As Long) As Boolean If i > -1 Then If VarTypeName(var(i)) <> "mEvent" Then Exit Function End If Else If Typename(bstack.lastobj) <> "mEvent" Then Exit Function End If End If CallEvent = True Dim a As mEvent, n$, f$, bb As mStiva, oldbstack As mStiva, nowtotal As Long, oldstatic As FastCollection FastSymbol rest$, "," If i < 0 Then Set a = bstack.lastobj i = var2used + CLng(Rnd(1000)) Else Set a = var(i) End If ''bstack.Look2Parent = True If Not PushParamGeneral(bstack, rest$) Then CallEvent = False Set a = Nothing Exit Function End If ''bstack.Look2Parent = False Dim j As Long, k, s1$, klm As Long Set oldbstack = bstack.soros Set oldstatic = bstack.StaticCollection Dim ohere$ ohere$ = here$ If a Is Nothing Then Exit Function For j = 0 To a.Count - 1 here$ = "EV" & i & "." & j If a.enabled Then 'Set bstack.StaticCollection = Nothing Set bstack.StaticCollection = a.StaticCollection a.ReadVar j, n$, f$ If f$ <> "" Then Set bb = NewmStiva Set bstack.Sorosref = bb bb.Copy2TopNItems2FromStiva a.params, oldbstack PushStage bstack, False s1$ = Mid$(f$, 2, rinstr(f$, "}") - 2) klm = ModuleSubAsap("A_()", s1$, Trim$(Mid$(f$, Len(s1$) + 3))) If Not ProcModuleEntry(bstack, "A_()", klm, "", , True) Then PopStage bstack bb.Flush GoTo conthere End If PopStage bstack bb.Flush End If End If Set a.StaticCollection = bstack.StaticCollection Next j conthere: Set a.StaticCollection = bstack.StaticCollection Set bstack.Sorosref = oldbstack Set bstack.StaticCollection = oldstatic Set oldstatic = Nothing Set oldbstack = Nothing bstack.soros.drop a.params Set bb = Nothing here$ = ohere$ End Function Public Function CallEventFromGui(gui As GuiM2000, a As mEvent, aString$) As Boolean If a Is Nothing Then CallEventFromGui = True: Exit Function Dim tr As Boolean, extr As Boolean, olescok As Boolean olescok = escok escok = False extr = extreme extreme = True tr = trace If tr Then If Rnd * 100 > 3 Then trace = False On Error Resume Next CallEventFromGui = True Dim n$, f$, bb As mStiva, oldbstack As mStiva, nowtotal As Long Dim bstack As basetask Set bstack = New basetask With bstack .IamAnEvent = True Set .Owner = Basestack1.Owner End With Dim i As Long i = a.VarIndex bstack.soros.DataStr aString$ If gui.index >= 0 Then bstack.soros.DataVal gui.index End If bstack.soros.DataObj gui Set oldbstack = bstack.soros Dim j As Long, s1$, klm As Long Dim ohere$ ohere$ = here$ Set bb = NewmStiva For j = 0 To a.Count - 1 here$ = "EV" & i & "." & j If a.enabled Then a.ReadVar j, n$, f$ If f$ <> "" Then bb.Flush If Not a.StaticCollection Is Nothing Then If a.StaticCollection.ExistKey(n$) Then Set bstack.StaticCollection = a.StaticCollection.ValueObj End If End If Set bstack.Sorosref = bb bb.Copy2TopNItems2FromStiva a.params, oldbstack PushStage bstack, False s1$ = Mid$(f$, 2, rinstr(f$, "}") - 2) klm = ModuleSubAsap("A_()", s1$, Trim$(Mid$(f$, Len(s1$) + 3))) Dim ww As Boolean ww = Not ProcModuleEntry(bstack, "A_()", klm, "", , True) PopStage bstack If Not bstack.StaticCollection Is Nothing Then If a.StaticCollection Is Nothing Then Set a.StaticCollection = New FastCollection If Not a.StaticCollection.ExistKey(n$) Then a.StaticCollection.AddKey n$, bstack.StaticCollection End If End If If ww Then GoTo conthere End If End If Next j conthere: Set bstack.Sorosref = oldbstack Set oldbstack = Nothing bb.Recycle Set bb = Nothing If Not a Is Nothing Then bstack.soros.drop a.params End If here$ = ohere$ extreme = extr If tr Then trace = tr escok = olescok End Function Public Function CallEventFromGuiOne(gui As GuiM2000, a As mEvent, aString$) As Boolean If a Is Nothing Then CallEventFromGuiOne = True: Exit Function If Not a.enabled Then CallEventFromGuiOne = True: Exit Function Dim n$, f$, F1$, uIndex As Long Dim s1$, klm As Long Dim i As Long, ui As Long i = a.VarIndex uIndex = gui.index ui = -1 If uIndex >= 0 Then ui = uIndex uIndex = 1 End If uIndex = uIndex + 1 FastPureLabel aString$, f$, , , , , False n$ = Mid$(aString$, Len(f$) + 1) n$ = Left$(n$, Len(n$) - 1) If n$ <> "" Then If uIndex > 0 Then n$ = "@Data " + n$ + " : @ShiftBack @Stack.Size" + str(1 - uIndex) + "," + str$(uIndex) + vbCrLf Else n$ = "@Data " + n$ + " : @ShiftBack @Stack.Size" + vbCrLf End If End If F1$ = gui.modulename If F1$ <> "" Then f$ = myUcase(F1$ + "." + f$ + ")", True) Else f$ = myUcase(f$ + ")", True) If Not GetSub(f$, klm) Then CallEventFromGuiOne = False Exit Function End If Dim ohere$ SwapStrings ohere$, here$ here$ = "EV" & i s1$ = sbf(klm).sb If Left$(s1$, 10) = "'11001EDIT" Then SetNextLine s1$ End If Dim tr As Boolean, extr As Boolean, olescok As Boolean olescok = escok escok = False tr = trace extr = extreme extreme = True If tr Then If Rnd * 100 > 3 Then trace = False Dim bstack As basetask Set bstack = New basetask Set bstack.Owner = Form1.DIS If ui >= 0 Then bstack.soros.DataVal CDbl(ui) bstack.soros.DataObj gui bstack.IamAnEvent = True PushStage bstack, False If Not a.StaticCollection Is Nothing Then If a.StaticCollection.ExistKey(f$) Then Set bstack.StaticCollection = a.StaticCollection.ValueObj End If End If If F1$ <> "" Then s1$ = n$ + "Module " + F1$ + vbCrLf + sbf(klm).sb Else s1$ = n$ + sbf(klm).sb Dim ww As Boolean ww = Execute(bstack, s1$, False, False) = 0 If Not bstack.StaticCollection Is Nothing Then If a.StaticCollection Is Nothing Then Set a.StaticCollection = New FastCollection If Not a.StaticCollection.ExistKey(f$) Then a.StaticCollection.AddKey f$, bstack.StaticCollection End If End If If ww Then If F1$ = vbNullString Then MyEr "Problem in Event " + aString$, "Πρόβλημα στο γεγονός " + aString$ Else MyEr "Problem in Event " + aString$ + " in module " + F1$, "Πρόβλημα στο γεγονός " + aString$ + " στο τμήμα " + F1$ End If Else CallEventFromGuiOne = True End If PopStage bstack Set bstack = Nothing here$ = ohere$ If tr Then trace = tr extreme = extr escok = olescok End Function Public Function CallEventFromGuiNow(gui As GuiM2000, a As mEvent, aString$, vrs()) As Boolean If a Is Nothing Then CallEventFromGuiNow = True: Exit Function If Not a.enabled Then CallEventFromGuiNow = True: Exit Function Dim tr As Boolean, extr As Boolean, olescok As Boolean olescok = escok escok = False extr = extreme extreme = True tr = trace If tr Then If Rnd * 100 > 3 Then trace = False Dim n$, f$, F1$, bb As mStiva, oldbstack As mStiva, nowtotal As Long Dim bstack As basetask Set bstack = New basetask Set bstack.Owner = Form1.DIS bstack.IamAnEvent = True Dim i As Long i = a.VarIndex F1$ = gui.modulename Set oldbstack = bstack.soros Dim j As Long, k As Long, s1$, klm As Long, S2$ Dim ohere$ SwapStrings ohere$, here$ here$ = "EV" & i a.ReadVar 0, n$, f$ If f$ <> "" Then Set bb = NewmStiva Set bstack.Sorosref = bb PushStage bstack, False For k = LBound(vrs()) To UBound(vrs()) - 1 If VarType(vrs(k)) = vbString Then globalvarGroup "EV" & (i + k) & "$", vrs(k) bb.DataStr here$ & ".EV" & (i + k) & "$" Else globalvarGroup "EV" & (i + k), vrs(k) bb.DataStr here$ & ".EV" & (i + k) End If Next k bb.DataObj gui FastPureLabel aString$, f$, , , , , False n$ = Mid$(aString$, Len(f$) + 1) If Len(n$) > 0 Then n$ = Left$(n$, Len(n$) - 1) If n$ <> "" Then n$ = "Push " + n$ + vbCrLf End If If F1$ <> "" Then f$ = myUcase(F1$ + "." + f$ + ")", True) Else f$ = myUcase(f$ + ")", True) If Not GetSub(f$, klm) Then CallEventFromGuiNow = False GoTo conthere End If s1$ = sbf(klm).sb If Left$(s1$, 10) = "'11001EDIT" Then SetNextLine s1$ End If If F1$ <> "" Then s1$ = n$ + "Module " + F1$ + vbCrLf + sbf(klm).sb Else s1$ = n$ + sbf(klm).sb Dim nn As Long, ww As Boolean If Not a.StaticCollection Is Nothing Then If a.StaticCollection.ExistKey(f$) Then Set bstack.StaticCollection = a.StaticCollection.ValueObj End If End If ww = Execute(bstack, s1$, False, False) = 0 If Not bstack.StaticCollection Is Nothing Then If a.StaticCollection Is Nothing Then Set a.StaticCollection = New FastCollection If Not a.StaticCollection.ExistKey(f$) Then a.StaticCollection.AddKey f$, bstack.StaticCollection End If End If If ww Then MyEr "Problem in Event " + aString$, "Πρόβλημα στο γεγονός " + aString$ GoTo conthere End If here$ = "EV" & i For k = LBound(vrs()) To UBound(vrs()) - 1 If VarType(vrs(k)) = vbString Then GetlocalVar "EV" & (i + k) & "$", j vrs(k) = var(j) Else GetlocalVar "EV" & (i + k), j vrs(k) = var(j) End If Next k CallEventFromGuiNow = True conthere: PopStage bstack Set bstack.Sorosref = oldbstack Set oldbstack = Nothing bb.Recycle Set bb = Nothing End If SwapStrings here$, ohere$ If tr Then trace = tr extreme = extr escok = olescok End Function Sub ProcMethodArray(bstack As basetask, pppp As mArray, index As Long, co$, rest$, Lang As Long, ifier0 As Boolean, groupok As Boolean, prive As Boolean) Dim VR(1) Set VR(0) = pppp.item(index) On Error Resume Next ProcMethod bstack, VR(), 0, co$, rest$, Lang, ifier0, groupok, prive ifier0 = (Err = 0) And ifier0 Err.Clear End Sub Sub ProcPropertyArray(bstack As basetask, pppp As mArray, index As Long, co$, rest$, Lang As Long, ifier0 As Boolean, Optional usethis As Long) Dim VR(1) If VarType(pppp.item(index)) <> vbEmpty Then Set VR(0) = pppp.item(index) On Error Resume Next ProcProperty bstack, VR(), 0, co$, rest$, Lang, True, usethis ifier0 = Err = 0 Err.Clear Else NoObjectFound End If End Sub Private Function ProcPtr(ByVal nAddress As Long) As Long ProcPtr = nAddress End Function Function CallByPtr(nSubAddress As Long, basestack As basetask, rest$, Lang As Long) As Boolean Dim resp As Boolean CallWindowProc nSubAddress, VarPtr(basestack), VarPtr(rest$), VarPtr(Lang), VarPtr(resp) CallByPtr = resp End Function Sub NeoWait(basestackLP As Long, rest$, Lang As Long, resp As Boolean) Dim basestack As basetask, p As Variant Set basestack = ObjFromPtr(basestackLP) If IsExp(basestack, rest$, p) Then mywait basestack, p Else mywait basestack, 0 End If Set basestack = Nothing resp = True End Sub Sub CallNext(basestack As basetask, rest$, resp As Boolean, V1 As Variant, V2 As String) Dim i As Long, p As Variant, par As Boolean, f As Long, b$ Dim flag As Boolean, it As Long, what$, s$, x1 As Long, ss$, bs As basetask, vvl As Variant, X As Double s$ = V2 i = Abs(IsLabel(basestack, s$, what$)) GoTo there reenter1: i = Abs(IsLabel(basestack, rest$, what$)) there: If i = 3 And Len(rest$) > 0 Then If AscW(rest$) = 46 Then If Not IsStrExp(basestack, (what$), what$) Then MissPar: Exit Sub rest$ = what$ + rest$ GoTo reenter1 End If End If ' call function as module '********************************************************** ss$ = what$ + ")" If FastSymbol(rest$, ",") Then End If ''ss$ = myucase(ss$) resp = True MakeThisSub basestack, ss$ it = CLng(GetSub(ss$, x1)) If Not it Then it = CLng(GetlocalSub(ss$, x1)) If it Then Set bs = New basetask Set bs.Parent = basestack If basestack.IamThread Then Set bs.Process = basestack.Process If Not TheSame(here$, ss$) Then Set bs.Sorosref = basestack.soros Set bs.Owner = basestack.Owner bs.OriginalCode = x1 If flag Then bs.UseGroupname = basestack.UseGroupname bs.GroupName = basestack.GroupName bs.SetV Call GoFunc(bs, ss$, rest$, vvl, , x1) Else bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer bs.SetV Call GoFunc(bs, ss$, rest$, vvl) End If If Not bs.StaticCollection Is Nothing Then basestack.SetVarobJ "%_" + bs.StaticInUse, bs.StaticCollection End If Set bs = Nothing If Not par Then If myVarType(vvl, vbEmpty) Then resp = False: Exit Sub If InStr(ss$, "$") > 0 Then V2 = CStr(vvl) Else V1 = CDbl(vvl) End If End If Else ' ?? End If End Sub Sub NeoCall(basestackLP As Long, rest$, Lang As Long, resp As Boolean) Dim basestack As basetask, i As Long, p As Variant, par As Boolean, f As Long, Op As Object, Op1 As Object Dim flag As Boolean, it As Long, what$, s$, x1 As Long, ss$, bs As basetask, vvl As Variant, X As Double Dim c As Constant, myl As lambda, a As Group, usethis As stdCallFunction, originalwhat$ Set basestack = ObjFromPtr(basestackLP) If Fast2VarNoTrim(rest$, "ΤΕΛΕΣΤΗ", 7, "OPERATOR", 8, 9, f) Then If ISSTRINGA(rest$, s$) Then contoper: If ThisPointer(basestack, x1) Then If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p) Then If basestack.lastobj Is Nothing Then NeedAGroupFromExpression Set basestack.lastobj = Nothing Exit Sub End If If TypeOf basestack.lastobj Is Group Then basestack.soros.PushObj basestack.lastobj Set basestack.lastobj = Nothing NeoCall2 basestack, var(x1).Patch + "." + ChrW(&H1FFF) + s$ + "()", (True) resp = True Else NeedAGroupFromExpression End If Else MissNumExpr End If Else NeoCall2 basestack, "." + ChrW(&H1FFF) + s$ + "()", (True) resp = True End If Set basestack.lastobj = Nothing Exit Sub Else OnlyInAGroup Exit Sub End If ElseIf IsLabelSymbolNew(rest$, "ΜΟΝΑΔΙΑΙΟ", "UNARY", Lang) Then s$ = "-:": GoTo contoper Else SyntaxError Exit Sub End If End If resp = True If FastSymbol(rest$, "!") Then basestack.nokillvars = True par = False: f = 0 ss$ = vbNullString If IsLabelSymbolNewExp(rest$, "ΚΕΝΗ", "VOID", Lang, ss$) Then par = True If IsLabelSymbolNewExp(rest$, "ΕΞΩΤΕΡΙΚΗ", "EXTERN", Lang, ss$) Then basestack.nokillvars = False If FastSymbol(rest$, ".") Then i = FastPureLabel(rest$, ss$) If GetVar(basestack, "THIS." + myUcase(ss$, True), i) Then 'ChrW(&HFFBF) + GoTo cont11 End If resp = False Exit Sub ElseIf IsExp(basestack, rest$, p) Then i = CLng(p) cont11: If i >= 0 Or i <= p Then If Not MyIsObject(var(i)) Then InternalError ElseIf TypeOf var(i) Is stdCallFunction Then Set usethis = var(i) On Error Resume Next Err.Clear If usethis.IsInterfaceCall Then CallByObject1 basestack, Not par, usethis Else CallByObject basestack, Not par, usethis End If Set basestack = Nothing If Err.Number <> 0 Then MyEr Err.Description, Err.Description End If Exit Sub Else If TypeOf var(i) Is Constant Then Set c = var(i) If Not c.flag Then InternalError resp = False Exit Sub End If Set myl = c.Value End If If (TypeOf var(i) Is lambda) Or Not myl Is Nothing Then ' call lamda If myl Is Nothing Then Set myl = var(i) PushStage basestack, False flag = False it = 1 rest$ = vbNullString myl.Name = here$ myl.CopyToVar basestack, here$ = vbNullString, var() basestack.OriginalCode = -i basestack.FuncRec = subHash.LastKnown ss$ = myl.Code$ Call Module10.executeblock(it, basestack, ss$, False, flag, , True) myl.CopyFromVar basestack, var() If it = 0 Then Set basestack.lastobj = Nothing Set basestack.FuncObj = Nothing basestack.ThrowThreads MyErMacro rest$, Chr(0) + "Problem in lambda", Chr(0) + "Πρόβλημα στη λάμδα" FK$(13) = "EDIT " & sbf(var(i).OriginalCode).goodname & "," & (-var(i).lastlen - Len(ss$) + 1) myl.lastlen = Len(ss$) PopStage basestack Set basestack = Nothing resp = False Exit Sub End If If c Is Nothing Then Set var(i) = myl ' not allow change when running PopStage basestack Set basestack = Nothing Exit Sub Else InternalError ' INVALID FUNCTION HANDLE End If End If Else ' INVALID FUNCTION HANDLE InternalError End If End If ElseIf IsLabelSymbolNewExp(rest$, "ΓΕΓΟΝΟΣ", "EVENT", Lang, ss$) Then i = Abs(IsLabel(basestack, rest$, what$)) If i = 1 Then If Not GetVar(basestack, basestack.GroupName + what$, i) Then MissPar Else If VarTypeName(var(i)) <> "mEvent" Then MyEr "Can't find Event", "Δεν μπορώ να βρω το Γεγονός" Else resp = CallEvent(basestack, rest$, Lang, i) End If End If ElseIf i = 5 Then If GetEventFromArray(basestack, rest$, what$) Then resp = CallEvent(basestack, rest$, Lang, -1) End If ElseIf i = 0 Then If ISSTRINGA(rest$, s$) Then If ThisPointer(basestack, i) Then s$ = myUcase(s$) Set Op = var(i) Set a = Op Set Op = Nothing If Not a.EventFuncPos(s$, ss$, x1) Then ' check parent If Len(basestack.UseGroupname) > 0 Then what$ = Mid$(basestack.UseGroupname, 1, Len(basestack.UseGroupname) - 1) If GetVar(basestack, what$, x1) Then If Len(what$) > Len(var(x1).GroupName) Then what$ = Left$(what$, Len(what$) - Len(var(x1).GroupName)) End If Do While GetVar(basestack, what$, x1) If Typename$(var(x1)) <> mGroup Then Exit Do Set a = var(x1) If a.EventFuncPos(s$, ss$, x1) Then If sbf(x1).goodname = ss$ Then GoTo contcallhere End If If Len(what$) > Len(var(x1).GroupName) Then what$ = Left$(what$, Len(what$) - Len(var(x1).GroupName)) Else what$ = "" End If Loop End If Set a = Nothing ThrowPar: ' THROW PARAMETERS HERE Set bs = New basetask Set bs.Owner = basestack.Owner If bs Is Nothing Then Set bs = basestack Set bs.Parent = basestack it = IsLabelSymbolNew(rest$, "ΔΙΑΔΟΧΙΚΟ", "CASCADE", Lang) bs.Look2Parent = True FastSymbol rest$, "," If Not PushParamGeneralV70(bs, rest$, "") Then Exit Sub Set bs = Nothing ElseIf Not sbf(x1).goodname = ss$ Then GoTo ThrowPar Else contcallhere: Set bs = New basetask Set bs.Owner = basestack.Owner If bs Is Nothing Then Set bs = basestack bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer bs.OriginalCode = x1 Set bs.Parent = basestack it = IsLabelSymbolNew(rest$, "ΔΙΑΔΟΧΙΚΟ", "CASCADE", Lang) If it Then Set bs.Sorosref = basestack.soros bs.Look2Parent = True FastSymbol rest$, "," If Not PushParamGeneralV70(bs, rest$, "") Then bs.Look2Parent = False Exit Sub End If bs.strg = False bs.fHere = Left$(ss$, rinstr(ss$, ".") - 1) s$ = here$ here$ = bs.fHere bs.Look2Parent = False PushStage basestack, False bs.SetSkip Module10.executeblock (0), bs, (sbf(x1).sb), (False), (flag) PopStage basestack here$ = s$ Set bs = Nothing Exit Sub End If End If End If Else MissPar End If Set basestack = Nothing Exit Sub Else flag = IsLabelSymbolNew(rest$, "ΤΟΠΙΚΑ", "LOCAL", Lang) If IsLabelSymbolNew(rest$, "ΣΥΝΑΡΤΗΣΗ", "FUNCTION", Lang) Then f = 3 reenter1: i = Abs(IsLabelNoUcase(basestack, rest$, originalwhat$)) If i <> 0 Then what$ = myUcase(originalwhat$) If i = 3 And Len(rest$) > 0 Then reenter0: If AscW(rest$) = 46 Then If Not IsStrExp(basestack, (what$), what$) Then MissPar: Set basestack = Nothing: Exit Sub i = Abs(IsLabel(basestack, rest$, s$)) what$ = what$ + "." + s$ If i = 3 And Len(rest$) > 0 Then GoTo reenter0 s$ = vbNullString End If End If reenter1Skip: If i = 0 Or i = 2 Then If i = 0 Then If Not IsStrExp(basestack, rest$, what$) Then MissPar: Set basestack = Nothing: Exit Sub End If s$ = what$ i = Abs(IsLabel(basestack, s$, what$)) If i = 0 Then If FastSymbol(s$, "{") Then reenter2: ss$ = block(s$) If FastSymbol(s$, "}") And ss$ <> "" Then PushStage basestack, False x1 = ModuleSubAsap("A_()", ss$, Trim$(s$)) Set bs = New basetask Set bs.Parent = basestack If basestack.IamThread Then Set bs.Process = basestack.Process Set bs.Sorosref = basestack.soros ' same stack Set bs.Owner = basestack.Owner bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer bs.OriginalCode = x1 bs.SetV If par Then Call GoFunc(bs, what$, rest$, vvl, , x1) Else '' no static for this type of call bs.originalname = "()" Call GoFunc(bs, what$, rest$, vvl, , x1) If Not vvl = Empty And Not flag Then vvl = CStr(vvl) X = InStr(vvl, "|") If X = 0 Then MyEr "ERROR " + vvl, "ΛΑΘΟΣ " + vvl Else MyEr "ERROR " + Left$(vvl, X - 1), "ΛΑΘΟΣ " + Mid$(vvl, X + 1) End If resp = False PopStage basestack ' this always kill vars Set basestack = Nothing: Exit Sub End If End If Set bs = Nothing basestack.nokillvars = False If LastErNum = -1 Then Set basestack = Nothing resp = False: Set basestack = Nothing: Exit Sub End If resp = True PopStage basestack ' this always kill vars Set basestack = Nothing: Exit Sub Else s$ = "Error{Bad Call}, {στη κλήση}" End If Else s$ = "Error{Bad Call}, {στη κλήση}" End If End If ' 2 If Len(s$) > 0 Then basestack.restpart = s$ End If If f > 0 And i < 5 Then i = i + 4: what$ = what$ + "(" If i = 1 Then If Right$(what$, 1) = ChrW(&H1FFF) Then i = InStr(rest$, "()") If i > 0 And i < 4 Then what$ = what$ + Left$(rest$, i + 1) rest$ = Mid$(rest$, i + 1) ' leave last ) End If End If FastSymbol rest$, "," s$ = what$ MakeThisSub basestack, what$ it = GetlocalSub(what$, x1) If Not it Then If SecureNames And basestack.IamChild Then x1 = InStrRev(here$, "»«") If x1 > 0 Then x1 = val(Mid$(here$, x1 + 2)) End If End If If here$ = what$ Then ElseIf x1 > 0 Then If Not InStr(sbf(x1).goodname, what$) - 2 = Len(here$) And Not Right$(sbf(x1).goodname, Len(what$) + 1) = "." + what$ Then i = x1 s$ = what$ If Replace(here$, ChrW(&HFFBF), "") = what$ Then it = True: x1 = basestack.OriginalCode ElseIf Len(basestack.UseGroupname) > 0 Then If InStr(what$, basestack.UseGroupname) = 1 Then what$ = basestack.UseGroupname + ChrW(&HFFBF) + Mid$(what$, Len(basestack.UseGroupname) + 1) it = GetSub(what$, x1) End If End If If it = 0 Then what$ = s$ If basestack.fHere <> "" Then If sbf(i).goodname = StripThis2(basestack.fHere + "«") + "." + s$ Then x1 = i: it = True End If Else If sbf(i).goodname = StripThis2(here$ + "«") + "." + s$ Then x1 = i: it = True Else it = subHash.Find(what$, x1) End If End If End If If it = 0 Then it = GetSub(what$, x1) Else it = True End If ElseIf Left$(basestack.fHere$, InStr(basestack.fHere$ + "«", "«") - 1) = what$ Then ' GetStrUntil("«", basestack.fHere$ + "«") it = True: x1 = basestack.OriginalCode ElseIf Not SecureNames Then If iRVAL(here$, 0) > 0 Then For i = -iRVAL(here$, 0) To -1 it = GetSub(RVAL2(here$, i) + what$, x1) If it Then Exit For Next i End If If it = 0 Then it = GetSub(what$, x1) Else it = GetSub(what$, x1) End If If it = 0 Then If Replace(here$, ChrW(&HFFBF), "") = what$ Then it = True: x1 = basestack.OriginalCode ElseIf Len(basestack.UseGroupname) > 0 Then If InStr(what$, basestack.UseGroupname) = 1 Then s$ = what$ If Len(basestack.UseGroupname) > 0 Then what$ = basestack.UseGroupname + ChrW(&HFFBF) + Mid$(what$, Len(basestack.UseGroupname) + 1) it = GetSub(what$, x1) If it = 0 Then it = GetSub(s$, x1): what$ = s$ End If End If End If End If If it Then If x1 < 0 Then basestack.callx1 = -1 basestack.tmpstr = originalwhat$ resp = True Exit Sub End If resp = True Set bs = New basetask Set bs.Parent = basestack If basestack.IamThread Then Set bs.Process = basestack.Process Set bs.Sorosref = basestack.soros ' same stack Set bs.Owner = basestack.Owner bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer bs.OriginalCode = x1 bs.SetV If Len(here$) = 0 Then ' bs.StaticInUse = what$ here$ = what$ Call GoFunc(bs, what$, rest$, vvl, , x1) here$ = vbNullString ElseIf x1 >= 0 Then If flag Then bs.UseGroupname = basestack.UseGroupname bs.GroupName = basestack.GroupName bs.StaticInUse = basestack.StaticInUse Set bs.StaticCollection = basestack.StaticCollection bs.CallLocalLast = True bs.strfunnum = basestack.strfunnum bs.strnum = basestack.strnum bs.numnum = basestack.numnum bs.numfunnum = basestack.numfunnum bs.commnum = basestack.commnum Call GoFunc(bs, "()", rest$, vvl, , x1) basestack.FuncValue = vvl Set basestack.FuncObj = bs.lastobj If LastErNum Then MyEr Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), ""), Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), "") resp = False GoTo ExitHere End If Else bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer If Left$(what$, 1) <> "_" Then If SecureNames And basestack.IamThread Then what$ = "_" + what$ + LTrim$(basestack.Process.id) End If End If bs.StaticInUse = what$ Call GoFunc(bs, "", rest$, vvl, , x1) If LastErNum Then MyEr "at " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), ""), "στο " + Replace(GetName(sbf(x1).goodname), ChrW(&HFFBF), "") resp = False GoTo ExitHere End If End If Else Call GoFunc(bs, what$, rest$, vvl) End If myerror1: Set bs = Nothing basestack.nokillvars = False If LastErNum = -1 Then Set basestack = Nothing resp = False: Set basestack = Nothing: Exit Sub End If Else par = skiperror skiperror = True If IsNumber(basestack, (what$), p, True) Then ss$ = what$ + "()" f = 3 GoTo cont00123 End If skiperror = par par = False resp = True ' new : MyEr "not found " + what$, "δεν βρέθηκε το " + what$ If it Then ElseIf Len(rest$) = 0 Then rest$ = what$ Else basestack.tmpstr = "@" + originalwhat$ + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) End If 'rest$ = rest$ End If Set basestack = Nothing: Exit Sub ElseIf i = 3 Then If IsStrExp(basestack, what$, s$) Then If Len(s$) > 0 Then If FastSymbol(s$, "{") Then GoTo reenter2 i = Abs(IsLabel(basestack, s$, what$)) If Len(s$) > 0 Then basestack.restpart = s$ s$ = vbNullString If i = 3 And Len(rest$) > 0 Then GoTo reenter0 End If GoTo reenter1Skip Else basestack.nokillvars = False resp = False Set basestack = Nothing: Exit Sub End If Else ' error basestack.nokillvars = False resp = False Set basestack = Nothing: Exit Sub End If ElseIf i > 3 Then ' call function as module '********************************************************** ss$ = what$ + ")" cont00123: FastSymbol rest$, "," MakeThisSub basestack, ss$ it = CLng(GetSub(ss$, x1)) If Not it Then it = CLng(GetlocalSub(ss$, x1)) If it = 0 Then If StripThis(here$) = ss$ Then it = True: x1 = basestack.OriginalCode ElseIf Replace(here$, ChrW(&HFFBF), "") = ss$ Then it = True: x1 = basestack.OriginalCode ElseIf InStr(what$, basestack.UseGroupname) = 1 And Not basestack.UseGroupname = vbNullString Then If Len(basestack.UseGroupname) > 0 Then ss$ = basestack.UseGroupname + ChrW(&HFFBF) + Mid$(ss$, Len(basestack.UseGroupname) + 1) it = GetSub(ss$, x1) Else If Left$(what$, 1) = "T" Or Left$(what$, 1) = "Α" Then If Left$(what$, 5) = "THIS." Or Left$(what$, 5) = "ΑΥΤΟ." Then ss$ = Left$(what$, 5) + ChrW(&HFFBF) + Mid$(what$, 6) + ")" MakeThisSub basestack, ss$ it = GetSub(ss$, x1) End If Else If Lang = 1 Then If what$ = "LAMBDA(" Then again111: If basestack.IamLambda Then ss$ = basestack.FuncRec it = GetSub(ss$, x1) Else ss$ = Mid$(here$, rinstr(here$, "».") + 2) If Right$(here$, 2) = "()" Then If Right$(here$, 2) = "()" And basestack.UseGroupname = vbNullString Then ss$ = sbf(basestack.OriginalCode).goodname x1 = basestack.OriginalCode it = 1 Else it = GetSub(ss$, x1) If Not it Then If here$ Like "*." + ss$ Then x1 = basestack.OriginalCode it = 1 End If End If End If End If End If ElseIf what$ = "LAMBDA$(" Then GoTo again111 End If Else If what$ = "ΛΑΜΔΑ(" Then GoTo again111 ElseIf what$ = "ΛΑΜΔΑ$(" Then GoTo again111 End If End If End If End If End If If it Then If x1 = -1 Then MyEr "no call for static function", "όχι τη κάλεσε σε στατική συνάρτηση" resp = False Exit Sub End If Set bs = New basetask Set bs.Parent = basestack bs.IamAnEvent = basestack.IamAnEvent If basestack.IamThread Then Set bs.Process = basestack.Process If Not TheSame(here$, ss$) Then Set bs.Sorosref = basestack.soros Set bs.Owner = basestack.Owner bs.OriginalCode = x1 bs.SetV If flag Then bs.UseGroupname = basestack.UseGroupname bs.GroupName = basestack.GroupName bs.CallLocalLast = True bs.strfunnum = basestack.strfunnum bs.strnum = basestack.strnum bs.numnum = basestack.numnum bs.numfunnum = basestack.numfunnum bs.commnum = basestack.commnum Set bs.StaticCollection = basestack.StaticCollection Call GoFunc(bs, ss$, rest$, vvl, , x1) basestack.FuncValue = vvl Set basestack.FuncObj = bs.lastobj vvl = Empty Else bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer Call GoFunc(bs, ss$, rest$, vvl, True, x1) End If Set bs = Nothing If Not par Then If InStr(ss$, "$") > 0 Then If vvl <> "" Then ' no zero we have error X = InStr(vvl, "|") If X = 0 Then MyEr "ERROR " + vvl, "ΛΑΘΟΣ " + vvl Else MyEr "ERROR " + Left$(vvl, X - 1), "ΛΑΘΟΣ " + Mid$(vvl, X + 1) End If resp = False basestack.nokillvars = False Set basestack = Nothing: Exit Sub End If Else If val(vvl) <> 0 Then ' no zero we have error MyEr "ERROR " & Int(val(vvl)), "ΛΑΘΟΣ " & Int(val(vvl)) resp = False basestack.nokillvars = False Set basestack = Nothing: Exit Sub End If End If End If Else If Not flag Then MyEr "Nothing to call", "Τίποτα για να καλέσω" resp = False Else rest$ = vbNullString End If End If ElseIf IsStrExp(basestack, rest$, s$) Then If f = 3 Then s$ = s$ + "(" FastSymbol rest$, "," If s$ <> "" Then If InStr(s$, ").") > 0 And f <> 3 Then If Right$(s$, 1) = ")" Then rest$ = s$ + " " + rest$ GoTo reenter1 Else rest$ = ": " + s$ + " " + rest$ End If Else If Right$(s$, 1) = ")" Then rest$ = Left$(s$, Len(s$) - 1) + " " + rest$ Else rest$ = s$ + " " + rest$ End If GoTo reenter1 End If End If Else rest$ = ": " + rest$ End If End If ExitHere: basestack.nokillvars = False Set basestack = Nothing End Sub Sub NeoCall2(basestack As basetask, rest$, resp As Boolean) Dim i As Long, p As Variant, par As Boolean, f As Long Dim flag As Boolean, it As Long, what$, s$, x1 As Long, ss$, bs As basetask, vvl As Variant, X As Double resp = True i = Abs(IsLabel(basestack, rest$, what$)) If i = 1 Then If Right$(what$, 1) = ChrW(&H1FFF) Then i = InStr(rest$, "()") If i > 0 And i < 4 Then what$ = what$ + Left$(rest$, i + 1) Mid$(rest$, 1, i) = space(i) End If End If JUMPHERE: MakeThisSub basestack, what$ it = GetlocalSub(what$, x1) If Not it Then it = GetSub(what$, x1) If Not it Then If here$ = what$ Then it = True: x1 = basestack.OriginalCode Else For i = -iRVAL(here$, 0) To -1 it = GetSub(RVAL2(here$, i) + what$, x1) If it Then Exit For Next i End If If it = 0 Then If StripThis(here$) = what$ Then it = True: x1 = basestack.OriginalCode ElseIf Replace(here$, ChrW(&HFFBF), "") = what$ Then it = True: x1 = basestack.OriginalCode ElseIf InStr(what$, basestack.UseGroupname) = 1 Then what$ = basestack.UseGroupname + ChrW(&HFFBF) + Mid$(what$, Len(basestack.UseGroupname) + 1) it = GetSub(what$, x1) End If End If End If If it Then resp = True Set bs = New basetask Set bs.Parent = basestack If basestack.IamThread Then Set bs.Process = basestack.Process Set bs.Sorosref = basestack.soros ' same stack Set bs.Owner = basestack.Owner bs.UseGroupname = sbf(x1).sbgroup bs.tpointer = sbf(x1).tpointer bs.OriginalCode = x1 bs.SetV If LenB(here$) = 0 Then here$ = what$ Call GoFunc(bs, what$, rest$, vvl, , x1) here$ = vbNullString ElseIf x1 >= 0 Then ' bs.UseGroupname = sbf(x1).sbgroup 'bs.tpointer = sbf(x1).tpointer bs.StaticInUse = what$ Call GoFunc(bs, "", rest$, vvl, , x1) Else Call GoFunc(bs, what$, rest$, vvl) End If myerror1: ' If Not bs.StaticCollection Is Nothing Then ' basestack.Parent.SetVarobJ "%_" + bs.StaticInUse, bs.StaticCollection ' End If Set bs = Nothing If LastErNum = -1 Then resp = False: Exit Sub End If Else resp = False rest$ = ":" + what$ + " " + rest$ End If ElseIf i = 7 Then what$ = what$ + ")" GoTo JUMPHERE End If End Sub Function myStructure(basestack As basetask, rest$, Lang As Long) As Boolean Dim Base As String If IsStrExp(basestack, rest$, Base) Then myStructure = TABLENAMES(Base, basestack, rest$, Lang) Else myStructure = makestruct(basestack, rest$, Lang, here$ = "", False) End If End Function Private Function Between(a, b, c, Optional exclude) As Boolean If IsMissing(exclude) Then Between = a >= b And a <= c Else Between = (a >= b And a <= c) And Not a = exclude End If End Function Function StructPage(basestack As basetask, rest$, Lang As Long, ByVal Offset As Long, ByRef offset2 As Long, offsetlist As StructCollection, ByVal lasthead$) As Boolean Dim what$, offset1 As Long, i As Long, s$, b$, p As Variant, w2 As Long, maxOffset As Long, probeoffset As Long, usehandler As mHandler, localList As StructCollection Dim itisSingle As Boolean, itisCur As Boolean b$ = NLtrim$(block(rest$)) If Not FastSymbol(rest$, "}") Then Exit Function If FastSymbol(b$, vbCrLf, , 2) Then GoTo cont567 Else GoTo again1 End If again: If FastSymbol(b$, vbCrLf, , 2) Then cont567: Do While FastSymbol(b$, vbCrLf, , 2) Wend Loop Until Not NocharsInLine(b$) Or b$ = vbNullString again1: Set localList = Nothing itisSingle = False itisCur = False If MaybeIsSymbol(b$, "/\'") Then SetNextLineNL b$ Do While FastSymbol(b$, vbCrLf, , 2) Wend Loop Until Not NocharsInLine(b$) Or b$ = vbNullString GoTo again1 ElseIf FastSymbol(b$, "{") Then ' IS A NEW PAGE probeoffset = 0 If StructPage(basestack, b$, Lang, Offset, probeoffset, offsetlist, lasthead$) Then If FastSymbol(b$, ";") Then Offset = probeoffset Else FastSymbol b$, "," End If If probeoffset > maxOffset Then maxOffset = probeoffset ' leave offset as is GoTo cont567 Else Exit Function End If ElseIf Between(FastPureLabel(b$, what$), 1, 3, 2) Then Do '' check type, or by default use 2 If IsLabelSymbolNew(what$, "ΔΟΜΗ", "STRUCTURE", Lang) Then If FastPureLabel(b$, what$) = 1 Then If FastSymbol(b$, "{") Then probeoffset = 0 If offsetlist.ExistKey(lasthead$ + what$) Then MyEr "double name is same struct", "διπλή εισαγωγή ονόματος" StructPage = False Set offsetlist = Nothing Exit Function End If If StructPage(basestack, b$, Lang, Offset, probeoffset, offsetlist, lasthead$ + what$ + ".") Then If FastSymbol(b$, "*") Then p = 1& If Not IsExp(basestack, b$, p) Then MissNumExpr: Exit Function p = MyRound(p) If p * (probeoffset - Offset) + Offset > &H1FFFFFFF Then ' half gigabyte for struct (is very big too) GoTo err111 ElseIf p <= 0 Then GoTo err222 End If probeoffset = p * (probeoffset - Offset) + Offset End If If probeoffset > maxOffset Then maxOffset = probeoffset ' leave offset as is offsetlist.AddKeyStruct myUcase(lasthead$ + what$, True), Offset, 1&, Nothing If offsetlist.Done Then offsetlist.sValue = probeoffset - Offset If FastSymbol(b$, ";") Then Offset = probeoffset End If ' keytype not used for strucrures except for single values ' so Eval() can read single from 4 bytes If itisSingle Then offsetlist.KeyTypeValue = CInt(vbSingle): itisSingle = False If itisCur Then offsetlist.KeyTypeValue = CInt(vbCurrency): itisCur = False End If FastSymbol b$, "," GoTo cont567 Else Exit Function End If Else Exit Function End If Else Exit Function End If ElseIf IsLabelSymbolNew(b$, "ΩΣ", "AS", Lang) Then itisSingle = False itisCur = False If IsLabelSymbolNew(b$, "ΨΗΦΙΟ", "BYTE", Lang) Then offset1 = 1 ElseIf IsLabelSymbolNew(b$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then offset1 = 2 ElseIf IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then offset1 = -8 ' negative for long long? Else offset1 = 4 End If ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then offset1 = 8 itisCur = True ElseIf IsLabelSymbolNew(b$, "ΑΠΛΟΣ", "SINGLE", Lang) Then offset1 = 4 itisSingle = True ElseIf IsLabelSymbolNew(b$, "ΓΡΑΜΜΑ", "STRING", Lang) Then offset1 = -4 ElseIf IsLabelSymbolNew(b$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then offset1 = 8 Else If Abs(IsLabel(basestack, b$, s$)) = 1 Then If GetVar3(basestack, basestack.GroupName + s$, i) Then If IsExp(basestack, basestack.GroupName + s$, p) Then If basestack.lastobj Is Nothing Then GoTo comehere If Not TypeOf basestack.lastobj Is mHandler Then GoTo comehere Set usehandler = basestack.lastobj If Not TypeOf usehandler.objref Is StructCollection Then GoTo comehere Set localList = usehandler.objref If localList.structLen = 0 Then GoTo comehere offset1 = localList.structLen Set usehandler = Nothing Set basestack.lastobj = Nothing Else GoTo comehere End If Else If IsExp(basestack, s$, p) Then If basestack.lastobj Is Nothing Then GoTo comehere If Not TypeOf basestack.lastobj Is mHandler Then GoTo comehere Set usehandler = basestack.lastobj If Not TypeOf usehandler.objref Is StructCollection Then GoTo comehere If usehandler.objref.structLen = 0 Then GoTo comehere offset1 = usehandler.objref.structLen Set basestack.lastobj = Nothing Set usehandler = Nothing Else GoTo comehere End If End If Else comehere: SyntaxError Exit Function End If End If Else ' check here If GetVar3(basestack, basestack.GroupName + myUcase(what$, True), i) Then foundit: If IsmHandler(var(i)) Then Set usehandler = var(i) If usehandler.t1 = 5 Then Set localList = usehandler.objref For i = 0 To Len(localList.Count - 1) If offsetlist.Find(myUcase(lasthead$ + localList.KeyToString3(i), True)) Then MyEr "double name is same struct", "διπλή εισαγωγή ονόματος" StructPage = False Set offsetlist = Nothing Exit Function End If Next localList.MergeCollection offsetlist, Offset, myUcase(lasthead$, True) offset1 = localList.structLen offsetlist.AddKeyStruct myUcase(lasthead$ + what$, True), Offset, 1&, localList Set localList = Nothing If maxOffset < Offset + offset1 Then offset2 = Offset + offset1 Else offset2 = maxOffset End If If FastSymbol(b$, ";") Then Offset = Offset + offset1 Else FastSymbol b$, "," End If If offset2 > maxOffset Then maxOffset = offset2 If offsetlist.Done Then offsetlist.sValue = offset1 End If 'If offsetlist.Done Then ' offsetlist.sValue = probeoffset - offset ' If FastSymbol(b$, ";") Then ' offset = probeoffset ' Else ' While FastSymbol(b$, ",") ' Wend ' End If ' End If GoTo cont567 Else offset1 = 2 End If Else offset1 = 2 End If ' ChrW(&HFFBF) + ElseIf GetVar3(basestack, basestack.GroupName + ChrW(&HFFBF) + myUcase(what$, True), i) Then GoTo foundit Else offset1 = 2 End If End If w2 = offset1 ' negative offset for strings p = 1 If FastSymbol(b$, "*") Then If Not IsExp(basestack, b$, p) Then MissNumExpr Exit Function Else p = MyRound(p) If p * Abs(offset1) + Offset > &H1FFFFFFF Then ' half gigabyte for struct (is very big too) err111: MyEr "Too big size for struct", "Μεγάλο μέγεθος για δομή" Exit Function ElseIf p <= 0 Then err222: MyEr "size is zero or less for struct", "Μεγάλο νούμερο για δομή" Exit Function Else offset1 = offset1 * CLng(p) End If End If End If If offsetlist.ExistKey(lasthead$ + what$) Then MyEr "double name is same struct", "διπλή εισαγωγή ονόματος" StructPage = False Set offsetlist = Nothing Exit Function End If 'offsetlist.AddKey myUcase(lasthead$ + what$, True), CVar(offset) If p <= 0 Then p = 1 offsetlist.AddKeyStruct myUcase(lasthead$ + what$, True), Offset, CLng(p), localList If offsetlist.Done Then offsetlist.sValue = w2 If itisSingle Then offsetlist.KeyTypeValue = CInt(vbSingle): itisSingle = False If itisCur Then offsetlist.KeyTypeValue = CInt(vbCurrency): itisCur = False Offset = Offset + Abs(offset1) If FastSymbol(b$, ",") Then If NocharsInLine(b$) Or b$ = vbNullString Then GoTo cont147 End If While FastSymbol(b$, vbCrLf, , 2) Wend Else SetNextLineNL b$ Do While FastSymbol(b$, vbCrLf, , 2) Wend Loop Until Not NocharsInLine(b$) Or b$ = vbNullString End If cont147: If MaybeIsSymbol(b$, "{") Then GoTo a192929 Loop Until Not Between(FastPureLabel(b$, what$), 1, 3, 2) a192929: If maxOffset < Offset Then offset2 = Offset Else offset2 = maxOffset End If StructPage = True GoTo again1 End If If maxOffset < Offset Then offset2 = Offset Else offset2 = maxOffset End If StructPage = True If offset2 < maxOffset Then offset2 = maxOffset StructPage = True End If End If End Function Function MyLet(bstack As basetask, rest$, Lang As Long) As Boolean Dim what$, ss$, s$, i As Long, x1 As Long, flag As Boolean MyLet = True Dim whatplus$, x2 As Long Do whatplus$ = vbNullString x1 = Abs(IsLabelBig(bstack, rest$, what$)) If x1 <> 0 Then If x1 = 8 Then ss$ = BlockParamSq(rest$) i = Len(ss$) If i = 0 Then SyntaxError: MyLet = False: Exit Function Mid$(rest$, 1, i) = space(i) i = i + 1 If Mid$(rest$, i, 2) = "][" Then While Mid$(rest$, i, 2) = "][" Mid$(rest$, i, 2) = " " s$ = BlockParamSq(rest$) If Len(s$) - i < 2 Then SyntaxError: MyLet = False: Exit Function Mid$(rest$, 1, Len(s$)) = space(Len(s$)) ss$ = ss$ + "][" + Trim(s$) i = 1 + Len(s$) Wend End If If Mid$(rest$, i, 1) <> "]" Then SyntaxError: MyLet = False: Exit Function Mid$(rest$, i, 1) = " " what$ = what$ + "[" + ss$ + "]" ElseIf x1 > 4 Then j4: ss$ = BlockParam(rest$) If x1 > 4 Then what$ = what$ + ss$ + ")" Else whatplus$ = whatplus$ + ss$ + ")" End If Mid$(rest$, 1, Len(ss$) + 1) = space(Len(ss$) + 1) Do While IsSymbol(rest$, ".") x1 = IsLabel(bstack, rest$, ss$) If x1 > 0 Then what$ = what$ + "." + ss$ Else Exit Do If x1 > 4 Then ss$ = BlockParam(rest$) what$ = what$ + ss$ + ")" Mid$(rest$, 1, Len(ss$) + 1) = space(Len(ss$) + 1) End If Loop End If j0: If FastSymbol(rest$, "=") Then i = 1 aheadstatus rest$, False, i If i > 1 Then ss$ = Left$(rest$, i - 1) flag = MyPush(bstack, ss$) If LastErNum = -2 Then rest$ = ss$ + Mid$(rest$, i) MyLet = flag Exit Function ElseIf NLtrim(ss$) <> vbNullString Then SyntaxError Exit Function End If If MyLet Then ' If x1 = 8 Then ' MyLet = MyRead(6, bstack, s$, 1, s$, x1) ' Else If Len(whatplus$) > 0 Then If x1 = 1 Then MyLet = MyRead(6, bstack, whatplus$, Lang, what$, x1) Else MyLet = MyRead(6, bstack, what$ + whatplus$, Lang, what$, x1) End If Else MyLet = MyRead(6, bstack, what$, Lang, what$, x1) End If rest$ = Mid$(rest$, i) Else MyEr "Nothing to assign", "Τίποτα για να δώσω" Exit Function End If Else MyEr "Expecting expression", "Περίμενα έκφραση" MyLet = False End If ElseIf FastSymbol(rest$, "|") Then x2 = Abs(IsLabelBig(bstack, rest$, whatplus$)) If x2 > 0 Then If x2 > 4 Then If x1 < 5 Then whatplus$ = "|" + whatplus$ Else what$ = what$ + "|" + whatplus$ whatplus$ = "" End If GoTo j4 End If whatplus$ = "|" + whatplus$ GoTo j0 End If End If End If Loop Until Not FastSymbol(rest$, ",") End Function Function MyThread(bstack As basetask, rest$, Lang As Long) As Boolean Dim frm$, ss$, what$, i As Long, p As Variant, X As Double, par As Boolean, bs As basetask Dim addlen As Long MyThread = True If FastSymbol(rest$, "{") Then frm$ = NLtrim$(block(rest$)) addlen = Len(rest$) If FastSymbol(rest$, "}") Then par = False If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then Else MyEr "can't find clause AS variable_name", "δεν μπορώ να βρώ το μέρος ΩΣ ονομα_μεταβλητής" MyThread = False Exit Function End If Select Case Abs(IsLabel(bstack, rest$, what$)) ' is Ifier Case 1 p = GetTaskId + 20000 If GetVar(bstack, what$, i) Then ' if exist var(i) = p Else globalvar what$, p ' or make one End If Set bs = New basetask ' bs is the basetask of the thread but thread process class arn't constructed yet Set bs.Parent = bstack ' link to current basestask bs.addlen = addlen + bstack.addlen + 1 bstack.PushThread CLng(p), what$ 'push thread id and Ifier to threads collection in current basetask sThreadInternal bs, p, 0, frm$, -1&, here$, False ' thread construction - also we have a connection to Set bs = Nothing ss$ = vbNullString If IsLabelSymbolNewExp(rest$, "ΚΑΘΕ", "INTERVAL", Lang, ss$) Then GoTo chekInterval ElseIf IsLabelSymbolNewExp(rest$, "ΕΚΤΕΛΕΣΗ", "EXECUTE", Lang, ss$) Then If FastSymbol(rest$, "{") Then frm$ = NLtrim$(block(rest$)) If FastSymbol(rest$, "}") Then TaskMaster.Message CLng(p), 5, , frm$ Else SyntaxError MyThread = False End If Else TaskMaster.Message CLng(p), 4, , rest$ End If End If Case Else MissingnumVar MyThread = False Exit Function End Select End If ElseIf IsExp(bstack, rest$, p, flatobject:=True, nostring:=True) Then ss$ = vbNullString If IsLabelSymbolNewExp(rest$, "ΣΒΗΣΕ", "ERASE", Lang, ss$) Then If Not bstack.ThrowOne(CLng(p)) Then TaskMaster.ThrowOne (CLng(p)) End If ElseIf IsLabelSymbolNewExp(rest$, "ΚΡΑΤΑ", "HOLD", Lang, ss$) Then TaskMaster.Message CLng(p), 0 ElseIf IsLabelSymbolNewExp(rest$, "ΕΚΤΕΛΕΣΗ", "EXECUTE", Lang, ss$) Then If FastSymbol(rest$, "{") Then frm$ = NLtrim$(block(rest$)) If FastSymbol(rest$, "}") Then TaskMaster.Message CLng(p), 5, , frm$ Else SyntaxError MyThread = False End If Else TaskMaster.Message CLng(p), 4, , rest$ End If ElseIf IsLabelSymbolNewExp(rest$, "ΞΕΚΙΝΑ", "RESTART", Lang, ss$) Then TaskMaster.Message CLng(p), 2 ElseIf IsLabelSymbolNewExp(rest$, "ΚΑΘΕ", "INTERVAL", Lang, ss$) Then chekInterval: If IsExp(bstack, rest$, X, flatobject:=True, nostring:=True) Then If X < 2 Then X = 2 TaskMaster.Message CLng(p), 3, CLng(X) Else MisInterval MyThread = False End If Else NoClauseInThread MyThread = False End If End If what$ = vbNullString End Function Function ObjFromPtr(ByVal Ptr As Long) As Object ObjSetAddRef ObjFromPtr, Ptr End Function Function AssignTypeNumeric(v, ByVal i As Integer) As Boolean If myVarType(v, i) Then AssignTypeNumeric = True: Exit Function On Error GoTo there Select Case i Case vbBoolean v = CBool(v) Case vbCurrency v = CCur(v) Case vbDecimal v = CDec(v) Case vbLong v = CLng(v) Case vbSingle v = CSng(v) Case vbInteger v = CInt(v) Case 20 v = cInt64(v) Case vbDouble v = CDbl(v) Case vbByte v = CByte(v) Case vbDate v = CDate(v) Case vbUserDefinedType 'If MemInt(VarPtr(v)) <> I Then 'MissType 'Exit Function 'End If Case vbString MissStringExpr Exit Function End Select AssignTypeNumeric = True Exit Function there: If Err = 6 Then Err.Clear OverflowValue CInt(i) Exit Function End If MyEr "Can't convert value", "Δεν μπορώ να μετατρέψω την τιμή" End Function Function AssignTypeNumeric2(v, ByVal i As Integer) As Boolean If myVarType(v, i) Then AssignTypeNumeric2 = True: Exit Function On Error GoTo there Select Case i Case vbBoolean v = CBool(v) Case vbCurrency v = CCur(v) Case vbDecimal v = CDec(v) Case vbLong v = CLng(v) Case vbSingle v = CSng(v) Case vbInteger v = CInt(v) Case 20 v = cInt64(v) Case vbByte v = CByte(v) Case vbDate v = CDate(v) Case vbUserDefinedType If MemInt(VarPtr(v)) <> i Then MissType Exit Function End If Case vbString v = vbNullString Case Else v = CDbl(v) End Select AssignTypeNumeric2 = True Exit Function there: End Function Function MyPush(bstack As basetask, rest$) As Boolean Dim s$, p As Variant, usehandler As mHandler MyPush = True Do If FastSymbol(rest$, "!") Then If IsExp(bstack, rest$, p, nostring:=True) Then If bstack.lastobj Is Nothing Then bstack.soros.PushValLong CLng(p) ElseIf TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If TypeOf usehandler.objref Is mStiva Then bstack.soros.MergeTop usehandler.objref ElseIf TypeOf usehandler.objref Is iBoxArray Then bstack.soros.MergeTopCopyArray usehandler.objref Else myp123: MyPush = False MyEr "Expected Stack Object or Array after !", "Περίμενα αντικείμενο Σωρό ή πίνακα μετά το !" Set bstack.lastobj = Nothing Exit Function End If Set bstack.lastobj = Nothing Set usehandler = Nothing ElseIf TypeOf bstack.lastobj Is iBoxArray Then bstack.soros.MergeTopCopyArray bstack.lastobj Set bstack.lastobj = Nothing Else GoTo myp123 End If End If ElseIf IsExp(bstack, rest$, p) Then If bstack.lastobj Is Nothing Then If myVarType(p, vbString) Then SwapString2Variant s$, p bstack.soros.PushStr s$ Else bstack.soros.PushVal p End If Else If TypeOf bstack.lastobj Is mStiva Then Set bstack.Sorosref = bstack.lastobj ElseIf TypeOf bstack.lastobj Is VarItem Then bstack.soros.PushObjVarItem bstack.lastobj Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If bstack.soros.PushObj bstack.lastobj Set bstack.lastpointer = Nothing End If Set bstack.lastobj = Nothing End If ElseIf IsStrExp(bstack, rest$, s$, False) Then If bstack.lastobj Is Nothing Then bstack.soros.PushStr s$ Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If bstack.soros.PushObj bstack.lastobj Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing End If Else MyPush = LastErNum1 = 0 Exit Do End If If Not FastSymbol(rest$, ",") Then Exit Do Loop End Function Function MyData(bstack As basetask, rest$) As Boolean Dim s$, p As Variant, usehandler As mHandler MyData = True Do If FastSymbol(rest$, "!") Then If IsExp(bstack, rest$, p, nostring:=True) Then If bstack.lastobj Is Nothing Then bstack.soros.DataValLong p ElseIf TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If TypeOf usehandler.objref Is mStiva Then bstack.soros.MergeBottom usehandler.objref ElseIf TypeOf usehandler.objref Is iBoxArray Then bstack.soros.MergeBottomCopyArray usehandler.objref Else myd123: MyData = False MyEr "Expected Stack Object or Array after !", "Περίμενα αντικείμενο Σωρό ή πίνακα μετά το !" Set bstack.lastobj = Nothing Exit Function End If Set usehandler = Nothing ElseIf TypeOf bstack.lastobj Is iBoxArray Then bstack.soros.MergeBottomCopyArray bstack.lastobj Else GoTo myd123 End If End If Set bstack.lastobj = Nothing ElseIf IsExp(bstack, rest$, p) Then If bstack.lastobj Is Nothing Then If myVarType(p, vbString) Then SwapString2Variant s$, p bstack.soros.DataStr s$ Else bstack.soros.DataVal p End If Else If TypeOf bstack.lastobj Is mStiva Then Set bstack.Sorosref = bstack.lastobj ElseIf TypeOf bstack.lastobj Is VarItem Then bstack.soros.DataObjVaritem bstack.lastobj Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If bstack.soros.DataObj bstack.lastobj Set bstack.lastpointer = Nothing End If Set bstack.lastobj = Nothing End If ElseIf IsStrExp(bstack, rest$, s$, False) Then If bstack.lastobj Is Nothing Then bstack.soros.DataStr s$ Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If bstack.soros.DataObj bstack.lastobj Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing End If Else MyData = LastErNum1 = 0 Exit Do End If If Not FastSymbol(rest$, ",") Then Exit Do Loop End Function Function MyClear(bstack As basetask, rest$) As Boolean Dim curbstack As basetask, i As Long, y1 As Long, what$, it As Long, pppp As iBoxArray, myobject As mStiva Dim usehandler As mHandler MyClear = True Do y1 = Abs(IsLabel(bstack, rest$, what$)) If y1 = 3 Then If GetVar(bstack, what$, i) Then If VarTypeName(var(i)) = doc Then Set var(i) = New Document var(i).LCID = LCID_DEF var(i).textDoc = vbNullString Else var(i) = vbNullString End If Else globalvar what$, "" End If ElseIf y1 < 5 And y1 > 0 Then If GetVar(bstack, what$, i) Then If MyIsObject(var(i)) Then ' PUT ZERO TO VARIABLES INSIDE GROUP If Typename(var(i)) = "lambda" Then Set var(i) = Nothing Dim ok As Boolean var(i) = 0& ElseIf Typename(var(i)) = mGroup Then If Not var(i).IamCleared Then CallClear bstack, what$, var(i) If var(i).IamApointer Then Set var(i) = New Group Else var(i).ResetGroup End If End If ElseIf Typename(var(i)) = mHdlr Then Set usehandler = var(i) If usehandler.t1 = 1 Then If usehandler.ReadOnly Then ReadOnly MyClear = False Exit Function End If If usehandler.UseIterator Then ReadOnly MyClear = False Exit Function End If If usehandler.objref.IsQueue Then Set var(i) = Nothing MakeitObjectInventory var(i), True Else Set var(i) = Nothing MakeitObjectInventory var(i) End If ElseIf usehandler.t1 = 2 Then Set usehandler = New mHandler Set var(i) = usehandler usehandler.t1 = 2 Set usehandler.objref = New MemBlock ElseIf usehandler.UseIterator Then Set var(i) = Nothing var(i) = 0& ElseIf Typename$(usehandler.objref) = myArray Then Set usehandler.objref = New mArray ElseIf Typename$(usehandler.objref) = "tuple" Then usehandler.objref.flushTuple ElseIf Typename$(usehandler.objref) = "mStiva" Then Set usehandler.objref = NewmStiva End If ElseIf Typename(var(i)) = "tuple" Then var(i).flushTuple Else var(i) = Empty End If ElseIf myVarType(var(i), vbLong) Then var(i) = 0& ElseIf myVarType(var(i), vbString) Then var(i) = vbNullString Else var(i) = 0# End If Else globalvar what$, it End If ElseIf y1 = 5 Or y1 = 7 Then If neoGetArray(bstack, what$, pppp) Then If Not pppp.arr Then NotArray: MyClear = False: Exit Function If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$) Then MyClear = False: Exit Function If pppp.ItemType(it) = mGroup Then Set pppp.item(it) = Nothing EmptyVariantArrayItem pppp, it ElseIf pppp.ItemType(it) = "lambda" Then Set pppp.item(it) = Nothing EmptyVariantArrayItem pppp, it Else SyntaxError MyClear = False End If Else SyntaxError MyClear = False End If ElseIf y1 = 6 Then If neoGetArray(bstack, what$, pppp) Then If Not pppp.arr Then NotArray: MyClear = False: Exit Function If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$) Then MyClear = False: Exit Function If pppp.ItemType(it) = mGroup Then Set pppp.item(it) = Nothing EmptyVariantArrayItem pppp, it ElseIf pppp.ItemType(it) = doc Then Set pppp.item(it) = New Document pppp.item(it).textDoc = vbNullString ElseIf pppp.ItemType(it) = "lambda" Then Set pppp.item(it) = Nothing EmptyVariantArrayItem pppp, it Else pppp.item(it) = vbNullString End If Else SyntaxError MyClear = False End If ElseIf y1 > 0 Then SyntaxError MyClear = False Else Form1.List1.Clear If bstack.IamThread Then If Not bstack.StaticCollection Is Nothing Then Set bstack.StaticCollection = Nothing End If ElseIf bstack.IamAnEvent Then If Not bstack.StaticCollection Is Nothing Then If Not bstack.Parent Is Nothing Then If Not bstack.Parent.StaticCollection Is Nothing Then If bstack.Parent.StaticCollection.ExistKey("%_" + here$) Then bstack.Parent.StaticCollection.RemoveWithNoFind End If End If End If Set bstack.StaticCollection = Nothing Else MyEr "Only static variables can clear in an event", "Μόνο στατικές μπορώ να σβήσω σε ένα γεγονός" End If Else bstack.clearbasket Set curbstack = bstack again1234: If curbstack.IamChild Then If curbstack.IamThread Then Set curbstack = Nothing: Exit Function If Not curbstack.Parent.IamChild And Not curbstack.Parent.IamAnEvent Then Set EventStaticCollection = New FastCollection End If If curbstack.IamAnEvent Then Set curbstack = Nothing: Exit Function With curbstack If .SkipClear > 0 Then Set curbstack = Nothing: Exit Function var2used = curbstack.Vars varhash.ReduceHash curbstack.Vname, var() End With Exit Function End If GarbageFlush Set curbstack = Nothing Set EventStaticCollection = New FastCollection Set bstack.StaticCollection = Nothing varhash.ReduceHash 0, var() varhash.BigSize 3000 var2used = 0 ReDim var(3000) As Variant Set curbstack = bstack again12345: If curbstack.IamChild Then With curbstack If .Vars = 0 Then Set curbstack = Nothing: Exit Function .Vars = 0 End With Set curbstack = curbstack.Parent GoTo again12345 End If Set curbstack = Nothing End If Exit Do End If If Not MyClear Then Exit Do Loop Until Not FastSymbol(rest$, ",") End Function Function MyMethod(bstack As basetask, rest$, Lang As Long, groupok As Boolean, prive As Boolean) As Boolean Dim i As Long, s$, pppp As iBoxArray, pa$, ok As Boolean, r As Variant, j As Integer Dim s1$ i = Abs(IsLabel(bstack, rest$, s$)) 'I = Abs(innerIsLabel(bstack, rest$, s$, , True, True)) If Not groupok Then Else s1$ = bstack.GroupName + ChrW(&HFFBF) + s$ s$ = bstack.GroupName + s$ End If MyMethod = True ok = True If i = 1 Or i = 3 Then If GetVar(bstack, s$, i) Then CONT1234: j = MemInt(VarPtr(var(i))) If j = 9 Or j = 13 Then If var(i) Is Nothing Then MissingObj Else Dim p IsSymbol3 rest$, "," If IsExp(bstack, rest$, p) Then If Not bstack.lastobj Is Nothing Then Exit Function End If If MemInt(VarPtr(p)) = vbString Then SwapString2Variant pa$, p ProcMethod bstack, var(), i, pa$, rest$, Lang, ok, groupok, prive Else MyEr "not ready yet", "δεν δουλεύει ακόμα" End If ElseIf IsStrExp(bstack, rest$, pa$, False) Then ProcMethod bstack, var(), i, pa$, rest$, Lang, ok, groupok, prive End If MyMethod = ((Err = 0) And ok) Err.Clear End If Else MyMethod = False MissingObjRef End If Exit Function Else If GetVar(bstack, s1$, i) Then GoTo CONT1234 End If Nosuchvariable s$ End If ElseIf i = 5 Or i = 6 Then If neoGetArray(bstack, s$, pppp) Then again11: If NeoGetArrayItem(pppp, bstack, s$, i, rest$) Then If FastSymbol(rest$, "(") Then If MyIsObject(pppp.item(i)) Then If pppp.itemObject(i) Is Nothing Then WrongObject MyMethod = False Exit Function ElseIf TypeOf pppp.itemObject(i) Is iBoxArray Then Set pppp = pppp.item(i) Else Dim pppp1 As ppppLight Set pppp1 = New ppppLight pppp1.arr = False Set pppp1.GroupRef = pppp.item(i) Set pppp = pppp1 Set pppp1 = Nothing End If GoTo again11 End If End If IsSymbol3 rest$, "," If IsStrExp(bstack, rest$, pa$) Then ProcMethodArray bstack, pppp, i, pa$, rest$, Lang, MyMethod, groupok, prive End If End If Else MyMethod = False MissingObj End If End If End Function Function GetEventFromArray(basestack As basetask, rest$, what$) As Boolean Dim pppp As iBoxArray, x1 As Long If neoGetArray(basestack, what$, pppp) Then If Not NeoGetArrayItem(pppp, basestack, what$, x1, rest$, True) Then Exit Function If MyIsObject(pppp.item(x1)) Then GetEventFromArray = True Set basestack.lastobj = pppp.item(x1) Exit Function Else MyEr "Not an Event object", "Όχι ένα αντικείμενο Γεγονός" Exit Function End If End If End Function Function myEvent(basestack As basetask, rest$, Lang As Long, Optional alocal As Boolean) Dim x1 As Long, what$, i As Long myEvent = True x1 = Abs(IsLabel(basestack, rest$, what$)) If x1 <> 1 Then If x1 = 5 Then Dim pppp As iBoxArray If neoGetArray(basestack, what$, pppp) Then If Not NeoGetArrayItem(pppp, basestack, what$, x1, rest$, True) Then Exit Function If MyIsObject(pppp.item(x1)) Then Set basestack.lastobj = pppp.item(x1) myEvent = ProcEvent(basestack, rest$, Lang, -1) Exit Function Else MyEr "Not an Event object", "Όχι ένα αντικείμενο Γεγονός" myEvent = False: Exit Function End If End If Else myEvent = False: Exit Function End If End If If basestack.priveflag Then what$ = ChrW(&HFFBF) + what$ If alocal Then i = globalvar(basestack.GroupName + what$, Empty) MakeitObjectEvent var(i) ElseIf GetlocalVar(basestack.GroupName + what$, i) Then ' we found it ElseIf GetVar(basestack, basestack.GroupName + what$, i) Then ' we found it Else i = globalvar(basestack.GroupName + what$, Empty) MakeitObjectEvent var(i) End If myEvent = ProcEvent(basestack, rest$, Lang, i) End Function Function MyReport(bstack As basetask, rest$, Lang As Long) As Boolean Dim p As Variant, prive As Long, X As Double, Y As Double, y1 As Long, x1 As Long, it As Long Dim s$, i As Long, pa$, sx As Double Dim Hold As Boolean MyReport = False prive = GetCode(bstack.Owner) If FastSymbol(rest$, "!") Then If IsExp(bstack, rest$, p, flatobject:=True, nostring:=True) Then ReportTabWidth = Abs(p) players(prive).ReportTab = ReportTabWidth MyReport = True End If Exit Function End If If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then s$ = p: p = 0: GoTo there123 If Not FastSymbol(rest$, ",") Then MissPar:: Exit Function Else p = 0 End If If IsFlatStringExpr(bstack, rest$, s$) Then there123: X = bstack.Owner.Width If lookOne(rest$, ";") Then SyntaxError: Exit Function If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, X) Then: Exit Function With players(prive) If X <= .mX Then X = X * .Xt - 2 * dv15 bstack.Owner.currentX = bstack.Owner.currentX + dv15 ElseIf bstack.toprinter Then If prFactor > 0 Then X = X / prFactor End If End With End If If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, Y) Then: Exit Function y1 = Y - 1 If IsLabelSymbolNew(rest$, "ΓΡΑΜΜΗ", "LINE", Lang) Then If Not IsExp(bstack, rest$, sx) Then Exit Function x1 = sx - 1 If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then wwPlain bstack, players(prive), s$, CLng(X), y1, , , CLng(p), x1, , , True bstack.tmpstr = "®" + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) If Not Module10.executeblock(i, bstack, rest$, True, False, , True) Then ' error ?? End If Else Hold = IsLabelSymbolNew(rest$, "ΚΥΛΙΣΗ", "SCROLL", Lang) wwPlain bstack, players(prive), s$, CLng(X), y1, Hold, , CLng(p), x1, , , , , Hold End If Else If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then wwPlain bstack, players(prive), s$, CLng(X), y1, , , CLng(p), , it, , True bstack.tmpstr = "®" + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) If Not Module10.executeblock(i, bstack, rest$, True, False, , True) Then ' error ? End If Else Hold = IsLabelSymbolNew(rest$, "ΚΥΛΙΣΗ", "SCROLL", Lang) wwPlain bstack, players(prive), s$, CLng(X), y1, Hold, , CLng(p), , it, , , , Hold End If End If players(prive).LastReportLines = CDbl(it) Else wwPlain bstack, players(prive), s$, CLng(X), 100000, True, , CLng(p), , it players(prive).LastReportLines = -1 End If MyReport = True Else If LastErNum <> 0 Then LastErNum = 0: Exit Function 'ifier=true End If End Function Function MyInput(bstack As basetask, rest$, Lang As Long) As Boolean Dim i As Long, p As Variant, pp As Variant, s$, ss$, what$, f As Long, x1 As Long, Y As Double, X As Double Dim frm$, par As Boolean, pppp As iBoxArray, prive As Long, it As Long, W$, mystack As mStiva, integ As Boolean, noexp As Boolean Dim rpos As Long, rrow As Long, ex$, Final$, ok As Boolean, pppp1 As ppppLight, sp$, ppp If IsLabelSymbolNew(rest$, "ΜΕ", "WITH", Lang) Then If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p p = Empty GoTo wehavestring Else MissStringExpr End If ElseIf IsStrExp(bstack, rest$, s$, False) Then wehavestring: inpcsvsep$ = Left$(s$, 1) If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p p = Empty GoTo wehavestring2 Else MissStringExpr End If ElseIf IsStrExp(bstack, rest$, s$, False) Then wehavestring2: inpcsvDec$ = Left$(s$, 1): MyInput = True End If End If inpcsvuseescape = False If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then inpcsvuseescape = CBool(p): MyInput = True If FastSymbol(rest$, ",") Then MyInput = False: If IsExp(bstack, rest$, p) Then inpcleanstrings = CBool(p): MyInput = True Else MissStringExpr End If Exit Function End If Fkey = 0 If inpcsvsep$ = vbNullString Then inpcsvsep$ = "," If inpcsvDec$ = vbNullString Then inpcsvDec$ = "." MyInput = True With players(GetCode(bstack.Owner)) If IsLabelSymbolNew(rest$, "ΤΕΛΟΣ", "END", Lang) Then If Not NOEDIT Then NOEDIT = True Else If QRY Then QRY = False ''INK$ = Chr$(13) ' If GFQRY Then GFQRY = False End If Exit Function End If prive = GetCode(bstack.Owner) If Not releasemouse Then If Not Form1.Visible Then newshow Basestack1 MyInput = False '************* rest$ = NLtrim$(rest$) If FastSymbol(rest$, "!") Then x1 = 0 frm$ = vbNullString If bstack.toprinter = True Then oxiforPrinter: Exit Function If prive > 32 Then If Left$(Typename(bstack.Owner), 3) = "Gui" Then oxiforforms: Exit Function If TypeOf bstack.Owner Is MetaDc Then oxiforMetaFiles: Exit Function If TypeOf bstack.Owner Is VB.PictureBox Then oxiforImages: Exit Function End If f = Abs(IsLabel(bstack, rest$, what$)) Select Case f Case 1, 4 If f = 1 Then If GetVar(bstack, what$, i) Then If Not MyIsNumeric(var(i)) Then If VarTypeName(var(i)) <> "BigInteger" Then GoTo jumpthere2 End If End If End If End If If Not FastSymbol(rest$, ",") Then MissPar: Exit Function If Not IsExp(bstack, rest$, p) Then p = .mX X = p Y = 0 If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, p) Then x1 = 29 x1 = p If x1 < 1 Or x1 > 29 Then x1 = 29 Else x1 = 29 End If Form1.ShadowMarks = True If Y < 1 And x1 = 0 Then Y = 1 If GetVar(bstack, what$, i) Then Select Case VarType(var(i)) Case vbBoolean, vbByte, vbLong, vbInteger, 20 integ = True: noexp = True f = 4 Case vbDecimal, vbCurrency noexp = True End Select If VarType(var(i)) = 20 Then s$ = CStr(var(i)) ElseIf VarType(var(i)) = vbString Then s$ = LTrim$(var(i)) ElseIf VarTypeName(var(i)) = "BigInteger" Then s$ = var(i).ToString Set p = var(i) f = 4 x1 = 1000 GoTo cont43244 Else s$ = LTrim$(str(var(i))) End If '???????????????? If VarType(var(i)) = vbBoolean Then f = 4: x1 = 1: s$ = LTrim$(str(Abs(CLng(var(i))))) If Not NoUseDec Then If OverideDec Then s$ = Replace(s$, ".", NowDec$) End If Else s$ = Replace(s$, ".", QueryDecString) End If p = var(i) cont43244: Do s$ = iText(bstack, s$, (X), (Y), "", x1, True, f = 4) Loop Until ValidNum(s$, True, f = 4, VarType(p) + (x1 = 1000) * 500) If MyIsObject(var(i)) Then If Not var(i) Is Nothing Then If VarTypeName(var(i)) = "BigInteger" Then f = 0 Set var(i) = Module13.CreateBigInteger(s$) GoTo cont87887454 End If End If End If If Not NoUseDec Then If OverideDec Then s$ = Replace(s$, NowDec$, ".") End If Else s$ = Replace(s$, QueryDecString, ".") End If ValidNumberOnly s$, p, f = 4 Select Case VarType(var(i)) Case 20 var(i) = cInt64(p) Case vbByte var(i) = CByte(p) Case vbInteger var(i) = CInt(p) Case vbLong var(i) = CLng(p) Case vbSingle var(i) = CSng(p) Case vbCurrency var(i) = CCur(p) Case vbDouble var(i) = CDbl(p) Case vbDecimal var(i) = CDec(p) Case vbBoolean var(i) = CBool(p) Case Else var(i) = p End Select cont87887454: Else If i = -1 Then ' static variables If f = 4 Then s$ = LTrim$(str(ReadVarInt(bstack, what$))) Else s$ = LTrim$(str(ReadVarDouble(bstack, what$))) End If p = ReadVarDouble(bstack, what$) If VarType(p) = vbLong Or VarType(p) = vbInteger Then f = 4 If Not NoUseDec Then If OverideDec Then s$ = Replace(s$, ".", NowDec$) End If Else s$ = Replace(s$, ".", QueryDecString) End If Do s$ = iText(bstack, s$, (X), (Y), "", x1, True, f = 4) Loop Until ValidNum(s$, True, f = 4) If Not NoUseDec Then If OverideDec Then s$ = Replace(s$, NowDec$, ".") End If Else s$ = Replace(s$, QueryDecString, ".") End If ' where is long long ?????????????????????????????????????????????? If VarType(p) = vbLong Or VarType(p) = vbInteger Then ValidNumberOnly s$, p, f = 4 On Error Resume Next p = CLng(p) If Err.Number = 6 Then OverflowValue MyInput = False End If Else ValidNumberOnly s$, p, f = 4 End If bstack.SetVar what$, p Else s$ = vbNullString Do s$ = iText(bstack, s$, (X), (Y), "", x1, True, f = 4) Loop Until ValidNum(s$, True, f = 4) If Not NoUseDec Then If OverideDec Then s$ = Replace(s$, NowDec$, ".") End If Else s$ = Replace(s$, QueryDecString, ".") End If ValidNumberOnly s$, p, f = 4 globalvar what$, (p) End If End If MyInput = True Form1.ShadowMarks = False Case 3 jumpthere2: If Not FastSymbol(rest$, ",") Then MissPar: Exit Function If Not IsExp(bstack, rest$, p) Then p = .mX X = p If Not FastSymbol(rest$, ",") Then Y = 0 x1 = 50 If IsLabelSymbolNew(rest$, "ΜΗΚΟΣ", "LEN", Lang) Then If FastSymbol(rest$, "=") Then If IsExp(bstack, rest$, p) Then x1 = Abs(MyRound(p)) Else MissNumExpr Exit Function End If Else MissSymbol "=" Exit Function End If End If p = -1& ElseIf Not IsExp(bstack, rest$, Y) Then MissPar Exit Function Else p = -1& If FastSymbol(rest$, ",") Then If FastSymbol(rest$, ",") Then comehere: If Not IsExp(bstack, rest$, p, flatobject:=True, nostring:=True) Then MissPar: Exit Function p = MyRound(p) Else If Not IsExp(bstack, rest$, ppp, flatobject:=True) Then If Not IsStrExp(bstack, rest$, frm$) Then MissPar: Exit Function Else If MemInt(VarPtr(ppp)) = vbString Then SwapString2Variant frm$, ppp Else MissPar Exit Function End If End If If FastSymbol(rest$, ",") Then GoTo comehere End If Else If Len(var(i)) > 0 Then x1 = -Len(var(i)) End If End If Form1.ShadowMarks = True Form1.TEXT1.TabWidth = ReportTabWidth Form1.TabControl = ReportTabWidth If Y < 1 And x1 = 0 Then Y = 1 If GetVar(bstack, what$, i) Then var(i) = iText(bstack, var(i), (X), (Y), frm$, x1, , , p) Else If i = -1 Then bstack.SetVar what$, iText(bstack, ReadVarStr(bstack, what$), (X), (Y), frm$, x1, , , p) Else globalvar what$, iText(bstack, "", (X), (Y), frm$, x1, , , p) End If End If MyInput = True Form1.ShadowMarks = False Case 5, 7 ' NUMBER IN ARRAY If neoGetArray(bstack, what$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$) Then Exit Function Else NosuchArray Exit Function End If If pppp.IsStringItem(it) Then GoTo jumpthere3 End If If Not FastSymbol(rest$, ",") Then MissPar: Exit Function If Not IsExp(bstack, rest$, p) Then p = .mX X = p Y = 0 If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, p) Then x1 = 29 x1 = p If x1 < 1 Or x1 > 29 Then x1 = 29 Else x1 = 29 End If Form1.ShadowMarks = True If Y < 1 And x1 = 0 Then Y = 1 s$ = LTrim$(str(pppp.itemnumeric(it))) p = pppp.itemnumeric(it) If VarType(p) = vbLong Or VarType(p) = vbInteger Then f = 7 If VarType(var(i)) = vbBoolean Then f = 7: x1 = 1: s$ = LTrim$(str(Abs(CLng(pppp.itemnumeric(it))))) End If Do s$ = iText(bstack, s$, (X), (Y), "", x1, True, f = 7) Loop Until ValidNum(s$, True, f = 7, VarType(p)) If Not NoUseDec Then If OverideDec Then s$ = Replace(s$, NowDec$, ".") End If Else s$ = Replace(s$, QueryDecString, ".") End If ValidNumberOnly s$, p, f = 7 Select Case VarType(pppp.item(it)) Case 0 pppp.item(it) = cInt64(p) Case vbInteger pppp.item(it) = CInt(p) Case vbLong pppp.item(it) = CLng(p) Case vbSingle pppp.item(it) = CSng(p) Case vbCurrency pppp.item(it) = CCur(p) Case vbDouble pppp.item(it) = CDbl(p) Case vbDecimal pppp.item(it) = CDec(p) Case vbBoolean pppp.item(it) = CBool(p) Case Else pppp.item(it) = p End Select Form1.ShadowMarks = False MyInput = True Case 6 If neoGetArray(bstack, what$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$) Then Exit Function End If Else NosuchArray Exit Function End If jumpthere3: If Not FastSymbol(rest$, ",") Then MissPar: Exit Function If Not IsExp(bstack, rest$, p) Then p = .mX X = p If Not FastSymbol(rest$, ",") Then Y = 0 x1 = 50 If IsLabelSymbolNew(rest$, "ΜΗΚΟΣ", "LEN", Lang) Then If FastSymbol(rest$, "=") Then If IsExp(bstack, rest$, p) Then x1 = Abs(MyRound(p)) Else MissNumExpr Exit Function End If Else MissSymbol "=" Exit Function End If End If ElseIf Not IsExp(bstack, rest$, Y) Then MissPar Exit Function Else p = -1 If FastSymbol(rest$, ",") Then If FastSymbol(rest$, ",") Then comehere1: If Not IsExp(bstack, rest$, p, flatobject:=True, nostring:=True) Then MissPar: Exit Function p = MyRound(p) Else If Not IsExp(bstack, rest$, ppp, flatobject:=True) Then If Not IsStrExp(bstack, rest$, frm$) Then MissPar: Exit Function Else If MemInt(VarPtr(ppp)) = vbString Then SwapString2Variant frm$, ppp Else MissPar Exit Function End If End If End If If FastSymbol(rest$, ",") Then GoTo comehere1 Else If Len(CStr(pppp.item(it))) > 0 Then x1 = -Len(CStr(pppp.item(it))) End If End If Form1.ShadowMarks = True ' look here to change it with values from Edit ! Form1.TEXT1.TabWidth = ReportTabWidth Form1.TabControl = ReportTabWidth If Y < 1 And x1 = 0 Then Y = 1 If VarType(pppp.item(it)) = vbString Then s$ = iText(bstack, LTrim$(pppp.item(it)), (X), (Y), frm$, x1, , , (p)) Else s$ = iText(bstack, LTrim$(str(pppp.item(it))), (X), (Y), frm$, x1) End If Form1.ShadowMarks = False If pppp.ItemType(it) = doc Then Set pppp.item(it) = New Document If s$ <> "" Then pppp.item(it).textDoc = s$ Else pppp.item(it) = s$ End If MyInput = True End Select Exit Function '******************************************** ElseIf FastSymbol(rest$, "#") Then If Not IsExp(bstack, rest$, p) Then MissPar: Exit Function If Not FastSymbol(rest$, ",") Then MissPar: Exit Function f = CLng(p) If Fkind(f) = FnoUse Or Fkind(f) = Foutput Or Fkind(f) = Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": MyInput = False: Exit Function par = True Else If bstack.toprinter = True Then oxiforPrinter: Exit Function If prive > 32 Then If Left$(Typename(bstack.Owner), 3) = "Gui" Then oxiforforms: Exit Function If TypeOf bstack.Owner Is MetaDc Then oxiforMetaFiles: Exit Function If TypeOf bstack.Owner Is VB.PictureBox Then oxiforImages: Exit Function End If If ISSTRINGA(rest$, frm$) Then If Not Fast2Symbol(rest$, ",", 1, ";", 1) Then MissPar: Exit Function Else frm$ = "?" End If par = False End If W$ = vbNullString Fkey = -1 If bstack.toprinter = True And Not par Then oxiforPrinter Fkey = 0 Exit Function End If If (Left$(Typename(bstack.Owner), 3) = "Gui") And Not par Then oxiforforms: Fkey = 0: Exit Function If (TypeOf bstack.Owner Is MetaDc) And Not par Then oxiforMetaFiles: Exit Function MyInput = False Do ex$ = "" Final$ = "" x1 = 256 integ = False Select Case Abs(IsLabel(bstack, rest$, what$)) Case 1 If GetVar(bstack, what$, i) Then If Not MyIsNumeric(var(i)) Then If MyIsObject(var(i)) Then If Not var(i) Is Nothing Then If TypeOf var(i) Is BigInteger Then x1 = 1000 If FastSymbol(rest$, "=") Then If Not IsNumberCheck(rest$, p) Then SyntaxError Exit Function End If End If Set p = var(i) integ = True noexp = True GoTo there1112 ElseIf TypeOf var(i) Is Group Then p = 0# GoTo checktypehere ElseIf Not TypeOf var(i) Is Document Then WrongType Exit Function End If End If End If GoTo jumpthere Else Select Case VarType(var(i)) Case vbBoolean, vbByte, vbLong, vbInteger, 20 integ = True: noexp = True Case vbDecimal, vbCurrency noexp = True End Select End If p = var(i) If FastSymbol(rest$, "=") Then If IsNumberCheck(rest$, (p)) Then Else SyntaxError Exit Function End If End If Else checktypehere: If FastSymbol(rest$, "=") Then If IsNumberCheck(rest$, p) Then Select Case VarType(p) Case vbBoolean, vbByte, vbLong, vbInteger, 20 integ = True: noexp = True Case vbDecimal, vbCurrency noexp = True Case vbObject integ = True noexp = True GoTo there1112 End Select Else SyntaxError Exit Function End If End If End If If p <> 0 Then p = p - p there1112: If par Then If uni(f) Then getUniRealComma f, s$ Else getAnsiRealComma f, s$ End If Else prive = GetCode(bstack.Owner) ss$ = "" If frm$ <> "" Then ' here add one PlainBaSket bstack.Owner, players(prive), frm$, , , 0 End If If players(prive).lastprint Then LCTbasket bstack.Owner, players(prive), players(prive).currow, players(prive).curPos players(prive).lastprint = False rpos = players(prive).curPos rrow = players(prive).currow Else rpos = GetRealPos(bstack.Owner) rrow = GetRealRow(bstack.Owner) End If If MaybeIsSymbol2(rest$, ",;", i) Then If Mid$(rest$, i, 1) = "," Then Final$ = ", " ex$ = "," + vbCr ElseIf Mid$(rest$, i + 1, 1) = """" Then FastSymbol rest$, ";" If ISSTRINGA(rest$, Final$) Then If MaybeIsSymbol2(rest$, ",;", i) Then If Trim$(Final$) = "" Then If Len(Final$) = 0 Then Final$ = " " ex$ = " " + vbCr Else ex$ = Left$(LTrim$(Final$), 1) + vbCr End If Else ex$ = vbCr End If Else SyntaxError Exit Function End If End If Else Final$ = "" ex$ = vbCr End If ss$ = "" again112: If Len(ex$) > 1 Then sp$ = Trim$(Left$(ex$, 1)) + vbCr Else sp$ = vbCr Do If Len(ss$) > 0 Then ss$ = ss$ + Final$ If ((rpos + Len(ss$)) \ players(prive).mX) + rrow > players(prive).mY - 1 Then rrow = players(prive).mY - ((rpos + Len(ss$)) \ players(prive).mX) - 1 End If LCTbasket bstack.Owner, players(prive), rrow, rpos bstack.Owner.FontTransparent = False PlainBaSket bstack.Owner, players(prive), space$(Len(ss$)), , , 0, True bstack.Owner.FontTransparent = True LCTbasket bstack.Owner, players(prive), rrow, rpos Beep Else LCTbasket bstack.Owner, players(prive), rrow, rpos End If If integ Then W$ = QUERY(bstack, "", s$, x1, False, sp$, "+*/!.@#$|\{}[]'~`%^&()=_:;eEεΕ", True, Final$) Else If noexp Then W$ = QUERY(bstack, "", s$, x1, False, sp$, "+*/!@#$|\{}[]'~`%^&()=_:;eEεΕ", True, Final$) Else W$ = QUERY(bstack, "", s$, 256, False, sp$, "+*/!@#$|\{}[]'~`%^&()=_:;", True, Final$) End If End If ss$ = s$ Loop While Not ValidNum(s$, True, f = 4, VarType(p) + (x1 = 1000) * 500) If LenB(Trim(s$)) = 0 Then ErrNum: MyInput = False: Fkey = 0: Exit Function If NowDec$ <> "." Then s$ = Replace(s$, NowDec$, ".") End If End If If GetVar(bstack, what$, i) Then If MyIsObject(var(i)) Then If VarTypeName(var(i)) = mGroup Then If var(i).HasSet Then Set mystack = bstack.soros Select Case VarType(p) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbByte s$ = s$ + "ub" Case vbDate ' ?????????????????????? s$ = s$ + "ud" Case vbInteger s$ = s$ + "%" Case 20 s$ = s$ + "&&" Case vbObject Set pp = Module13.CreateBigInteger(s$) GoTo cont445487 End Select If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If cont445487: bstack.soros.PushVal pp Set bstack.lastobj = Nothing PushErrStage bstack NeoCall2 bstack, what$ + "." + ChrW(&H1FFF) + ":=()", MyInput PopErrStage bstack Set bstack.Sorosref = mystack Set mystack = Nothing If LastErNum <> 0 Then LastErNum = 0 LastErNum1 = 0 If LastErName <> "" Then LastErName = Chr(0) + LastErName If LastErNameGR <> "" Then LastErNameGR = Chr(0) + LastErNameGR GoTo again112 End If Else BadGroupHandle MyInput = False Fkey = 0: Exit Function End If ElseIf VarTypeName(var(i)) = "BigInteger" Then ' Set var(i) = Module13.CreateBigInteger(s$) ElseIf VarTypeName(var(i)) = "Constant" Then CantAssignValue End If Else Select Case VarType(var(i)) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" End Select If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If If VarTypeName(var(i)) = "Boolean" Then var(i) = pp <> 0 Else var(i) = pp End If End If Else If i = -1 Then bstack.ReadVar what$, pp Select Case VarTypeName(pp) Case "Long" s$ = s$ + "&" Case "Currency" s$ = s$ + "#" Case "Decimal" s$ = s$ + "@" Case "Single" s$ = s$ + "~" Case "Integer" s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case vbObject If Not var(i) Is Nothing Then If VarTypeName(var(i)) = "BigInteger" Then Set pp = Module13.CreateBigInteger(s$) GoTo cont87887454587 End If End If End Select If IsNumberCheck(s$, p) Then bstack.SetVar what$, pp Else Select Case VarType(pp) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case vbObject, vbEmpty If VarTypeName(p) = "BigInteger" Then s$ = s$ + "u" End If End Select If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If cont87887454587: globalvar what$, pp End If End If MyInput = True Case 3 jumpthere: If par Then If uni(f) Then getUniStringComma f, s$, inpcleanstrings Else getAnsiStringComma f, s$, inpcleanstrings End If If inpcsvuseescape Then s$ = EscapeStrToString(s$) Else If MaybeIsSymbol2(rest$, ",;", i) Then If Mid$(rest$, i, 1) = "," Then Final$ = ", " ex$ = "," + vbCr ElseIf Mid$(rest$, i + 1, 1) = """" Then FastSymbol rest$, ";" If ISSTRINGA(rest$, Final$) Then If MaybeIsSymbol2(rest$, ",;", i) Then If Trim$(Final$) = "" Then If Len(Final$) = 0 Then Final$ = " " ex$ = " " + vbCr Else ex$ = Left$(LTrim$(Final$), 1) + vbCr End If Else ex$ = vbCr End If Else SyntaxError Exit Function End If End If Else ex$ = vbCr End If prive = GetCode(bstack.Owner) If players(prive).lastprint Then LCTbasket bstack.Owner, players(prive), players(prive).currow, players(prive).curPos players(prive).lastprint = False End If ' no use of ex$ QUERY bstack, frm$, s$, 256, False, vbCr, IIf(lookOne(rest$, ","), ",", Chr$(0)) + Chr$(34) + "{}", , Final End If If GetVar(bstack, what$, i) Then If MyIsObject(var(i)) Then If Typename(var(i)) = mGroup Then If var(i).HasSet Then Set mystack = bstack.soros If bstack.lastobj Is Nothing Then bstack.soros.PushStr s$ Else If TypeOf bstack.lastobj Is Group Then bstack.lastobj.ToDelete = False End If bstack.soros.PushObj bstack.lastobj Set bstack.lastobj = Nothing End If If Right$(what$, 1) <> "$" Then NeoCall2 bstack, what$ + "." + ChrW(&H1FFF) + ":=()", MyInput Else NeoCall2 bstack, Left$(what$, Len(what$) - 1) + "." + ChrW(&H1FFF) + ":=()", MyInput End If Set bstack.Sorosref = mystack Set mystack = Nothing Else BadGroupHandle MyInput = False Fkey = 0: Exit Function End If ElseIf Typename(var(i)) = "Constant" Then CantAssignValue End If Else CheckVar var(i), s$ End If Else If i = -1 Then bstack.SetVar what$, s$ Else globalvar what$, s$ End If End If MyInput = True Case 4 If FastSymbol(rest$, "=") Then IsNumberCheck rest$, p Else p = 0# If p <> 0 Then p = p - p If par Then If uni(f) Then getUniRealComma f, s$ Else getAnsiRealComma f, s$ End If Else If MaybeIsSymbol2(rest$, ",;", i) Then If Mid$(rest$, i, 1) = "," Then Final$ = ", " ex$ = "," + vbCr ElseIf Mid$(rest$, i + 1, 1) = """" Then FastSymbol rest$, ";" If ISSTRINGA(rest$, Final$) Then If MaybeIsSymbol2(rest$, ",;", i) Then If Trim$(Final$) = "" Then If Len(Final$) = 0 Then Final$ = " " ex$ = " " + vbCr Else ex$ = Left$(LTrim$(Final$), 1) + vbCr End If Else ex$ = vbCr End If Else SyntaxError Exit Function End If End If Else ex$ = vbCr End If prive = GetCode(bstack.Owner) If players(prive).lastprint Then LCTbasket bstack.Owner, players(prive), players(prive).currow, players(prive).curPos players(prive).lastprint = False End If If Len(ex$) > 1 Then sp$ = Trim$(Left$(ex$, 1)) + vbCr Else sp$ = vbCr W$ = QUERY(bstack, frm$, s$, 256, False, sp$, "+*/!.@#$|\{}[]'~`%^&()=_:;eEεΕ", True, Final) If LenB(Trim(s$)) = 0 Then ErrNum: MyInput = False: Fkey = 0: Exit Function End If If GetVar(bstack, what$, i) Then Select Case VarType(var(i)) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case vbObject If Not var(i) Is Nothing Then If VarTypeName(var(i)) = "BigInteger" Then Set pp = Module13.CreateBigInteger(s$) GoTo cont878874545871 End If End If End Select If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If cont878874545871: var(i) = MyRound(pp) Else If i = -1 Then bstack.ReadVar what$, pp Select Case VarType(pp) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case Else If VarTypeName(var(i)) = "BigInteger" Then s$ = s$ + "u" End If End Select If IsNumberCheck(s$, p) Then bstack.SetVar what$, pp bstack.SetVar what$, MyRound(pp) Else Select Case VarType(p) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case Else If VarTypeName(var(i)) = "BigInteger" Then s$ = s$ + "u" End If End Select If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If If VarTypeName(p) <> VarTypeName(pp) Then OverflowValue VarType(p) Else globalvar what$, MyRound(pp) End If End If End If MyInput = True Case 5 If neoGetArray(bstack, what$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$, , , , True) Then Fkey = 0: Exit Function Else NosuchArray Fkey = 0: Exit Function End If If Not pppp.arr Then If pppp.GroupRef Is Nothing Then InternalError Exit Function ElseIf it = -2 Then Set mystack = bstack.soros Set bstack.Sorosref = NewmStiva PushParamStraight bstack, rest$ If Not FastSymbol(rest$, ")") Then SyntaxError Exit Function End If p = 0# GoTo cont2232322 ElseIf pppp.IsObjAt(it, p) Then GoTo aaa2332 'ElseIf it < -2 Then 'Set mystack = bstack.soros 'Set bstack.Sorosref = newmstiva 'If FastSymbol(rest$, ")") Then 'PushParamStraight bstack, rest$ ' If Not FastSymbol(rest$, ")") Then ' SyntaxError ' Exit Function ' End If 'End If End If p = 0# ElseIf pppp.IsObjAt(it, p) Then aaa2332: If p Is Nothing Then Set p = ZeroBig ElseIf TypeOf p Is BigInteger Then If FastSymbol(rest$, "=") Then IsNumberCheck rest$, (0) End If GoTo cont1333 ElseIf TypeOf p Is Group Then Set mystack = bstack.soros Set bstack.Sorosref = NewmStiva If FastSymbol(rest$, "(") Then PushParamStraight bstack, rest$ If Not FastSymbol(rest$, ")") Then SyntaxError Exit Function End If End If p = 0# GoTo cont2232322 End If Else If pppp.IsStringItem(it) Then GoTo jumpthere4 End If cont2232322: If FastSymbol(rest$, "=") Then IsNumberCheck rest$, p Select Case VarType(p) Case vbBoolean, vbByte, vbLong, vbInteger, 20 integ = True: noexp = True Case vbDecimal, vbCurrency noexp = True Case vbObject If p Is Nothing Then integ = True: noexp = True Set p = ZeroBig ElseIf Not TypeOf p Is BigInteger Then WrongType Exit Function End If integ = True: noexp = True End Select ElseIf it > -2 Then Select Case pppp.ItemTypeNum(it) Case vbBoolean, vbByte, vbLong, vbInteger, 20 integ = True: noexp = True p = pppp.item(it) Case vbDecimal, vbCurrency noexp = True p = pppp.item(it) Case vbObject If pppp.itemObject(it) Is Nothing Then integ = True: noexp = True Set p = ZeroBig ElseIf Not TypeOf pppp.itemObject(it) Is BigInteger Then If TypeOf pppp.itemObject(it) Is Document Then GoTo jumpthere4 ElseIf TypeOf pppp.itemObject(it) Is Group Then GoTo cont1333 End If WrongType Exit Function End If integ = True: noexp = True Set p = ZeroBig Case Else If pppp.ItemIsObject(it) Then p = 0# Else p = pppp.item(it) If VarType(p) = vbString Then GoTo jumpthere4 End If End If End Select Else p = 0# End If cont1333: 'MyInput = True If par Then If uni(f) Then getUniRealComma f, s$ Else getAnsiRealComma f, s$ End If Else prive = GetCode(bstack.Owner) ss$ = "" If frm$ <> "" Then PlainBaSket bstack.Owner, players(prive), frm$, , , 0 End If If players(prive).lastprint Then LCTbasket bstack.Owner, players(prive), players(prive).currow, players(prive).curPos players(prive).lastprint = False rpos = players(prive).curPos rrow = players(prive).currow Else rpos = GetRealPos(bstack.Owner) rrow = GetRealRow(bstack.Owner) End If If MaybeIsSymbol2(rest$, ",;", i) Then If Mid$(rest$, i, 1) = "," Then Final$ = "," ex$ = "," + vbCr ElseIf Mid$(rest$, i + 1, 1) = """" Then FastSymbol rest$, ";" If ISSTRINGA(rest$, Final$) Then If MaybeIsSymbol2(rest$, ",;", i) Then If Trim$(Final$) = "" Then If Len(Final$) = 0 Then Final$ = " " ex$ = " " + vbCr Else ex$ = Left$(LTrim$(Final$), 1) + vbCr End If Else ex$ = vbCr End If Else SyntaxError Exit Function End If End If Else Final$ = "" ex$ = vbCr End If ss$ = "" again112a: If Len(ex$) > 1 Then sp$ = Trim$(Left$(ex$, 1)) + vbCr Else sp$ = IIf(lookOne(rest$, ","), "," + vbCr, vbCr) Do If Len(ss$) > 0 Then ss$ = ss$ + Final$ If ((rpos + Len(ss$)) \ players(prive).mX) + rrow > players(prive).mY - 1 Then rrow = players(prive).mY - ((rpos + Len(ss$)) \ players(prive).mX) - 1 End If LCTbasket bstack.Owner, players(prive), rrow, rpos bstack.Owner.FontTransparent = False PlainBaSket bstack.Owner, players(prive), space$(Len(ss$)), , , 0, True bstack.Owner.FontTransparent = True LCTbasket bstack.Owner, players(prive), rrow, rpos Beep Else LCTbasket bstack.Owner, players(prive), rrow, rpos End If If integ Then W$ = QUERY(bstack, "", s$, 256, False, sp$, ",+*/!.@#$|\{}[]'~`%^&()=_:;eEεΕ", True, Final$) Else If noexp Then W$ = QUERY(bstack, "", s$, 256, False, sp$, ",+*/!@#$|\{}[]'~`%^&()=_:;eEεΕ", True, Final$) Else W$ = QUERY(bstack, "", s$, 256, False, sp$, ",+*/!@#$|\{}[]'~`%^&()=_:;", True, Final$) End If End If If LenB(Trim(s$)) = 0 Then ErrNum: MyInput = False: Fkey = 0: Exit Function If NowDec$ <> "." Then s$ = Replace(s$, NowDec$, ".") End If ss$ = s$ Loop While Not ValidNum(s$, True, f = 4, VarType(p) + (x1 = 1000) * 500) If LenB(Trim(s$)) = 0 Then ErrNum: MyInput = False: Fkey = 0: Exit Function End If Select Case VarType(p) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case vbObject If TypeOf p Is BigInteger Then If it <> -2 Then Set pppp.item(it) = Module13.CreateBigInteger(s$) GoTo cont723948238749 End If End If End Select If it <> -2 And mystack Is Nothing Then If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If pppp.item(it) = pp Else If IsObject(p) Then bstack.soros.DataObj p Else If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If bstack.soros.DataVal pp End If If pppp.arr Then If SpeedGroup(bstack, pppp, "@R2", "", "", it) = 0 Then Set bstack.Sorosref = mystack Exit Function End If ElseIf TypeOf pppp.GroupRef Is mHandler Then Set pppp1 = New ppppLight pppp1.arr = False Set pppp1.GroupRef = pppp.item(it) If SpeedGroup(bstack, pppp1, "@R2", "", "", -2&) = 0 Then Set bstack.Sorosref = mystack Exit Function End If Set pppp.item(it) = pppp1.GroupRef Set pppp1 = Nothing ElseIf pppp.GroupRef.IamFloatGroup Then If SpeedGroup(bstack, pppp, "@R2", "", "", it) = 0 Then Set bstack.Sorosref = mystack Exit Function End If Else NeoCall2 bstack, Left$(what$, Len(what$) - 1) + "." + ChrW(&H1FFF) + ":=()", ok If Not ok Then Set bstack.Sorosref = mystack Exit Function Else Set bstack.Sorosref = mystack End If End If Set bstack.Sorosref = mystack End If cont723948238749: MyInput = True Case 6 If neoGetArray(bstack, what$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$) Then Fkey = 0: Exit Function Else NosuchArray Fkey = 0: Exit Function End If jumpthere4: If par Then If uni(f) Then getUniStringComma f, s$, inpcleanstrings Else getAnsiStringComma f, s$, inpcleanstrings End If If inpcsvuseescape Then s$ = EscapeStrToString(s$) Else prive = GetCode(bstack.Owner) If players(prive).lastprint Then LCTbasket bstack.Owner, players(prive), players(prive).currow, players(prive).curPos players(prive).lastprint = False End If QUERY bstack, frm$, s$, 256, False, IIf(lookOne(rest$, ","), "," + vbCr, vbCr), IIf(lookOne(rest$, ","), ",", Chr$(0)) + Chr$(34) + "{}", , Final$ End If If MyIsObject(pppp.item(it)) Then If pppp.ItemType(it) = mGroup Then If pppp.item(it).HasSet Then what = Left$(what$, Len(what$) - 2) Set mystack = bstack.soros PushParamGeneral bstack, rest$ If Not FastSymbol(rest$, ")", True) Then Set bstack.Sorosref = mystack MyInput = False: Exit Function End If bstack.soros.DataStr s$ NeoCall2 bstack, what$ + "." + ChrW(&H1FFF) + ":=()", MyInput Set bstack.Sorosref = mystack Set mystack = Nothing Else GroupCantSetValue End If ElseIf pppp.ItemType(it) = doc Then Set pppp.item(it) = New Document If s$ <> "" Then pppp.item(it).textDoc = s$ End If Else pppp.item(it) = s$ End If MyInput = True Case 7 If neoGetArray(bstack, what$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, what$, it, rest$) Then Fkey = 0: Exit Function Else NosuchArray Exit Function End If If par Then If uni(f) Then getUniRealComma f, s$ Else getAnsiRealComma f, s$ End If Else If MaybeIsSymbol2(rest$, ",;", i) Then If Mid$(rest$, i, 1) = "," Then Final$ = "," ex$ = "," + vbCr ElseIf Mid$(rest$, i + 1, 1) = """" Then FastSymbol rest$, ";" If ISSTRINGA(rest$, Final$) Then If MaybeIsSymbol2(rest$, ",;", i) Then If Trim$(Final$) = "" Then If Len(Final$) = 0 Then Final$ = " " ex$ = " " + vbCr Else ex$ = Left$(LTrim$(Final$), 1) + vbCr End If Else ex$ = vbCr End If Else SyntaxError Exit Function End If End If Else Final$ = "" ex$ = vbCr End If prive = GetCode(bstack.Owner) If players(prive).lastprint Then LCTbasket bstack.Owner, players(prive), players(prive).currow, players(prive).curPos players(prive).lastprint = False End If If Len(ex$) > 1 Then sp$ = Trim$(Left$(ex$, 1)) + vbCr Else sp$ = IIf(lookOne(rest$, ","), "," + vbCr, vbCr) W$ = QUERY(bstack, frm$, s$, 256, False, sp$, "+*/!@#$|\{}[.]'~`%^&()=_:;eEεΕ", True, Final$) If LenB(Trim(s$)) = 0 Then ErrNum: MyInput = False: Fkey = 0: Exit Function End If If FastSymbol(rest$, "=") Then IsNumberCheck rest$, p Else p = pppp.item(it) p = p - p Select Case VarType(p) Case vbLong s$ = s$ + "&" Case vbCurrency s$ = s$ + "#" Case vbDecimal s$ = s$ + "@" Case vbSingle s$ = s$ + "~" Case vbInteger s$ = s$ + "%" Case vbByte s$ = s$ + "ub" Case vbDate s$ = s$ + "ud" Case 20 s$ = s$ + "&&" Case Else If VarTypeName(var(i)) = "BigInteger" Then s$ = s$ + "u" End If End Select If par Then If Not IsNumberCheck(s$, pp, inpcsvDec$) Then pp = p Else If Not IsNumberCheck(s$, pp) Then pp = p End If pppp.item(it) = MyRound(pp) MyInput = True End Select If FastSymbol(rest$, ",") Then W$ = vbNullString If Not par Then If Final$ = "" Then frm$ = " " Else If InStr("=: ", Right$(Final$, 1)) = 0 Then frm$ = " " Else frm$ = "" End If End If ElseIf FastSymbol(rest$, ";") Then If Not par Then W$ = ";" If Len(ex$) = 1 Then frm$ = " " Else frm$ = "" End If Else If Final$ <> "" Then ' here add one ' PlainBaSket bstack.Owner, players(prive), Final$, , , 0 End If If Not par Then If Not W$ = ";" Then crNew bstack, players(prive) If W$ = ";" Then players(prive).lastprint = True End If W$ = vbNullString Fkey = 0: Exit Function End If Loop Fkey = 0 Exit Function End With End Function Function MyCopy(bstack As basetask, rest$, Lang As Long) As Boolean Dim p As Variant, Scr As Object, photo As cDIBSection, s$, it As Long, what$ MyCopy = True Dim x1 As Long, y1 As Long, x2 As Long, y2 As Long, pppp As iBoxArray, y22 As Single Dim scNow As Integer If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p p = Empty GoTo wehavestring Else x1 = p GoTo wehavenumber End If ElseIf IsStrExp(bstack, rest$, s$, False) Then wehavestring: If Left$(s$, 4) = "cDIB" And Len(s$) > 12 Then Set photo = New cDIBSection If cDib(s$, photo) Then If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then If IsStrExp(bstack, rest$, s$) Then photo.SaveDib s$ Set photo = Nothing End If End If Exit Function Else noImage s$ Exit Function End If Else If ExtractType(s$) = vbNullString Then s$ = s$ + ".bmp" FixPath s$ If Not CanKillFile(s$) Then FilePathNotForUser: Exit Function On Error Resume Next Set photo = New cDIBSection photo.CopyPicture bstack.Owner If ExtractType(s$) = "png" Then Dim mb As MemBlock, mb1 As MemBlock Set mb = New MemBlock If photo.SaveDibToMeMBlock(mb) Then Dim ok As Boolean Set mb = mb.RenderToPng(ok) If ok Then MyCopy = mb.SaveBufferToFile(s$) End If End If Else photo.SaveDib s$ End If Set photo = Nothing Exit Function End If Else wehavenumber: If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then y1 = p If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then Select Case Abs(IsLabel(bstack, rest$, s$)) Case 3, 1 If GetVar(bstack, s$, it) Then Set photo = New cDIBSection Set Scr = bstack.Owner With players(GetCode(Scr)) scNow = Scr.ScaleMode x1 = Scr.ScaleX(x1 + .XGRAPH, scNow, 3) - Scr.ScaleX(.XGRAPH, scNow, 3) y1 = Scr.ScaleX(y1 + .YGRAPH, scNow, 3) - Scr.ScaleX(.YGRAPH, scNow, 3) If photo.create(CLng(x1), CLng(y1)) Then photo.LoadPictureBlt Scr.hDC, CLng(Scr.ScaleX(.XGRAPH, scNow, 3)), CLng(Scr.ScaleX(.YGRAPH, scNow, 3)) If photo.bitsPerPixel <> 24 Then Conv24 photo var(it) = DIBtoSTR(photo) End If End With Set photo = Nothing Set Scr = Nothing Exit Function Else Nosuchvariable s$ MyCopy = False Exit Function End If Case 6, 5 Dim W6 As Long If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, W6, rest$) Then Exit Function Set photo = New cDIBSection Set Scr = bstack.Owner With players(GetCode(Scr)) scNow = Scr.ScaleMode x1 = Scr.ScaleX(x1 + .XGRAPH, scNow, 3) - Scr.ScaleX(.XGRAPH, scNow, 3) y1 = Scr.ScaleX(y1 + .YGRAPH, scNow, 3) - Scr.ScaleX(.YGRAPH, scNow, 3) If photo.create(CLng(x1), CLng(y1)) Then photo.LoadPictureBlt Scr.hDC, CLng(Scr.ScaleX(.XGRAPH, scNow, 3)), CLng(Scr.ScaleX(.YGRAPH, scNow, 3)) If photo.bitsPerPixel <> 24 Then Conv24 photo If MyIsObject(pppp.item(W6)) Then WrongItemType: MyEr "can't copy image to " + pppp.ItemType(W6), "δεν μπορώ να αντιγράψω εικόνα σε " + pppp.ItemType(W6) MyCopy = False Else On Error Resume Next pppp.item(W6) = DIBtoSTR(photo) If Err Then Err.Clear GoTo WrongItemType End If End If End If End With Set photo = Nothing Set Scr = Nothing Exit Function Else NotExistArray s$ + ")" MyCopy = False Exit Function End If End Select ElseIf IsLabelSymbolNew(rest$, "ΜΕ", "USE", Lang) Then If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p p = Empty GoTo wehavestring2 Else MissStringExpr End If ElseIf IsStrExp(bstack, rest$, s$, False) Then wehavestring2: Set photo = New cDIBSection If cDib(s$, photo) Then y22 = 0! Set Scr = bstack.Owner scNow = Scr.ScaleMode If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then y22 = p If y2 = 0 Then y2 = 100 If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then y2 = p Else y2 = 100 If Not (y22 = 0 And y2 = 100) Then RotateDib1 bstack, photo, y22, y2, Scr.BackColor End If photo.PaintPicture Scr.hDC, CLng(Scr.ScaleX(x1, scNow, 3)), CLng(Scr.ScaleX(y1, scNow, 3)) End If Set photo = Nothing Set Scr = Nothing Else MyCopy = False: Exit Function End If ElseIf IsLabelSymbolNew(rest$, "ΕΠΑΝΩ", "TOP", Lang) Then If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p p = Empty GoTo wehavestring3 Else MissStringExpr End If ElseIf IsStrExp(bstack, rest$, s$, False) Then wehavestring3: Set photo = New cDIBSection Set Scr = bstack.Owner scNow = Scr.ScaleMode If cDib(s$, photo) Then y22 = 0! If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then y22 = p If y2 = 0 Then y2 = 100 If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then y2 = p Else y2 = 100 If Not (y22 = 0 And y2 = 100) Then RotateDib1 bstack, photo, y22, y2, , CLng(x1), CLng(y1) End If photo.PaintPicture Scr.hDC, MyRound((Scr.ScaleX(x1, scNow, 3)), 0), MyRound((Scr.ScaleX(y1, scNow, 3)), 0) End If Set photo = Nothing Set Scr = Nothing Else MyCopy = False: MissNumExpr: Exit Function End If Else If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then x2 = p If FastSymbol(rest$, ",") Then If IsExp(bstack, rest$, p) Then y2 = p Else MyCopy = False: MissNumExpr: Exit Function If x2 = 0 Or y2 = 0 Then MyCopy = False: MissNumExpr: Exit Function ICOPY bstack.Owner, x1, y1, x2, CLng(y2) End If End If MyDoEvents1 bstack.Owner End Function Function MyFunction(entrypoint As Long, bstack As basetask, rest$, Lang As Long, Optional noskipcommand = False, Optional MakeNew As Boolean, Optional addlen As Long = 0, Optional ByPass As Boolean) As Boolean Dim y1 As Long, par As Boolean, what$, s$, ss$, pa$, x1 As Long, i As Long, frm$ Dim ohere$, ox As Long ohere$ = here$ MyFunction = True If entrypoint = 1 Then par = True y1 = True ElseIf entrypoint = 2 Then ' operators par = IsLabelSymbolNew(rest$, "ΝΕΑ", "NEW", Lang) i = InStr(rest$, " ") If i = 1 Then i = InStr(2, rest$, " ") what$ = Mid$(rest$, 2, i - 2) ' + "()" Else what$ = Left$(rest$, i - 1) ' + "()" End If rest$ = Mid$(rest$, i + 1) GoTo operators ElseIf entrypoint = -1 Then par = Len(ohere$) = 0 GoTo alocal Else y1 = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΗ", "GLOBAL", Lang) par = IsLabelSymbolNew(rest$, "ΝΕΑ", "NEW", Lang) End If If y1 <> 0 Then ' FUNCTION GLOBAL "ALFA[212].other" {definition} so we can place [ ] in a definition.. ' FOR INTERNAL USE.. If lookOne(rest$, Chr(34)) Then ISSTRINGA rest$, what$ x1 = 1 If Right$(what$, 1) = "$" Then x1 = 3 ElseIf Right$(what$, 1) = "%" Then x1 = 4 End If what$ = what$ + "()" If FastSymbolNoTrimAfter(rest$, "{") Then ss$ = block(rest$) If Len(ss$) = 0 Then ss$ = blockString(rest$, Asc("}")) End If i = Len(rest$) + addlen If Not FastSymbol(rest$, "}") Then MyFunction = False Else If Left$(sbf(Abs(bstack.OriginalCode)).sb, 10) = "'11001EDIT" Then If InStr(here$, ChrW(&H1FFF)) > 0 Then s$ = vbNullString Else pa$ = sbf(Abs(bstack.OriginalCode)).sb If Not Left$(ss$, 10) = "'11001EDIT" Then s$ = GetNextLine(pa$) + "-" + CStr(i - 2) + vbCrLf End If End If ElseIf Not bstack.LoadOnly Then If Left$(ss$, 10) <> "'11001EDIT" Then s$ = "'11001EDIT " + GetModuleName(bstack, ohere$) + "," + str(-(i + addlen - 2)) + vbCrLf End If End If bstack.IndexSub = ModuleSub(what$, s$ + ss$) End If Exit Function Else GoTo missdef End If End If End If alocal: x1 = Abs(IsLabelF(rest$, what$)) If x1 = 1 Or x1 = 3 Or x1 = 4 Then ' C() C%() C$() operators: If Not noskipcommand Then If x1 = 1 Then If funid.Find(what$ + "(", i, bstack.numfunnum) Then If i > 0 Then funid.ItemCreator what$ + "(", -Abs(i) End If ElseIf x1 = 3 Then If strfunid.Find(what$ + "(", i, bstack.strfunnum) Then If i > 0 Then strfunid.ItemCreator what$ + "(", -Abs(i) End If End If End If what$ = what$ + "()" MakeThisSub bstack, what$ If y1 Then ' We have a global function If Not GetGlobalSubAfterHere(bstack, what$, x1) Then If FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyFunction = False Exit Function End If frm$ = Trim$(frm$) End If If FastSymbolNoTrimAfter(rest$, "{") Then ss$ = block(rest$) If Len(ss$) = 0 Then ss$ = blockString(rest$, Asc("}")) End If y1 = Len(rest$) + addlen If Not FastSymbol(rest$, "}") Then MyFunction = False Else If Left$(sbf(Abs(bstack.OriginalCode)).sb, 10) = "'11001EDIT" Then If InStr(here$, ChrW(&H1FFF)) > 0 Then s$ = vbNullString Else pa$ = sbf(Abs(bstack.OriginalCode)).sb If Not Left$(ss$, 10) = "'11001EDIT" Then s$ = GetNextLine(pa$) + "-" + CStr(y1 - 2 + addlen) + vbCrLf End If End If ElseIf bstack.OriginalCode > 0 And Not bstack.LoadOnly And here$ <> "" Then If Left$(ss$, 10) <> "'11001EDIT" Then s$ = "'11001EDIT " + GetModuleName(bstack, ohere$) + "," + str(-(y1 - 2 + addlen)) + vbCrLf End If End If If frm$ <> "" Then ' If Lang = 1 Then s$ = s$ + neoReadEng + frm$ + vbCrLf ' Else ' s$ = s$ + neoReadGr + frm$ + vbCrLf ' End If End If If i < 0 And Len(here$) <> 0 Then bstack.IndexSub = ModuleSub(here$ + "." + what$, s$ + ss$) Else bstack.IndexSub = ModuleSub(what$, s$ + ss$) End If End If Else missdef: MyEr what$ + " missing definition", what$ + " λείπει ο ορισμός" End If Else If FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyFunction = False Exit Function End If frm$ = Trim$(frm$) End If If FastSymbolNoTrimAfter(rest$, "{") Then what$ = block(rest$) If Len(what$) = 0 Then what$ = blockString(rest$, Asc("}")) End If If Len(frm$) <> 0 Then ' If Lang = 1 Then what$ = neoReadEng + frm$ + vbCrLf + what$ ' Else ' what$ = neoReadGr + frm$ + vbCrLf + what$ ' End If frm$ = vbNullString End If If Not FastSymbol(rest$, "}") Then MyFunction = False Else If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf With sbf(x1) .sb = what$: bstack.IndexSub = x1 Set .subs = Nothing Set .Pad = Nothing End With End If Else MyEr what$ + " missing definition", what$ + " λείπει ο ορισμός" End If End If Exit Function Else If par Then If entrypoint = 2 Then x1 = ModuleSub(what$, "") Else If Len(here$) = 0 Then x1 = ModuleSub(what$, "") Else x1 = ModuleSub(here$ + "." + bstack.GroupName + what$, "") End If End If GoTo jump1 ElseIf here$ = vbNullString And subHash.Find(what$, x1) And Not MakeNew Then jump1: If x1 >= lckfrm And lckfrm <> 0 Then ' when we load a scrabled program..we have locked functions/modules rest$ = vbNullString MyFunction = False: Exit Function End If If FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyFunction = False Exit Function End If frm$ = Trim$(frm$) Else frm$ = vbNullString End If If FastSymbolNoTrimAfter(rest$, "{") Then what$ = block(rest$) + " " If Len(what$) = 1 Then what$ = blockString(rest$, Asc("}")) + " " End If If Len(frm$) <> 0 Then ' If Lang = 1 Then what$ = neoReadEng + frm$ + vbCrLf + what$ ' Else ' what$ = neoReadGr + frm$ + vbCrLf + what$ ' End If frm$ = vbNullString End If If Not FastSymbol(rest$, "}") Then MyFunction = False Else If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf With sbf(x1) .Changed = True .sb = what$: bstack.IndexSub = x1 Set .subs = Nothing Set .Pad = Nothing End With End If Else MyFunction = False End If Exit Function ElseIf GetlocalSub(bstack.GroupName + what$, x1) And Not MakeNew Then If FastSymbol(rest$, "(") Then ox = 1 frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyFunction = False Exit Function End If frm$ = Trim$(frm$) Else frm$ = vbNullString End If If FastSymbolNoTrimAfter(rest$, "{") Then If sbf(x1).locked Or sbf(x1).Extern > 0 Then what$ = block(rest$) If Len(what$) = 0 Then what$ = blockString(rest$, Asc("}")) End If bstack.IndexSub = x1 FastSymbol rest$, "}", True Exit Function End If If Len(frm$) <> 0 Then 'If Lang = 1 Then rest$ = neoReadEng + frm$ + vbCrLf + rest$ 'Else ' rest$ = neoReadGr + frm$ + vbCrLf + rest$ 'End If frm$ = vbNullString End If i = Len(rest$) what$ = block(rest$) + " " If Len(what$) = 1 Then what$ = blockString(rest$, Asc("}")) + " " End If While Left$(what$, 10) = "'11001EDIT" SetNextLine what$ Wend If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf what$ = "'11001EDIT " + GetModuleName(bstack, ohere$) + "," + str(-(i - 2 + addlen)) + vbCrLf + what$ If Not FastSymbol(rest$, "}") Then MyFunction = False Else If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf With sbf(x1) .Changed = True .sb = what$ bstack.IndexSub = x1 Set .subs = Nothing Set .Pad = Nothing End With End If Else '' or MyFunction=false If bstack.IndexSub = x1 Then bstack.IndexSub = 0 End If If ox = 0 Then GoTo missdef Else rest$ = vbNullString End If End If Exit Function ElseIf FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyFunction = False Exit Function End If frm$ = Trim$(frm$) If FastSymbolNoTrimAfter(rest$, "{") Then GoTo jumpheretoo rest$ = "" ElseIf FastSymbolNoTrimAfter(rest$, "{") Then jumpheretoo: If here$ = vbNullString Then s$ = block(rest$) If Len(s$) = 0 Then s$ = blockString(rest$, Asc("}")) End If If frm$ <> "" Then s = neoReadEng + frm$ + vbCrLf + s$ End If If Right$(s$, 2) <> vbCrLf Then s$ = s$ + vbCrLf bstack.IndexSub = ModuleSub(what$, s$) Else ss$ = block(rest$) If Len(ss$) = 0 Then ss$ = blockString(rest$, Asc("}")) End If i = Len(rest$) If Left$(sbf(Abs(bstack.OriginalCode)).sb, 10) = "'11001EDIT" Then If InStr(here$, ChrW(&H1FFF)) > 0 Then s$ = vbNullString Else pa$ = sbf(Abs(bstack.OriginalCode)).sb If Not Left$(ss$, 10) = "'11001EDIT" Then s$ = GetNextLine(pa$) + "-" + CStr(i + addlen) + vbCrLf End If End If ElseIf Not bstack.LoadOnly Then If Left$(ss$, 10) <> "'11001EDIT" Then s$ = "'11001EDIT " + GetModuleName(bstack, ohere$) + "," + str(-(i + addlen + 2 * (Len(bstack.UseGroupname) > 0))) + vbCrLf End If End If If frm$ <> "" Then ' If Lang = 1 Then s$ = s$ + vbCrLf + neoReadEng + frm$ + vbCrLf ' Else ' s$ = s$ + vbCrLf + neoReadGr + frm$ + vbCrLf 'End If End If If Not ByPass Then If Len(here$) = 0 Then bstack.IndexSub = ModuleSub(bstack.GroupName + what$, s$ + ss$) Else bstack.IndexSub = ModuleSub(here$ + "." + bstack.GroupName + what$, s$ + ss$) End If End If End If If Not FastSymbol(rest$, "}") Or ByPass Then MyFunction = False If FastSymbol(rest$, ChrW(8189) + ChrW(8189), False, 2) Then sbf(bstack.IndexSub).IamAClass = True sbf(bstack.IndexSub).locked = True End If Exit Function Else MyFunction = False If entrypoint = 2 Then MyEr "missing definition", "λείπει ο ορισμός" Exit Function End If GoTo missdef End If End If Else rest$ = what$ + " " + rest$ MyFunction = False End If End Function Function ProcView(bstack As basetask, rest$, Lang As Long) As Boolean If bstack.toprinter Then oxiforPrinter: Exit Function If Left$(Typename(bstack.Owner), 3) = "Gui" Then oxiforforms: Exit Function If TypeOf bstack.Owner Is MetaDc Then oxiforMetaFiles: Exit Function If TypeOf bstack.Owner Is VB.PictureBox Then On Error GoTo ttt If CLng("0" & bstack.Owner.Tag) > 33 Then oxiforImages: Exit Function End If End If Err.Clear ttt: GetNames bstack, rest$, Form1.List1, Lang mywait bstack, CDbl(100) If Not FastSymbol(rest$, ";") Then ProcView = MyMenu(2, bstack, rest$, Lang) Else ProcView = True End Function Function ProcProto(bstack As basetask, rest$, Lang As Long) As Boolean ProcProto = True Dim s$, W$, v As Long, hastype As Boolean If FastSymbol(rest$, "{") Then s$ = block(rest$) If Right$(s$, 1) = " " Then v = Len(s$) - MyTrimRStr(s$) If v > 0 Then s$ = Replace$(s$, Chr$(10) + space(v), Chr$(10)) ElseIf Right$(s$, 1) = vbTab Then v = Len(s$) - MyTrimRNoCr(s$) If v > 0 Then s$ = Replace$(s$, Chr$(10) + String$(v, vbTab), Chr$(10)) End If v = 0 Else MissingCodeBlock ProcProto = False Exit Function End If If FastSymbol(rest$, "}", True) Then If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then v = FastPureLabel(rest$, W$, , , True) If v = 3 Or v = 1 Then W$ = myUcase(W$, True) If GetVar(bstack, W$, v, True, , , , hastype) Then GoTo cont1 ElseIf GetlocalVar(W$, v) Then hastype = varhash.vType(varhash.index) cont1: If CheckVarOnlyNo(var(v), s$, hastype) Then If VarTypeName(var(v)) = "Constant" Then CantAssignValue ElseIf LastErNum = 0 Then NoObjectAssign End If ProcProto = False Exit Function End If Else v = globalvar(W$, v, , True) var(v) = s$ End If Else MyEr "No string name (using $)", "Δεν βρήκα όνομα αλφαριθμητικού" End If Else MyEr "Missing AS", "Λείπει το Ως" ProcProto = False Exit Function End If Else ProcProto = False End If End Function Function ProcBuffer(bstack As basetask, rest$, Lang As Long, Optional alocal As Boolean) As Boolean ProcBuffer = True Dim s$, what$, i As Long, p As Variant, pp As Long, par As Long, what2$, Runnable As Boolean, itisSingle As Boolean, itisCur As Boolean Dim usehandler As mHandler, useBuffer As MemBlock If IsLabelSymbolNew(rest$, "ΚΩΔΙΚΑ", "CODE", Lang) Then Runnable = True If IsLabelSymbolNew(rest$, "ΚΕΝΗ", "CLEAR", Lang) Then par = &H8 Do While Abs(IsLabel(bstack, rest$, what$)) = 1 If bstack.priveflag Then what$ = ChrW(&HFFBF) + what$ If alocal Then GoTo makeitnow ElseIf GetlocalVar(bstack.GroupName + what$, i) Then If Not MyIsObject(var(i)) Then MakeitObjectBuffer var(i) ElseIf GetVar(bstack, bstack.GroupName + what$, i, True) Then If Not MyIsObject(var(i)) Then MakeitObjectBuffer var(i) Else makeitnow: i = globalvar(bstack.GroupName + what$, Empty) MakeitObjectBuffer var(i) End If If TypeOf var(i) Is mHandler Then Set usehandler = var(i) If TypeOf usehandler.objref Is MemBlock Then GoTo contok End If Expected "Buffer", "Διάρθρωση μνήμης" Exit Function contok: Set usehandler = var(i) Set useBuffer = usehandler.objref ' GET TYPE OF BUFFER ' Char (1 byte) String (2 bytes) Long (4 Bytes) pp = 1 If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then If IsLabelSymbolNew(rest$, "ΨΗΦΙΟ", "BYTE", Lang) Then pp = 1 ElseIf IsLabelSymbolNew(rest$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then pp = 2 ElseIf IsLabelSymbolNew(rest$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If IsLabelSymbolNew(rest$, "ΜΑΚΡΥΣ", "LONG", Lang) Then pp = -8 Else pp = 4 End If ElseIf IsLabelSymbolNew(rest$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then pp = 8 itisCur = True ElseIf IsLabelSymbolNew(rest$, "ΑΠΛΟΣ", "SINGLE", Lang) Then itisSingle = True pp = 4 ElseIf IsLabelSymbolNew(rest$, "ΓΡΑΜΜΑ", "STRING", Lang) Then pp = -4 ElseIf IsLabelSymbolNew(rest$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then pp = 8 ElseIf Abs(IsLabel(bstack, rest$, what2$)) = 1 Then If useBuffer.UseStruct Then If useBuffer.structref.Tag = what2$ Then pp = useBuffer.structref.structLen GoTo contNum Else MyEr "can't change type", "δεν μπορώ να αλλάξω τύπο" Exit Function End If ElseIf GetVar3(bstack, bstack.GroupName + what2$, i) Then If IsExp(bstack, bstack.GroupName + what2$, p) Then If bstack.lastobj Is Nothing Then GoTo comehere If Not TypeOf bstack.lastobj Is mHandler Then GoTo comehere Set usehandler = bstack.lastobj If Not TypeOf usehandler.objref Is StructCollection Then GoTo comehere If usehandler.objref.structLen = 0 Then GoTo comehere pp = usehandler.objref.structLen Set useBuffer.structref = usehandler.objref useBuffer.UseStruct = True Set bstack.lastobj = Nothing Set usehandler = Nothing End If Else If IsExp(bstack, what2$, p) Then If bstack.lastobj Is Nothing Then GoTo comehere If Not TypeOf bstack.lastobj Is mHandler Then GoTo comehere Set usehandler = bstack.lastobj If Not TypeOf usehandler.objref Is StructCollection Then GoTo comehere If usehandler.objref.structLen = 0 Then GoTo comehere pp = usehandler.objref.structLen Set useBuffer.structref = usehandler.objref useBuffer.UseStruct = True Set bstack.lastobj = Nothing Set usehandler = Nothing End If End If Else comehere: SyntaxError ProcBuffer = False Exit Function End If contNum: If FastSymbol(rest$, "*") Then If IsExp(bstack, rest$, p) Then ' we get the size here If p <= 0 Then MyEr "No Zero or Negative number for size", "Όχι μηδέν ή αρνητικό αριθμό για μήκος" ProcBuffer = False Exit Function Else '' MAKE IT If useBuffer.ItemSize <> 0 Then If useBuffer.ItemSize = Abs(pp) Then useBuffer.ResizeItems CLng(p), par End If Else useBuffer.ClearError If itisSingle Then useBuffer.Construct pp, CLng(p), par, Runnable, vbSingle ElseIf itisCur Then useBuffer.Construct pp, CLng(p), par, Runnable, vbCurrency ElseIf pp = -8 Then useBuffer.Construct pp, CLng(p), par, Runnable, 20 Else useBuffer.Construct pp, CLng(p), par, Runnable End If End If End If Else MissPar ProcBuffer = False Exit Function End If Else If useBuffer.status = 0 Then If itisSingle Then useBuffer.Construct pp, 1, par, Runnable, vbSingle ElseIf itisCur Then useBuffer.Construct pp, 1, par, Runnable, vbCurrency ElseIf pp = -8 Then useBuffer.Construct pp, 1, par, Runnable, 20 Else useBuffer.Construct pp, 1, par, Runnable ', useBuffer.ItemSize End If End If End If End If If Not FastSymbol(rest$, ",") Then Exit Do Loop End Function Function ProcInventory(bstack As basetask, rest$, Lang As Long, Optional alocal As Boolean) As Boolean ProcInventory = True Dim s$, what$, i As Long, p As Variant, queue As Boolean, serr As Boolean, usehandler As mHandler queue = IsLabelSymbolNew(rest$, "ΟΥΡΑ", "QUEUE", Lang) Do While Abs(IsLabel(bstack, rest$, what$)) = 1 serr = False conthere: If bstack.priveflag Then what$ = ChrW(&HFFBF) + what$ If Not FastSymbol(rest$, "<") Then ' get local var first If alocal Then i = globalvar(bstack.GroupName + what$, Empty) ' MAKE ONE GoTo makeitnow1 ElseIf GetlocalVar(bstack.GroupName + what$, i) Then If Not MyIsObject(var(i)) Then GoTo makeitnow1 If FastSymbol(rest$, "=") Then GoTo there12 Else If MyIsObject(var(i)) Then If TypeOf var(i) Is mHandler Then Set usehandler = var(i) If usehandler.t1 = 1 Then If Not usehandler.objref Is Nothing Then usehandler.objref.drop 0 End If End If End If End If GoTo makeitnow1 End If ' use global inventory for global ' change from revision 19-version 8.7 ElseIf here$ = vbNullString Then If Not GetVar(bstack, bstack.GroupName + what$, i) Then ' If Not MyIsObject(var(i)) Then GoTo makeitnow1 'GoTo there12 GoTo lookglobal End If GoTo makeitnow1 Else lookglobal: i = globalvar(bstack.GroupName + what$, Empty) ' MAKE ONE ' If Not MyIsObject(var(i)) Then GoTo makeitnow1 If FastSymbol(rest$, "=") Then GoTo there12 Else GoTo makeitnow1 End If End If ElseIf GetVar(bstack, bstack.GroupName + what$, i, True) Then If MyIsObject(var(i)) Then If TypeOf var(i) Is mHandler Then Set usehandler = var(i) If usehandler.t1 = 1 Then If Not usehandler.objref Is Nothing Then usehandler.objref.drop 0 End If End If Set usehandler = Nothing End If End If GoTo makeitnow1 Else i = globalvar(bstack.GroupName + what$, Empty) ' MAKE ONE If i <> 0 Then makeitnow1: MakeitObjectInventory var(i), queue ' here look for block If FastSymbol(rest$, "=") Then there12: Set bstack.lastobj = var(i) ' new addition we can change an inventory to a queue inventory ' but not the other way Set usehandler = bstack.lastobj If queue Then usehandler.objref.AllowAnyKey Set usehandler = Nothing serr = True ProcInventory = AddInventory(bstack, rest$, serr) If serr Then Exit Function serr = Not Abs(IsLabel(bstack, rest$, what$)) = 1 If serr Then Exit Do GoTo conthere Else ' nothing End If End If End If If Not FastSymbol(rest$, ",") Then Exit Do serr = True Loop If serr Then SyntaxError: ProcInventory = False End Function Function ProcThreadPlan(bstack As basetask, rest$, Lang As Long) As Boolean Dim r If IsLabelSymbolNew(rest$, "ΤΑΥΤΟΧΡΟΝΟ", "CONCURRENT", Lang) Then IsExp bstack, rest$, r, , , True 'If TaskMaster.QueueCount <> 0 Then If Not TaskMaster.CanChangePlan Then If Not Interrupted Then MyEr "Threads exist, can't change thread plan", "Υπάρχουν νήματα, δεν μπορείς να αλλάξεις σχέδιο" Else plan = CLng(r) Interrupted = True End If ElseIf IsLabelSymbolNew(rest$, "ΔΙΑΔΟΧΙΚΟ", "SEQUENTIAL", Lang) Then 'If TaskMaster.QueueCount <> 0 Then If Not TaskMaster.CanChangePlan Then If Interrupted Then MyEr "Threads exist, can't change thread plan", "Υπάρχουν νήματα, δεν μπορείς να αλλάξεις σχέδιο" Else plan = 0 Interrupted = False End If End If ProcThreadPlan = True End Function Function ProcItalic(bstack As basetask, rest$) As Boolean Dim p As Variant If IsExp(bstack, rest$, p) Then bstack.myitalic = (p <> 0) Else bstack.myitalic = Not bstack.myitalic p = CDbl(bstack.myitalic) End If players(GetCode(bstack.Owner)).italics = Abs(p <> 0) bstack.Owner.Font.Italic = (p <> 0) ProcItalic = True End Function Function ProcEditDoc(bstack As basetask, rest$, Lang As Long) As Boolean Dim prive As Long, s$, sx As Double, i As Long, dum As Boolean, frm$ Dim x1 As Long, y1 As Long, p As Variant, Col As Long, OldValue As Boolean Dim pppp As iBoxArray prive = GetCode(bstack.Owner) If prive > 32 Then If Left$(Typename(bstack.Owner), 3) = "Gui" Then oxiforforms: Exit Function If TypeOf bstack.Owner Is MetaDc Then oxiforMetaFiles: Exit Function If TypeOf bstack.Owner Is VB.PictureBox Then oxiforImages: Exit Function End If With players(prive) Form1.EditTextWord = Not IsLabelSymbolNew(rest$, "ΚΩΔΙΚΑ", "CODE", Lang) dum = False y1 = Abs(IsLabel(bstack, rest$, s$)) If y1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, i, rest$) Then Exit Function Else MissingDoc Exit Function End If End If If FastSymbol(rest$, ",") Then If Not IsExp(bstack, rest$, sx) Then ' FROM If FastSymbol(rest$, ",") Then GoTo conteditdoc Else MissNumExpr Exit Function End If End If Else sx = 0 End If If FastSymbol(rest$, ",") Then conteditdoc: If Not IsStrExp(bstack, rest$, frm$) Then If FastSymbol(rest$, ",") Then GoTo conteditdoc2 End If Else ' Form1.ResetMarks frm$ = vbNullString End If If FastSymbol(rest$, ",") Then conteditdoc2: If Not IsExp(bstack, rest$, p) Then ' FROM MissStringExpr Exit Function Else Col = CLng(p) dum = True End If 'Else 'Form1.ResetMarks End If If y1 = 3 Then If GetVar(bstack, s$, i) Then If VarTypeName(var(i)) = doc Then If var(i).LastSelStart > 0 And sx = 0 Then x1 = var(i).LastSelStart Else If sx = 0 Then sx = -1 x1 = sx End If Form1.TEXT1.Title = frm$ + " " Form1.TEXT1.TabWidth = ReportTabWidth + 2 * dum Form1.TabControl = ReportTabWidth + 2 * dum OldValue = Form1.nobypasscheck Form1.nobypasscheck = False ScreenEditDOC bstack, var(i), 0, .mysplit, .mX - 1, .mY - 1, x1, dum, Col Form1.nobypasscheck = OldValue var(i).LastSelStart = x1 var(i).ColorEvent = False ProcEditDoc = True Else MissingDoc End If Else MissFuncParameterStringVar End If ElseIf y1 = 6 Then If pppp.ItemType(i) = doc Then If pppp.item(i).LastSelStart > 0 And sx = 0 Then x1 = pppp.item(i).LastSelStart Else If sx = 0 Then sx = -1 x1 = sx End If Form1.TEXT1.Title = frm$ + " " Form1.TEXT1.TabWidth = ReportTabWidth + 2 * dum Form1.TabControl = ReportTabWidth + 2 * dum OldValue = Form1.nobypasscheck Form1.nobypasscheck = False ScreenEditDOC bstack, pppp.item(i), 0, .mysplit, .mX - 1, .mY - 1, x1, dum, Col Form1.nobypasscheck = OldValue pppp.item(i).LastSelStart = x1 pppp.item(i).ColorEvent = False ProcEditDoc = True Else MissingDoc End If Else MissPar End If End With End Function Function ProcStack(bstack As basetask, rest$, Lang As Long) As Boolean Dim ss$, frm$, ps As mStiva, it As Long, X As Variant, x0 As Double, s$, once As Boolean, prive As Long Dim x1 As Long, pa$, what$, i As Long, pppp As iBoxArray, f As Long, myobject As Object, nd&, usehandler As mHandler ProcStack = True If IsLabelSymbolNew(rest$, "ΝΕΟΣ", "NEW", Lang) Then If FastSymbol(rest$, "{") Then ss$ = block(rest$) Set ps = bstack.soros Set bstack.Sorosref = NewmStiva TraceStore bstack, nd&, rest$, 0 rest$ = Mid$(rest$, 2) Call Module10.executeblock(it, bstack, ss$, False, once, , True) bstack.addlen = nd& Set bstack.Sorosref = ps Set ps = Nothing If it = 2 Then If ss$ = "" Then If once Then rest$ = ": Break": If trace Then WaitShow = 2: TestShowSub = vbNullString Else rest$ = ": Goto " + ss$ If trace Then WaitShow = 2: TestShowSub = rest$ End If it = 1 End If If it <> 1 Then ProcStack = False: rest$ = ss$ + rest$ Else ProcStack = False MissingBlockCode End If Exit Function Else If FastSymbol(rest$, "!") Then If VALIDATEpart(rest$, s$) Then X = Empty Do While s$ <> "" If ISSTRINGA(s$, pa$) Then bstack.soros.DataStr pa$ ElseIf IsNumberD2fix(s$, X) Then If MyIsObject(X) Then bstack.soros.DataObj X Else bstack.soros.DataVal X End If X = Empty Else Exit Do End If Loop Else again: If IsExp(bstack, rest$, X) Then If bstack.lastobj Is Nothing Then 'SyntaxError Else If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If TypeOf usehandler.objref Is iBoxArray Then bstack.soros.MergeBottomCopyArray usehandler.objref ElseIf TypeOf usehandler.objref Is mStiva Then bstack.soros.MergeBottom usehandler.objref End If Set usehandler = Nothing ElseIf TypeOf bstack.lastobj Is iBoxArray Then bstack.soros.MergeBottomCopyArray bstack.lastobj End If Set bstack.lastobj = Nothing If FastSymbol(rest$, ",") Then FastSymbol rest$, "!": GoTo again Exit Function End If End If ProcStack = False End If Exit Function Else ' STACK A$ ' stack a$, "NN" If lookOne(rest$, ".") Then If IsStrExp(bstack, rest$, ss$) Then GoTo isAstring ElseIf IsExp(bstack, rest$, X) Then GoTo isAnobject Else SyntaxError ProcStack = False End If Exit Function Else i = 0 If IsLabelSYMB33N(rest$, what$, i) Then If Mid$(rest$, i, 2) = "$(" Then x1 = 6 what$ = myUcase(what$, True) + "$(" Mid$(rest$, 1, i + 1) = space$(i + 1) ElseIf Mid$(rest$, i, 1) = "(" Then x1 = 6 what$ = myUcase(what$, True) + "(" Mid$(rest$, 1, i) = space$(i) ElseIf Mid$(rest$, i, 1) = "$" Then x1 = 3 what$ = myUcase(what$, True) + "$" Mid$(rest$, 1, i) = space$(i) Else what$ = myUcase(what$, True) If GetVar(bstack, what$, it) Then If myVarType(var(it), vbString) Then x1 = 3 Mid$(rest$, 1, i - 1) = space$(i - 1) Else x1 = 0 End If it = 0 End If End If Else x1 = 0 End If If x1 = 3 Then If Not FastSymbol(rest$, "+") Then If GetVar(bstack, what$, it) Then ss$ = var(it) If FastSymbol(rest$, ",") Then If Not IsStrExp(bstack, rest$, pa$) Then ProcStack = False: Exit Function End If If VALIDATE(ss$, pa$, frm$) Then IsSymbol3 pa$, "," If VarTypeName(var(it)) = doc Then Set var(it) = New Document var(it).textDoc = pa$ Else var(it) = pa$ End If Set ps = NewmStiva i = 1 Do While i <= Len(frm$) And ss$ <> "" If Mid$(frm$, i, 1) = "S" Then If ISSTRINGA(ss$, pa$) Then ps.DataStr pa$ Else X = vbEmpty If IsNumberD2fix(ss$, X) Then If MyIsObject(X) Then ps.DataObj X Else ps.DataVal X End If End If End If IsSymbol ss$, "," i = i + 1 Loop With bstack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps End If End With Else MyEr "Stack can't read choosen types", "Ο σωρός δεν μπορεί να διαβάσει τους επιλεγμένους τύπους" ProcStack = False End If Exit Function Else Nosuchvariable what$ End If Else If Not GetVar(bstack, what$, it) Then ProcStack = False: Exit Function what$ = var(it) If IsStrExp(bstack, rest$, ss$) Then pa$ = vbNullString ss$ = what$ + ss$ If VALIDATE(ss$, pa$, frm$) Then Set ps = NewmStiva i = 1 Do While i <= Len(frm$) And ss$ <> "" If Mid$(frm$, i, 1) = "S" Then If ISSTRINGA(ss$, pa$) Then ps.DataStr pa$ Else X = vbEmpty If IsNumberD2fix(ss$, X) Then If MyIsObject(X) Then ps.DataObj X Else ps.DataVal X End If End If End If IsSymbol ss$, "," i = i + 1 Loop With bstack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps End If End With End If Else ProcStack = False Exit Function End If End If ElseIf x1 = 6 Then frm$ = what$ If neoGetArray(bstack, what$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, what$, f, rest$) Then ProcStack = False: Exit Function If pppp.ItemIsObject(f) Then Set myobject = pppp.itemObject(f) GoTo isAnobject2 End If ss$ = pppp.item(f) If FastSymbol(rest$, ",") Then If Not IsStrExp(bstack, rest$, pa$) Then ProcStack = False: Exit Function End If If VALIDATE(ss$, pa$, frm$) Then IsSymbol3 pa$, "," If pppp.ItemType(f) = doc Then s$ = pppp.item(f) Set pppp.item(f) = New Document If s$ <> "" Then pppp.item(f).textDoc = s$ End If Else pppp.item(f) = pa$ End If Set ps = NewmStiva i = 1 Do While i <= Len(frm$) And ss$ <> "" If Mid$(frm$, i, 1) = "S" Then If ISSTRINGA(ss$, pa$) Then ps.DataStr pa$ Else X = vbEmpty If IsNumberD2fix(ss$, X) Then If MyIsObject(X) Then ps.DataObj X Else ps.DataVal X End If End If End If IsSymbol ss$, "," i = i + 1 Loop With bstack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps End If End With Exit Function Else MyEr "String has no valid stack", "Το αλφαριθμητικό δεν έχει έγκυρα στοιχεία σωρού" End If Else If Len(frm$) > 0 Then Mid$(rest$, 1, Len(frm$)) = frm$: frm$ = vbNullString GoTo conthere End If Else conthere: If IsStrExp(bstack, rest$, ss$) Then isAstring: pa$ = vbNullString If VALIDATE(ss$, pa$, frm$) Then Set ps = NewmStiva i = 1 Do While i <= Len(frm$) And ss$ <> "" If Mid$(frm$, i, 1) = "S" Then If ISSTRINGA(ss$, pa$) Then ps.DataStr pa$ Else X = vbEmpty If IsNumberD2fix(ss$, X) Then If MyIsObject(X) Then ps.DataObj X Else ps.DataVal X End If End If End If IsSymbol ss$, "," i = i + 1 Loop With bstack If .SorosNothing Then Set .Sorosref = ps Else .soros.MergeTop ps End If End With 'stack$(bstack) = ss$ & stack$(bstack) Else ProcStack = False End If Exit Function ElseIf IsExp(bstack, rest$, X) Then If myVarType(X, vbString) Then SwapString2Variant ss$, X GoTo isAstring End If isAnobject: Set myobject = bstack.lastobj Set bstack.lastobj = Nothing isAnobject2: If Err Then MyEr "Not a stack", "Δεν είναι σωρός": Exit Function If CheckDeepAny(myobject) Then If Not TypeOf myobject Is mStiva Then MyEr "Not a stack", "Δεν είναι σωρός": Exit Function If FastSymbol(rest$, "{") Then ss$ = block(rest$) TraceStore bstack, nd&, rest$, 0 If FastSymbol(rest$, "}") Then Set ps = bstack.soros Set bstack.Sorosref = myobject it = 0 Call Module10.executeblock(it, bstack, ss$, False, once, , True, True) Set bstack.Sorosref = ps Set ps = Nothing If it = 2 Then If ss$ = "" Then If once Then rest$ = ": Break": If trace Then WaitShow = 2: TestShowSub = vbNullString Else rest$ = ": Goto " + ss$ If trace Then WaitShow = 2: TestShowSub = rest$ End If it = 1 End If If it <> 1 Then ProcStack = False: rest$ = ss$ + rest$ End If bstack.addlen = nd& Else bstack.soros.MergeBottom myobject 'MyEr "No Block {}", "Δεν υπάρχει μπλοκ εντολών { }" End If Else MyEr "Nothing found", "Δεν βρήκα τίποτα" End If Exit Function End If End If i = 0 With bstack.soros s$ = vbNullString Do i = i + 1 If .Total < i Then Exit Do Select Case .StackItemType(i) Case "?" s$ = s$ + "(?) " Case "N", "L", "D" Dim z z = .StackItem(i) If VarType(z) = vbUserDefinedType Then s$ = s$ + strComplex(z) + " " Else s$ = s$ + Trim$(str(z)) + " " End If Case "S" ss$ = .StackItem(i) If Len(ss$) > 78 Then s$ = s$ + Chr(34) + Left$(ss$, 75) + ".." + Chr(34) Else s$ = s$ + Chr(34) + ss$ + Chr(34) End If Case ">" If Lang = 1 Then ss$ = "[Optional]" Else ss$ = "[Προαιρετικό]" End If s$ = s$ + ss$ Case Else Set myobject = .StackItem(i) If Not myobject Is Nothing Then If TypeOf myobject Is mHandler Then Set usehandler = myobject If usehandler.indirect > -1 Then If MyIsObject(var(usehandler.indirect)) Then If usehandler.indirect <= var2used Then s$ = s$ + "*[" + VarTypeName(var(usehandler.indirect)) + "]" Else s$ = s$ + "*[Error]" End If Else s$ = s$ + "*[Nothing]" End If Else Select Case usehandler.t1 Case 1 s$ = s$ + "*[Inventory]" Case 2 s$ = s$ + "*[Buffer]" Case Else s$ = s$ + "*[" + Typename(usehandler.objref) + "]" End Select End If Else s$ = s$ + "*[" + Typename(myobject) + "]" End If Else s$ = s$ + "*[Nothing]" End If End Select Set usehandler = Nothing Loop Set myobject = Nothing End With prive = GetCode(bstack.Owner) PlainBaSket bstack.Owner, players(prive), s$ crNew bstack, players(prive) ' PlainBaSket bstack.Owner, players(prive), "cash:" + Str$(TrushCount) 'crNew bstack, players(prive) Exit Function End If End If End If End Function Function ProcDrop(basestack As basetask, rest$, Lang As Long) As Boolean Dim X As Double, usehandler As mHandler, tmp As FastCollection If Not IsExp(basestack, rest$, X) Then X = 1 Else If Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is mHandler Then Set usehandler = basestack.lastobj If usehandler.ReadOnly Then ReadOnly ProcDrop = False Exit Function End If If usehandler.t1 <> 1 Then OnlyForInventory: Exit Function If TypeOf usehandler.objref Is FastCollection Then Set tmp = usehandler.objref If IsLabelSymbolNew(rest$, "ΕΩΣ", "TO", Lang) Then If IsExp(basestack, rest$, X) Then tmp.drop X + 1 ProcDrop = True Else MissNumExpr End If Else FastSymbol rest$, "," ' optional If IsExp(basestack, rest$, X) Then tmp.drop tmp.Count - X + 1 ProcDrop = True Else tmp.drop tmp.Count ProcDrop = True End If End If End If End If Exit Function End If End If If X < 0 Then MyEr "No many items to drop from stack", "Δεν υπάρχουν τιμές να πετάξω από το σωρό" Exit Function End If If X = 0 Then ' do nothing ProcDrop = True Else If X > basestack.soros.Total Then MissStackItem Exit Function ElseIf X = basestack.soros.Total Then basestack.soros.Flush Else basestack.soros.drop CLng(X) End If ProcDrop = True End If End Function Function ProcShift(basestack As basetask, rest$) As Boolean Dim X As Double, Y As Double, i As Long ProcShift = True If Not IsExp(basestack, rest$, X) Then X = basestack.soros.Total If X <= 0 Then MyEr "No negatives or zero", "Όχι αρνητικοί ή μηδέν" Exit Function End If If X > basestack.soros.Total Then MissStackItem Exit Function Else If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, Y) Then Y = Int(Y) If Y < 0 Then Y = Abs(Y) X = X - 1 If CLng(X + Y) > basestack.soros.Count Then Y = basestack.soros.Count - X For i = X + 1 To X + Y basestack.soros.MakeTopItem CLng(i) Next i Else 'y = y - 1 If CLng(X + Y - 1) > basestack.soros.Count Then Y = basestack.soros.Count - X + 1 For i = Y To 1 Step -1 basestack.soros.MakeTopItem CLng(X + Y - 1) Next i End If End If Else basestack.soros.MakeTopItem CLng(X) End If End If End Function Function ProcShiftBack(basestack As basetask, rest$) As Boolean Dim X As Double, Y As Double, i As Long ProcShiftBack = True If Not IsExp(basestack, rest$, X) Then X = basestack.soros.Total If X <= 0 Then MyEr "No negatives or zero", "Όχι αρνητικοί ή μηδέν" Exit Function End If If X > basestack.soros.Total Then MissStackItem Exit Function Else If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, Y) Then If Y < 0 Then Y = Abs(Int(Y)) X = X - 1 If CLng(X + Y) > basestack.soros.Count Then Y = basestack.soros.Count - X For i = Y To 2 Step -1 basestack.soros.MakeTopItemBack CLng(i + X) Next i If X > 0 Then basestack.soros.MakeTopItemBack CLng(i + X) Else Y = Int(Y) If CLng(X + Y - 1) > basestack.soros.Count Then Y = basestack.soros.Count - X + 1 For i = 1 To Y basestack.soros.MakeTopItemBack CLng(X + Y - 1) Next i End If End If Else basestack.soros.MakeTopItemBack CLng(X) End If End If End Function Function ProcOver(basestack As basetask, rest$) As Boolean Dim X As Double, Y As Double, i As Long ProcOver = True If Not IsExp(basestack, rest$, X) Then X = 1 If X <= 0 Then MyEr "No negatives or zero", "Όχι αρνητικοί ή μηδέν" Exit Function End If If X > basestack.soros.Total Then MissStackItem Exit Function Else If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, Y) Then Y = Int(Y) For i = 1 To Y basestack.soros.Copy2TopItem CLng(X) Next i Else MissPar End If Else basestack.soros.Copy2TopItem CLng(X) End If End If End Function Function ProcFlush(basestack As basetask, rest$, Lang As Long) As Boolean Dim pppp As iBoxArray, what$, it As Long, y1 As Long If IsLabelSymbolNew(rest$, "ΛΑΘΟΣ", "ERROR", Lang) Then NOEXECUTION = False NERR = False LastErNum1 = 0 LastErNum = 0 LastErName = vbNullString LastErNameGR = vbNullString ElseIf IsLabelSymbolNew(rest$, "ΣΚΟΥΠΙΔΙΑ", "GARBAGE", Lang) Then GarbageFlush2 Else Do y1 = Abs(IsLabel(basestack, rest$, what$)) If y1 = 0 Then If it = 0 Then basestack.soros.Flush Else If y1 = 3 Then If GetVar(basestack, what$, it) Then If VarTypeName(var(it)) = doc Then var(it).EmptyDoc Else SyntaxError Exit Function End If Else SyntaxError Exit Function End If ElseIf y1 = 6 Then If neoGetArray(basestack, what$, pppp) Then If Not pppp.arr Then NotArray: Exit Function If Not NeoGetArrayItem(pppp, basestack, what$, it, rest$) Then Exit Function If pppp.ItemType(it) = doc Then Set pppp.item(it) = New Document pppp.item(it).EmptyDoc Else SyntaxError Exit Function End If Else SyntaxError Exit Function End If End If End If Loop Until Not FastSymbol(rest$, ",") End If ProcFlush = True End Function Function ProcRelease(basestack As basetask) As Boolean ' make this for each Guim2000 form also If basestack.Owner.Name = "DIS" Then Form1.MY_BACK.PaintPicture Form1.DIS.hDC ElseIf Typename(basestack.Owner) = "GuiM2000" Then Dim a As GuiM2000 Set a = basestack.Owner If a.Sizable Then MyEr "Not for User forms with resize function", "Όχι για φόρμες χρήστη με δυνατότητα αλλαγής μεγέθους" Else a.MY_BACK.PaintPicture a.hDC End If Set a = Nothing ElseIf basestack.Owner Is Form1 Then Form1.Back_Back.PaintPicture Form1.hDC ElseIf TypeOf basestack.Owner Is VB.PictureBox Then On Error GoTo there1 Dim p As Long p = GetCode(basestack.Owner) If p > 32 Then If getvar2(basestack, players(p).ControlName, p, True) Then Dim b As GuiImage Set b = var(p) If Not b.MY_BACK Is Nothing Then With b .MY_BACK.PaintPicture .pbox.hDC Set b = Nothing End With End If End If End If End If ProcRelease = True Exit Function there1: Err.Clear End Function Function ProcHold(basestack As basetask) As Boolean ' make this for each Guim2000 form also Dim p As Long If basestack.Owner.Name = "DIS" Then Form1.MY_BACK.ClearUp If Form1.MY_BACK.create(Form1.DIS.Width / DXP, Form1.DIS.Height / DYP) Then Form1.MY_BACK.LoadPictureBlt Form1.DIS.hDC If Form1.MY_BACK.bitsPerPixel <> 24 Then Conv24 Form1.MY_BACK End If ElseIf Typename(basestack.Owner) = "GuiM2000" Then Dim a As GuiM2000 Set a = basestack.Owner If a.MY_BACK Is Nothing Then Set a.MY_BACK = New cDIBSection If a.Sizable Then MyEr "Not for User forms with resize function", "Όχι για φόρμες χρήστη με δυνατότητα αλλαγής μεγέθους" Else With a .MY_BACK.ClearUp If .MY_BACK.create(.Width / DXP, .Height / DYP) Then .MY_BACK.LoadPictureBlt .hDC If .MY_BACK.bitsPerPixel <> 24 Then Conv24 .MY_BACK End If Set a = Nothing End With End If ElseIf basestack.Owner Is Form1 Then Form1.Back_Back.ClearUp If Form1.Back_Back.create(Form1.Width / DXP, Form1.Height / DYP) Then Form1.Back_Back.LoadPictureBlt Form1.hDC If Form1.Back_Back.bitsPerPixel <> 24 Then Conv24 Form1.Back_Back End If ElseIf TypeOf basestack.Owner Is VB.PictureBox Then On Error GoTo there1 p = GetCode(basestack.Owner) If p > 32 Then If getvar2(basestack, players(p).ControlName, p, True) Then Dim b As GuiImage Set b = var(p) If b.MY_BACK Is Nothing Then Set b.MY_BACK = New cDIBSection With b .MY_BACK.ClearUp If .MY_BACK.create(.pbox.Width / DXP, .pbox.Height / DYP) Then .MY_BACK.LoadPictureBlt .pbox.hDC If .MY_BACK.bitsPerPixel <> 24 Then Conv24 .MY_BACK End If Set b = Nothing End With End If End If End If ProcHold = True Exit Function there1: Err.Clear End Function Function ProcGet(basestack As basetask, rest$) As Boolean Dim pppp As iBoxArray, it As Long, what$, p As Variant, f As Variant, par As Boolean, s$, arr As Boolean Dim flag As Boolean, usehandler As mHandler, pp As Variant, RF As refArray IsSymbol3 rest$, "#" If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then f = Int(p) If Fkind(f) = FnoUse Or Fkind(f) = Foutput Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": ProcGet = False: Exit Function If Not FastSymbol(rest$, ",") Then GoTo ex123 Select Case IsLabel(basestack, rest$, what$) Case 1 ' check to see if is a handler If GetVar(basestack, what$, it) Then pp = 0 If VarTypeName(var(it)) = mHdlr Then If var(it).ReadOnly Then ReadOnly GoTo ex123 End If Set usehandler = var(it) flag = True ElseIf myVarType(var(it), vbObject) Then If Not var(it) Is Nothing Then If TypeOf var(it) Is refArray Then GoTo checkRF End If End If End If End If par = False Case 5 'check for handler what$ = Left$(what$, Len(what$) - 1) If GetVar(basestack, what$, it) Then pp = 0 If IsExp(basestack, rest$, pp, flatobject:=True, nostring:=True) Then ' nothing here arr = True End If If Not FastSymbol(rest$, ")") Then GoTo ex123 If Not VarTypeName(var(it)) = mHdlr Then GoTo ex123 Set usehandler = var(it) If usehandler.t1 <> 2 Then MissType GoTo ex123 End If If usehandler.ReadOnly Then ReadOnly GoTo ex123 End If flag = True End If par = False Case 3 If Fkind(f) <> Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": ProcGet = False: Exit Function par = True: If Not GetVar(basestack, what$, it) Then it = globalvar(what$, "") Case 6 If Fkind(f) <> Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": ProcGet = False: Exit Function par = False: If neoGetArray(basestack, what$, pppp) Then If Not NeoGetArrayItem(pppp, basestack, what$, it, rest$) Then GoTo ex123 Case 8 If GetVar(basestack, what$, it) Then If myVarType(var(it), vbObject) Then If TypeOf var(it) Is refArray Then If Not IsExp(basestack, rest$, pp, flatobject:=True, nostring:=True) Then pp = 0 End If If FastSymbol(rest$, "]", True) Then checkRF: Set RF = var(it) If RF.MarkTwoDimension Then GoTo err11 Select Case RF.ItemType(0) Case vbObject, vbVariant, vbString err11: MissType GoTo ex123 Case Else If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then FileSeek(f) = (Int(p) - 1@) * Fstep(f) + 1@ End If End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) Else GoTo ok112 End If Else p = 0 End If RF.GetData (f), CLng(pp), CLng(p) GoTo ok112 End Select End If End If End If End If MissingStrVar GoTo ex123 Case Else MissingStrVar GoTo ex123 End Select If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then FileSeek(f) = (Int(p) - 1@) * Fstep(f) + 1@ ElseIf Not flag Then MissNumExpr GoTo ex123 End If End If If flag Then If usehandler.t1 = 1 Then MissType GoTo ex123 End If Dim buf As MemBlock Dim aa() As Byte Set buf = usehandler.objref With buf ' pp is offset If Fstep(f) = 1 Then If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, pp, flatobject:=True, nostring:=True) Then reenter1: pp = Int(Abs(pp)) If pp = 0 Then GoTo wrong If .ValidArea(p, CLng(pp)) Then .GetData (f), p, CLng(pp) Else GoTo wrong End If Else MissNumExpr ProcGet = False GoTo ex123 End If Else SwapVariant pp, p p = .GetPtr(p) GoTo reenter1 End If Else MissNumExpr ProcGet = False GoTo ex123 End If Else On Error Resume Next .GetData (f), .GetBytePtr(0), .SizeByte End If Else If arr Then p = 1 If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then MissNumExpr GoTo ex123 End If End If p = Int(Abs(p)) If p = 0 Then GoTo wrong If .ValidArea2(pp, Fstep(f) * p) Then .GetData (f), .GetPtr(pp), Fstep(f) * p Else wrong: MyEr "Wrong size-position for loading the buffer", "Λάθος μέγεθος-θέση για να φορτωθεί η Διάρθρωση" GoTo ex123 End If Else .GetData (f), .GetPtr(0), .SizeByte End If End If End With Else Dim FH As Long FH = Module10.ReadFileHandler(CLng(f)) If FH = 0 Then Exit Function FileReadString FH, s$, Fstep(f) If Not uni(f) Then If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then MissPar: Exit Function On Error Resume Next s$ = StrConv(s$, vbUnicode, CLng(p)) If Err Then Err.Clear: NoValidLocale: Exit Function Else s$ = StrConv(s$, vbUnicode, Clid) End If End If If par Then CheckVar var(it), s$ Else If pppp Is Nothing Then NotArray ProcGet = False GoTo ex123 ElseIf pppp.ItemType(it) = doc Then Set pppp.item(it) = New Document If s$ <> "" Then pppp.item(it).textDoc = s$ Else pppp.item(it) = s$ End If End If End If End If ok112: ProcGet = True ex123: Set pppp = Nothing Set usehandler = Nothing Set basestack.lastobj = Nothing End Function Function ProcPipe(basestack As basetask, rest$) As Boolean Dim stac1$, ss$, p As Variant, s$ If IsStrExp(basestack, rest$, ss$) Then If FastSymbol(rest$, ",") Then stac1$ = vbNullString Do If IsExp(basestack, rest$, p, , True) Then If MemInt(VarPtr(p)) = 20 Then stac1$ = stac1$ + " " + CStr(p) ElseIf VarType(p) = vbString Then stac1$ = stac1$ + " " + LTrim$(p) Else stac1$ = stac1$ + " " + LTrim$(str(p)) End If ElseIf IsStrExp(basestack, rest$, s$) Then stac1$ = stac1$ + Sput(s$) Else Exit Do End If If Not FastSymbol(rest$, ",") Then Exit Do Loop If VALIDATE(stac1$, "", s$) Then ProcPipe = Trans2pipe(ss$, Sput(ss$) + Sput(s$) + stac1$) Exit Function End If End If End If ProcPipe = True End Function Function ProcGroup(entrypoint As Long, basestack As basetask, rest$, Lang As Long) As Boolean Dim s$, x1 As Long, y1 As Long, what$, flag As Boolean, ss$, i As Long, par As Boolean Dim p As Variant, HasStrName As Boolean, strName$, NewStat As Boolean, addlen As Long ProcGroup = True Dim y3 As Long If entrypoint = -1 Then NewStat = True: entrypoint = 0 If entrypoint < 199 Then If entrypoint = 1 Then flag = True y3 = IsLabelSymbolNew(rest$, "ΜΕΓΕΓΟΝΟΤΑ", "WITHEVENTS", Lang) If IsLabelSymbolNew(rest$, "ΑΥΤΟ", "THIS", Lang) Then If Len(basestack.UseGroupname) > 0 Then MyEr "Not in a Group Definition: Remove Group This { }", "Όχι σε ορισμό ομάδας: Αφαίρεσε την Ομάδα Αυτό {} " Exit Function Else s$ = vbNullString If basestack.GetDotNew(s$, 1) Then If Len(s$) = 0 Then: Exit Function '' why what$ = Left$(s$, Len(s$) - 1) x1 = 1 Else MyEr "Used in a For statement, For Group { this= or =this }", "Χρησιμοποιείται εντός ενός ΓΙΑ ομάδα { αυτό= ή =αυτό} " Exit Function End If End If Else x1 = Abs(IsLabel(basestack, rest$, what$)) End If Else what$ = rest$ If Right$(what$, 1) = "$" Then HasStrName = True strName$ = what$ what$ = Left$(what$, Len(what$) - 1) End If flag = entrypoint = 199 If GetVar(basestack, basestack.GroupName + rest$, i, flag) Then If MyIsObject(var(i)) Then If Not TypeOf var(i) Is Group Then SyntaxError Exit Function End If Else Set var(i) = New Group End If ElseIf Not GetVar(basestack, basestack.GroupName + what$, i, flag) Then i = globalvar(basestack.GroupName + what$, 0&, False, flag) Set var(i) = New Group Else If MyIsObject(var(i)) Then If Not TypeOf var(i) Is Group Then SyntaxError Exit Function End If Else Set var(i) = New Group End If End If If entrypoint = 199 Then var(i).IamGlobal = True UnFloatGroupReWriteVars basestack, basestack.GroupName + what$, i, basestack.lastobj Set basestack.lastobj = Nothing ElseIf entrypoint = 200 Then If basestack.lastobj.IamApointer Then If Not basestack.lastobj.link.IamFloatGroup Then CopyPointerRef basestack, basestack.lastobj End If End If UnFloatGroup basestack, basestack.GroupName + what$, i, basestack.lastobj, var(i).IamGlobal Set basestack.lastobj = Nothing If Len(basestack.UseGroupname) <> 0 Then var(i).IamRef = True globalvar what$, CVar(i), True, True End If End If ProcGroup = True Exit Function End If If x1 = 8 Then ProcGroup = False: SyntaxError: Exit Function again: If x1 = 3 Then HasStrName = True strName$ = what$ what$ = Left$(what$, Len(what$) - 1) x1 = 1 End If If x1 = 1 Then If IsLabelSymbolNew(rest$, "ΤΥΠΟΣ", "TYPE", Lang) Then If IsStrExp(basestack, rest$, ss$) Then s$ = basestack.GroupName prepareGroup basestack, what$, y1, flag, HasStrName var(y1).IamGlobal = flag ProcGroup = ExecuteGroupStruct(basestack, basestack.GroupName + what$, y1, ss$, 0, Lang) <> 0 basestack.GroupName = s$ End If Else par = Not FastSymbol(rest$, "+") If FastSymbol(rest$, "{") Then If par Then '' GROUP prepareGroup basestack, what$, y1, flag, HasStrName, NewStat var(y1).IamGlobal = flag If flag Then ss$ = here$: here$ = vbNullString addlen = Len(rest$) s$ = block(rest$) addlen = addlen - Len(s$) If ExecuteGroupStruct(basestack, basestack.GroupName + what$, y1, s$, addlen, Lang, flag, NewStat) = 0 Then If flag Then here$ = ss$ var(y1).edittag = "'11001EDIT " & here$ & ", " & (Len(rest$) - addlen - Len(s$)) ProcGroup = False Exit Function Else If s$ = "BREAK" Then s$ = "" If flag Then here$ = ss$ ProcGroup = FastSymbol(rest$, "}") rest$ = vbNullString GoTo CONTcontinue End If End If If flag Then here$ = ss$ ProcGroup = FastSymbol(rest$, "}") CONTcontinue: var(y1).FlushEvents If y3 = -1 Then On Error Resume Next MakeThunk what$, y1, basestack.UseGroupname, basestack.tpointer End If Else '' CLASS ss$ = block(rest$) s$ = basestack.GroupName prepareGroup basestack, what$, y1, flag, HasStrName var(y1).IamGlobal = flag If ExecuteGroupStruct(basestack, basestack.GroupName + what$, y1, ss$, 0, Lang, flag) = 0 Then rest$ = ss$ + rest$ Else ProcGroup = FastSymbol(rest$, "}") End If End If basestack.GroupName = s$ If var(y1).IamApointer Then Set var(y1) = CopyGroup0Obj(var(y1), p) PopStage basestack End If Else If GetVar(basestack, basestack.GroupName + what$, i, flag) Then ProcGroup = True Else contthere: i = globalvar(basestack.GroupName + what$, 0&, False, flag) Set var(i) = New Group var(i).IamGlobal = flag If FastSymbol(rest$, "=") Then If IsExp(basestack, rest$, p) Then If Not basestack.lastobj Is Nothing Then If IsObjGroup(basestack.lastobj) Then If basestack.lastobj.IamApointer Then If basestack.lastobj.link.IamFloatGroup Then Set basestack.lastobj = basestack.lastobj.link Else Dim ohere$, w2 As Long ohere$ = here$ here$ = basestack.lastobj.lasthere If GetVar(basestack, basestack.lastobj.GroupName, w2, , , True) Then CopyGroup2 var(w2), basestack End If here$ = ohere$ End If Set basestack.lastpointer = Nothing End If UnFloatGroup basestack, basestack.GroupName + what$, i, basestack.lastobj, flag Set basestack.lastobj = Nothing End If End If End If If Len(basestack.UseGroupname) <> 0 Then var(i).IamRef = True If Not flag Then globalvar what$, CVar(i), True, True End If var(i).FlushEvents If y3 = -1 Then On Error Resume Next MakeThunk what$, i, basestack.UseGroupname, basestack.tpointer End If ElseIf FastSymbol(rest$, "->", , 2) Then If y3 = -1 Then If IsExp(basestack, rest$, p) Then If Not basestack.lastobj Is Nothing Then If IsObjGroup(basestack.lastobj) Then UnFloatGroup basestack, basestack.GroupName + what$, i, basestack.lastobj, flag Set basestack.lastobj = Nothing End If End If End If var(i).ResetEvents On Error Resume Next MakeThunk what$, i, basestack.UseGroupname, basestack.tpointer Else MyEr "Used only with Group WithEvents", "Χρησιμοποιείται μόνο με την Ομάδα ΜεΓεγονότα" ProcGroup = False End If ElseIf entrypoint = 99 Then var(i).IamGlobal = True UnFloatGroup basestack, basestack.GroupName + what$, i, basestack.lastobj, True Set basestack.lastobj = Nothing ElseIf entrypoint = 100 Then If basestack.lastobj.IamApointer Then If Not basestack.lastobj.link.IamFloatGroup Then CopyPointerRef basestack, basestack.lastobj End If End If UnFloatGroup basestack, basestack.GroupName + what$, i, basestack.lastobj, here$ = vbNullString Set basestack.lastobj = Nothing Else var(i).GroupName = what$ + "." If HasStrName Then GlobalVarRefLink what$ + "$", i, flag End If If FastSymbol(rest$, ",") Then x1 = Abs(IsLabel(basestack, rest$, what$)) If x1 = 1 Or x1 = 3 Then GoTo again SyntaxError ProcGroup = False Exit Function End If If Len(var(i).Patch) = 0 Then If flag Then Else var(i).Patch = here$ + "." + basestack.GroupName + what$ End If End If End If Exit Function End If End If End If End If End Function Sub MakeThunk(where$, vvv As Long, ByVal GroupName$, ByVal tpointer As Long) Dim EventObj As FastCollection, M As Group, it As Long Set M = var(vvv) Set EventObj = M.Events If EventObj Is Nothing Then Exit Sub Dim i As Long, j As Long, part$ If here$ <> "" Then where$ = here$ + "." + where$ With EventObj For i = 0 To .Count - 1 .index = i .Done = True If .Value = vbNullString Then .Value = where$ + "_" + .KeyToString + "()" If GetSub(.Value, it) Then .sValue = it Else .sValue = ModuleSub(.Value, "", GroupName$) sbf(.sValue).tpointer = tpointer End If End If Next i .Done = False End With End Sub Function MyModule(basestack As basetask, rest$, Lang As Long, Optional noskipcommand = False, Optional MakeNew As Boolean, Optional addlen As Long = 0, Optional skipglob As Boolean = False, Optional ByPass As Boolean) As Boolean Dim s$, pa$, ss$, x1 As Long, par As Boolean, what$, ohere$, i As Long, x3 As Long, frm$ ohere$ = here$ MyModule = True If skipglob Then par = Len(ohere$) = 0 Else x1 = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΟ", "GLOBAL", Lang) par = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", Lang) End If If x1 <> 0 Then If lookOne(rest$, Chr(34)) Then ISSTRINGA rest$, what$ GoTo bypass1 End If End If x3 = IsLabelF(rest$, what$) If x3 = 1 Then If Right$(what$, 1) = "(" Then If FastSymbol(rest$, ")") Then what$ = what$ + ")" End If If x1 Then bypass1: If Not GetGlobalSubAfterHere(basestack, what$, x1) Then If noskipcommand Then x1 = ModuleSub(what$, "") Else x1 = GlobalSub(what$, "", , what$) End If basestack.IndexSub = x1 sbf(x1).sbc = 1 End If If FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyModule = False Exit Function End If frm$ = Trim$(frm$) End If If FastSymbolNoTrimAfter(rest$, "{") Then ss$ = block(rest$) If Len(ss$) = 0 Then ss$ = blockString(rest$, Asc("}")) End If i = Len(rest$) If Left$(sbf(Abs(basestack.OriginalCode)).sb, 10) = "'11001EDIT" Then If InStr(here$, ChrW(&H1FFF)) > 0 Then s$ = vbNullString Else pa$ = sbf(Abs(basestack.OriginalCode)).sb If Not Left$(ss$, 10) = "'11001EDIT" Then s$ = GetNextLine(pa$) & "-" & CStr(i) + vbCrLf End If End If Else If Left$(ss$, 10) <> "'11001EDIT" Then If LenB(here$) = 0 Then ElseIf basestack.OriginalCode > 0 And Not basestack.LoadOnly Then s$ = "'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str(-(i + addlen - 2)) + vbCrLf End If End If End If If frm$ <> "" Then 'If Lang = 1 Then s$ = s$ + vbCrLf + neoReadEng + frm$ + vbCrLf 'Else ' s$ = s$ + vbCrLf + neoReadGr + frm$ + vbCrLf 'End If End If With sbf(x1) .sb = s$ + ss$: basestack.IndexSub = x1 Set .subs = Nothing Set .Pad = Nothing End With If Not FastSymbol(rest$, "}") Then MyModule = False Else MyEr what$ + " missing definition", what$ + " λείπει ο ορισμός" End If Exit Function Else If par Then If noskipcommand Then x1 = ModuleSub(what$, "") sbf(x1).sbc = 1 Else If Len(here$) = 0 Then x1 = GlobalSub(what$, "", , what$) Else x1 = GlobalSub(here$ + "." + what$, "", , what$) GoTo jump1 End If End If GoTo jump0 ElseIf here$ = vbNullString And GetSub(what$, x1) And Not MakeNew Then jump0: If x1 >= lckfrm And lckfrm <> 0 Then MyEr what$ + " is locked", what$ + " είναι κλειδωμένο" rest$ = vbNullString MyModule = False: Exit Function End If If FastSymbolNoTrimAfter(rest$, "{") Then what$ = block(rest$) If Len(what$) = 0 Then what$ = blockString(rest$, Asc("}")) End If If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf If Not FastSymbol(rest$, "}") Then MyModule = False Else If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf With sbf(x1) .Changed = True .sb = what$: basestack.IndexSub = x1 Set .subs = Nothing Set .Pad = Nothing End With End If Else rest$ = ":" + what$ + " " + rest$ ''why End If Exit Function ElseIf GetlocalSub(basestack.GroupName + what$, x1) And Not MakeNew Then jump1: If FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If Len(frm$) = 0 Then frm$ = blockString(rest$, Asc("}")) End If If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyModule = False Exit Function End If frm$ = Trim$(frm$) End If If FastSymbolNoTrimAfter(rest$, "{") Then If x1 >= lckfrm And lckfrm <> 0 Then MyEr what$ + " is locked", what$ + " είναι κλειδωμένο" rest$ = vbNullString MyModule = False: Exit Function End If i = Len(rest$) '' what$ = block(rest$) + " " If Len(what$) = 1 Then what$ = blockString(rest$, Asc("}")) + " " End If If Not sbf(x1).locked Then While Left$(what$, 10) = "'11001EDIT" SetNextLine what$ Wend If Right$(what$, 2) <> vbCrLf Then what$ = what$ + vbCrLf s$ = "'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str(-(i + addlen - 2)) If frm$ <> "" Then ' If Lang = 1 Then what$ = s$ + vbCrLf + neoReadEng + frm$ + vbCrLf + what$ ' Else ' what$ = s$ + vbCrLf + neoReadGr + frm$ + vbCrLf + what$ ' End If Else what$ = s$ + vbCrLf + what$ End If If Not FastSymbol(rest$, "}") Then MyModule = False Else With sbf(x1) .Changed = True .sb = what$ basestack.IndexSub = x1 Set .subs = Nothing Set .Pad = Nothing End With End If Else If Not FastSymbol(rest$, "}") Then MyModule = False Else basestack.IndexSub = x1 End If End If Else rest$ = ":" + basestack.GroupName + what$ + " " + rest$ End If Exit Function ElseIf FastSymbol(rest$, "(") Then frm$ = BlockParam(rest$) If frm$ <> "" Then Mid$(rest$, 1, Len(frm$)) = space$(Len(frm$)) ': If InStr(frm$, "=") > 0 Then frm$ = "? " + frm$ If Not FastSymbol(rest$, ")", True) Then MyModule = False Exit Function End If frm$ = Trim$(frm$) If FastSymbolNoTrimAfter(rest$, "{") Then GoTo jumpheretoo ElseIf FastSymbolNoTrimAfter(rest$, "{") Then jumpheretoo: If here$ = vbNullString Then pa$ = block(rest$) If Len(pa$) = 0 Then pa$ = blockString(rest$, Asc("}")) End If If frm$ <> "" Then pa$ = neoReadEng + frm$ + vbCrLf + pa$ If Right$(pa$, 2) <> vbCrLf Then pa$ = pa$ + vbCrLf If noskipcommand Then basestack.IndexSub = ModuleSub(what$, pa$) Else basestack.IndexSub = GlobalSub(what$, pa$, , what$) End If Else ss$ = block(rest$) If Len(ss$) = 0 Then ss$ = blockString(rest$, Asc("}")) End If i = Len(rest$) If Left$(sbf(Abs(basestack.OriginalCode)).sb, 10) = "'11001EDIT" Then If InStr(here$, ChrW(&H1FFF)) > 0 Then s$ = vbNullString Else pa$ = sbf(Abs(basestack.OriginalCode)).sb If Not Left$(ss$, 10) = "'11001EDIT" Then s$ = GetNextLine(pa$) + "-" + CStr(i) + vbCrLf End If End If ElseIf Not basestack.LoadOnly Then If Left$(ss$, 10) <> "'11001EDIT" Then If addlen = 0 Then addlen = -1 s$ = "'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str(-(i + addlen)) + vbCrLf End If End If If frm$ <> "" Then ' If Lang = 1 Then s$ = s$ + neoReadEng + frm$ + vbCrLf ' Else ' s$ = s$ + neoReadGr + frm$ + vbCrLf 'End If End If If noskipcommand Then If Not ByPass Then If basestack.GroupName = vbNullString Then basestack.IndexSub = ModuleSub(here$ + "." + what$, s$ + ss$) Else basestack.IndexSub = ModuleSub(here$ + "." + basestack.GroupName + what$, s$ + ss$) End If sbf(basestack.IndexSub).sbc = 1 End If Else If basestack.GroupName = vbNullString Then basestack.IndexSub = GlobalSub(here$ + "." + what$, s$ + ss$, , what$) Else basestack.IndexSub = ModuleSub(here$ + "." + basestack.GroupName + what$, s$ + ss$) End If End If End If If Not FastSymbol(rest$, "}") Or ByPass Then MyModule = False Exit Function Else If basestack.StaticCollection Is Nothing Then ConnectStatic basestack, myUcase(what$) basestack.connectnow = True here$ = what$ End If End If Else If what$ <> "" Then rest$ = what$ + " :" + rest$ If IsStrExp(basestack, rest$, s$) Then If basestack.StaticCollection Is Nothing Then ConnectStatic basestack, myUcase(s$) basestack.connectnow = True here$ = myUcase(s$) Else rest$ = what$ + " " + rest$ MyModule = False End If End If End Function Function MyEscape(rest$, Lang As Long) As Boolean MyEscape = True If Lang = 1 Then If IsLabelSymbolLatin(rest$, "ON") Then escok = True ElseIf IsLabelSymbolLatin(rest$, "OFF") Then escok = False Else MyEscape = False End If Else If IsLabelSymbol(rest$, "ΝΑΙ") Then escok = True ElseIf IsLabelSymbol(rest$, "ΟΧΙ") Then escok = False Else MyEscape = False End If End If End Function Function MyPut(basestack As basetask, rest$) As Boolean Dim s$, f As Long, p As Variant, i As Long, pp As Variant, it As Long, flag As Boolean, arr As Boolean Dim usehandler As mHandler, what$, RF As refArray MyPut = False IsSymbol3 rest$, "#" If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then f = CLng(p) If Fkind(f) = FnoUse Or Fkind(f) = Finput Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": Exit Function If Not FastSymbol(rest$, ",") Then Exit Function i = 1 what$ = aheadstatus(rest$, , i) If Left$(what$, 1) = "N" Then Select Case IsLabel(basestack, rest$, what$) Case 1 ' check to see if is a handler If GetVar(basestack, what$, it) Then pp = 0 If VarTypeName(var(it)) = mHdlr Then If var(it).ReadOnly Then ReadOnly GoTo ex123 End If Set usehandler = var(it) ElseIf myVarType(var(it), vbObject) Then If Not var(it) Is Nothing Then If TypeOf var(it) Is refArray Then GoTo checkRF End If End If End If flag = True End If Case 5 'check for handler what$ = Left$(what$, Len(what$) - 1) If GetVar(basestack, what$, it) Then pp = 0 If IsExp(basestack, rest$, pp, flatobject:=True, nostring:=True) Then ' nothing here arr = True End If If Not FastSymbol(rest$, ")") Then GoTo ex123 If Not VarTypeName(var(it)) = mHdlr Then GoTo ex123 If var(it).ReadOnly Then ReadOnly GoTo ex123 End If Set usehandler = var(it) flag = True Else basestack.tmpstr = what$ + "(" + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) If IsExp(basestack, rest$, p) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant s$, p GoTo JUMPHERE End If End If End If Case 8 If GetVar(basestack, what$, it) Then If myVarType(var(it), vbObject) Then If TypeOf var(it) Is refArray Then If Not IsExp(basestack, rest$, pp, flatobject:=True, nostring:=True) Then pp = 0 End If If FastSymbol(rest$, "]", True) Then checkRF: Set RF = var(it) If RF.MarkTwoDimension Then GoTo err11 Select Case RF.ItemType(0) Case vbObject, vbVariant, vbString err11: MissType GoTo ex123 Case Else If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then FileSeek(f) = (Int(p) - 1@) * Fstep(f) + 1@ End If End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) Else GoTo ok112 End If Else p = 0 End If RF.putData (f), CLng(pp), CLng(p) GoTo ok112 End Select End If End If End If Else SyntaxError GoTo ex123 End If Case Else SyntaxError GoTo ex123 End Select Else If Fkind(f) <> Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": MyPut = False: Exit Function If Not IsStrExp(basestack, rest$, s$) Then GoTo ex123 End If JUMPHERE: If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then FileSeek(f) = (CCur(p) - 1@) * Fstep(f) + 1@ ElseIf Not flag Then GoTo ex123 End If End If If flag Then Dim buf As MemBlock Dim aa() As Byte Set buf = usehandler.objref With buf If Fstep(f) = 1 Then If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, pp, flatobject:=True, nostring:=True) Then pp = Int(Abs(pp)) If .ValidArea(p, CLng(pp)) Then .putData f, p, CLng(pp) Else GoTo wrong End If Else MissNumExpr GoTo ex123 End If Else MissNumExpr GoTo ex123 End If Else MissNumExpr GoTo ex123 End If Else .putData f, .GetBytePtr(0), .SizeByte End If Else If arr Then p = 1 If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then MissNumExpr MyPut = False GoTo ex123 End If End If p = Int(Abs(p)) If p = 0 Then GoTo wrong If .ValidArea2(pp, Fstep(f) * p) Then .putData f, .GetPtr(pp), Fstep(f) * p Else wrong: MyEr "Wrong size-position for loading the buffer", "Λάθος μέγεθος-θέση για να φορτωθεί η Διάρθρωση" GoTo ex123 End If Else .putData f, .GetPtr(0), .SizeByte End If End If End With ' use pp for Else If Fkind(f) <> Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": MyPut = False: Exit Function If uni(f) Then s$ = Left$(s$, Fstep(f) \ 2) s$ = s$ + space$(Fstep(f) \ 2 - Len(s$)) Else s$ = Left$(s$, Fstep(f)) s$ = s$ + space$(Fstep(f) - Len(s$)) End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then FileSeek(f) = (CCur(p) - 1@) * Fstep(f) + 1@ Else GoTo ex123 End If End If If Not uni(f) Then If FastSymbol(rest$, ",") Then If Not IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then MissPar: Exit Function On Error Resume Next s$ = StrConv(s$, vbFromUnicode, CLng(p)) If Err Then Err.Clear: NoValidLocale: Exit Function Else s$ = StrConv(s$, vbFromUnicode, Clid) End If End If i = Module10.ReadFileHandler(CLng(f)) Module10.FileWriteString i, s$ End If ok112: MyPut = True End If ex123: Set usehandler = Nothing Set basestack.lastobj = Nothing End Function Function ProcDir(basestack As basetask, rest$, Lang As Long) As Boolean Dim pa$, W$, par As Boolean, s$, ss$, i As Long, p As Variant, what$, x1 As Long If IsLabelSymbolNew(rest$, "ΧΡΗΣΤΗ", "USER", Lang) Then If IsSupervisor Then dset Else mcd = userfiles End If ProcDir = True Exit Function ElseIf IsLabelSymbolNew(rest$, "ΚΥΡΙΟ", "MASTER", Lang) Then userfiles = GetSpecialfolder(CLng(26)) + "\M2000\" ProcDir = True Exit Function ElseIf IsLabelSymbolNew(rest$, "ΥΠΟΛΟΓΙΣΤΗ", "COMPUTER", Lang) Then If IsSupervisor Then pa$ = "#" Else BadCommand: ProcDir = False: Exit Function Else pa$ = vbNullString End If If FastSymbol(rest$, "?") Or pa$ <> "" Then If IsSelectorInUse Then ProcDir = False SelectorInUse Exit Function End If ProcDir = True If pa$ = "#" Then W$ = "#" pa$ = vbNullString Else p = CBool(IsStrExp(basestack, rest$, W$)) End If If pa$ = vbNullString Then If FastSymbol(rest$, ",") Then p = CBool(IsStrExp(basestack, rest$, pa$)) olamazi DialogSetupLang Lang par = False If W$ <> "" Then If Right$(W$, 1) = "?" Then W$ = Trim$(Left$(W$, Len(W$) - 1)) mcd = W$ '' userfiles = W$ par = True End If Else If IsSupervisor Then W$ = "\" Else W$ = userfiles End If s$ = vbNullString If Form1.Visible Then If W$ = "#" Then If IsSupervisor Then If FolderSelector(basestack, "", "*", pa$, False) Then s$ = ReturnFile End If Else BadCommand ProcDir = False Exit Function End If Else If W$ <> "" Then If Not isdir(W$) Then BadPath: ProcDir = False: Exit Function If Not CanKillFile(W$) Then FilePathNotForUser: ProcDir = False: Exit Function If FolderSelector(basestack, mcd, W$, pa$, par) Then s$ = ReturnFile End If End If ElseIf form5iamloaded Then If W$ <> "" Then If Not isdir(W$) Then BadPath: ProcDir = False: Exit Function If Not CanKillFile(W$) Then FilePathNotForUser: ProcDir = False: Exit Function If FolderSelector(basestack, mcd, W$, pa$, par) Then s$ = ReturnFile End If End If s$ = mylcasefILE(s$) If s$ <> "" Then AddDirSep s$ If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then Select Case Abs(IsLabel(basestack, rest$, what$)) Case 3 ProcDir = True If GetVar(basestack, what$, i) Then CheckVar var(i), s$ Else globalvar what$, s$ End If Case Else MissingStrVar ProcDir = True Exit Function End Select Else mcd = s$ ProcDir = True Exit Function End If End If Else x1 = IsLabelFileName(basestack, rest$, W$) If x1 = 1 Then SwapStrings ss$, W$ Else x1 = IsStrExp(basestack, rest$, ss$, False) End If 'If Left$(ss$, 1) = "." Then x1 = 1 If Left$(ss$, 2) = ".." And mcd = userfiles And Not IsSupervisor Then ProcDir = True: Exit Function ' no error FixPath ss$ If x1 = 0 Then IsSymbol3 rest$, "." If FastSymbol(rest$, "*") Then rest$ = Chr(34) + "*" + Chr(34) + rest$ ElseIf Not FastSymbol(rest$, "!") Then rest$ = Chr(34) + "GSB" + Chr(34) + rest$ End If x1 = 1: ss$ = mcd par = True End If If x1 <> 0 Then AddDirSep ss$ If isdir(ss$) Then If Right(ss$, 1) <> "\" Then ss$ = ss$ + "\" If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then Select Case Abs(IsLabel(basestack, rest$, what$)) Case 3 ProcDir = True If GetVar(basestack, what$, i) Then CheckVar var(i), ss$ Else globalvar what$, ss$ End If Case Else MissingStrVar ProcDir = False Exit Function End Select Else If CanKillFile(ss$) Then mcd = ss$ ProcDir = True If par = True Then 'GOTO FILES If UserPath = "." Then If Lang Then ss$ = Chr(34) + "Dir User: " + Tcase(Originalusername) + Chr(34) Else ss$ = Chr(34) + "Κατάλογος Χρήστη: " + Tcase(Originalusername) + Chr(34) End If Else If IsSupervisor Then If Lang Then ss$ = Chr(34) + "Dir: " + UserPath2 + Chr(34) Else ss$ = Chr(34) + "Κατάλογος: " + UserPath2 + Chr(34) End If Else If Lang Then ss$ = Chr(34) + "Dir User: " + Tcase(Originalusername) + ": " + mylcasefILE(UserPath2) + Chr(34) Else ss$ = Chr(34) + "Κατάλογος Χρήστη: " + Tcase(Originalusername) + ": " + mylcasefILE(UserPath2) + Chr(34) End If End If End If par = MyReport(basestack, ss$, Lang) par = ProcFiles(basestack, rest$, Lang) par = ProcCat(basestack, "", Lang) End If Else mcd = ss$ ProcDir = True If par Then If Lang Then ss$ = "{Read Only Folder: " + mcd + "}" Else ss$ = "{Κατάλογος μόνο για ανάγνωση: " + mcd + "}" End If par = MyReport(basestack, ss$, Lang) par = ProcFiles(basestack, rest$, Lang) par = ProcCat(basestack, "", Lang) Or par End If End If Exit Function End If Else BadPath ProcDir = False Exit Function End If End If End If End Function Function ProcClass(basestack As basetask, rest$, Lang As Long, super As Boolean) As Boolean Dim i As Long, ss$, y1 As Long, what$, W$, ohere$, w2$, subs As Long, snames As Long, s$, pre$ Dim k As Long, M As Long, once As Boolean, Skipfirsttype As Boolean, wt$ Dim skipnew As Boolean If super Then subs = sb2used: snames = subHash.Count: Dim r As Variant Dim SuperGroup As Object End If once = True ohere$ = here$ ProcClass = True y1 = IsLabelSymbolNew(rest$, "ΓΕΝΙΚΗ", "GLOBAL", Lang) Select Case IsLabelA("", rest$, W$) Case 1 If comhash.Find2(W$, M, i) Then If M > 0 Then skipnew = True 'MyEr "bad class name", "μη αποδεκτό όνομα κλάσης" 'ProcClass = False 'Exit Function End If End If againhere: If FastSymbol(rest$, "{") Then ' new code for finding position on error using shift+f1 ss$ = block(rest$) If once Then If UCase(Left$(ss$, 5)) = "TYPE:" Or myUcase(Left$(ss$, 6), True) = "ΤΥΠΟΣ:" Then Skipfirsttype = True End If once = False End If i = Len(rest$) If Skipfirsttype Then wt$ = vbNullString Else If Lang = 1 Then wt$ = "type:" + W$ + vbCrLf Else wt$ = "τύπος:" + W$ + vbCrLf End If End If If here$ = vbNullString Or basestack.LoadOnly Then If Lang = 1 Then s$ = vbCrLf + "if module(" + W$ + "." + W$ + ") then call! " + W$ + "." + W$ + vbCrLf + "=group(" + W$ + ")" rest$ = W$ + "{" + vbCrLf + "group " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ Else s$ = vbCrLf + "Αν Τμήμα(" + W$ + "." + W$ + ") Τότε Κάλεσε! " + W$ + "." + W$ + vbCrLf + "=Ομάδα(" + W$ + ")" rest$ = W$ + "{" + vbCrLf + "ομάδα " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ End If Else If Lang = 1 Then s$ = vbCrLf + "if module(" + W$ + "." + W$ + ") then call! " + W$ + "." + W$ + vbCrLf + "=group(" + W$ + ")" rest$ = W$ + "{'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str$(-i) + "'" + str$(Len(s$) + 2) + vbCrLf + "group " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ Else s$ = vbCrLf + "Αν Τμήμα(" + W$ + "." + W$ + ") Τότε Κάλεσε! " + W$ + "." + W$ + vbCrLf + "=Ομάδα(" + W$ + ")" rest$ = W$ + "{'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str$(-i) + "'" + str$(Len(s$) + 2) + vbCrLf + "ομάδα " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ End If End If If MyFunction(1, basestack, rest$, Lang) Then ProcClass = True sbf(basestack.IndexSub).IamAClass = True y1 = basestack.IndexSub If Not (skipnew Or super) Then comhash.ItemCreator2 W$, 0, 44 End If Skipfirsttype = False ElseIf IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then i = IsLabelA("", rest$, what$) If i < 5 Then If GetSub(what$ + "()", i) Then If sbf(i).Extern > 0 Or Not sbf(i).IamAClass Then W$ = what$ GoTo conterror Else k = InStr(sbf(i).sb, vbCrLf) M = rinstr(sbf(i).sb, vbCrLf + vbCrLf) If M > k And Len(sbf(i).sb) > M Then s$ = Mid$(sbf(i).sb, k + 2, M - k) k = InStr(s$, "{") If k > 0 Then If Lang = 1 Then pre$ = block(Mid$(s$, k + 1)) + vbCrLf + "Public:" + vbCrLf + pre$ Else pre$ = block(Mid$(s$, k + 1)) + vbCrLf + "ΔΗΜΟΣΙΟ:" + vbCrLf + pre$ End If GoTo againhere Else s$ = "" End If Else W$ = what$ GoTo conterror End If End If Else W$ = what$ GoTo conterror End If Else W$ = what$ GoTo conterror End If End If Case 3 w2$ = Left$(W$, Len(W$) - 1) If comhash.Find2(w2$, M, i) Then If M > 0 Then MyEr "bad class name", "μη αποδεκτό όνομα κλάσης" ProcClass = False Exit Function End If End If M = 0 i = 0 againhere1: If FastSymbol(rest$, "{") Then ss$ = block(rest$) If once Then If UCase(Left$(ss$, 5)) = "TYPE:" Or myUcase(Left$(ss$, 6), True) = "ΤΥΠΟΣ:" Then Skipfirsttype = True End If once = False End If i = Len(rest$) If Skipfirsttype Then wt$ = vbNullString Else If Lang = 1 Then wt$ = "type:" + w2$ + vbCrLf Else wt$ = "τύπος:" + w2$ + vbCrLf End If End If If here$ = vbNullString Or basestack.LoadOnly Then If Lang = 1 Then s$ = "if module(" + w2$ + "." + w2$ + ") then call! " + w2$ + "." + w2$ + vbCrLf + "=group$(" + w2$ + ")" rest$ = W$ + "{" + vbCrLf + "group " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ Else s$ = "Αν Τμήμα(" + w2$ + "." + w2$ + ") Τότε Κάλεσε! " + w2$ + "." + w2$ + vbCrLf + "=Ομάδα$(" + w2$ + ")" rest$ = W$ + "{" + vbCrLf + "ομάδα " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ End If Else If Lang = 1 Then s$ = "if module(" + w2$ + "." + w2$ + ") then call! " + w2$ + "." + w2$ + vbCrLf + "=group$(" + w2$ + ")" rest$ = W$ + "{'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str$(-i) + "'" + str$(Len(s$) + 2) + vbCrLf + "group " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ Else s$ = "Αν Τμήμα(" + w2$ + "." + w2$ + ") Τότε Κάλεσε! " + w2$ + "." + w2$ + vbCrLf + "=Ομάδα$(" + w2$ + ")" rest$ = W$ + "{'11001EDIT " + GetModuleName(basestack, ohere$) + "," + str$(-i) + "'" + str$(Len(s$) + 2) + vbCrLf + "ομάδα " + W$ + " {" + pre$ + vbCrLf + wt$ + ss$ + "}" + vbCrLf + s$ + rest$ End If End If If MyFunction(1, basestack, rest$, Lang) Then ProcClass = True sbf(basestack.IndexSub).IamAClass = True comhash.ItemCreator2 w2$, 0, 44 End If Skipfirsttype = False ElseIf IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then i = IsLabelA("", rest$, what$) If i < 5 Then If GetSub(what$ + "()", i) Then If sbf(i).Extern > 0 Or Not sbf(i).IamAClass Then W$ = what$ GoTo conterror Else k = InStr(sbf(i).sb, vbCrLf) M = rinstr(sbf(i).sb, vbCrLf + vbCrLf) If M > k And Len(sbf(i).sb) > M Then s$ = Mid$(sbf(i).sb, k + 2, M - k) k = InStr(s$, "{") If k > 0 Then If Lang = 1 Then pre$ = block(Mid$(s$, k + 1)) + vbCrLf + "Public:" + vbCrLf + pre$ Else pre$ = block(Mid$(s$, k + 1)) + vbCrLf + "ΔΗΜΟΣΙΟ:" + vbCrLf + pre$ End If GoTo againhere1 Else s$ = "" End If Else W$ = what$ GoTo conterror End If End If Else W$ = what$ GoTo conterror End If Else W$ = what$ GoTo conterror End If ' End If Case Else conterror: MyEr "No proper name " + W$ + " for class in class definition", "Αντικανονικό όνομα " + W$ + " για κλάση στον ορισμό κλάσης" ProcClass = False End Select If super Then ' make a variable If Right$(W$, 1) = "$" Then 'Dim s As String If IsStrExp(basestack, W$ + "()", s) Then GoTo conthere End If ElseIf IsExp(basestack, W$ + "()", r) Then conthere: If basestack.lastobj Is Nothing Then ' error Else sb2used = subs subHash.ReduceHash snames, sbf() If UBound(sbf()) / 3 > sb2used And UBound(sbf()) > 499 Then ReDim Preserve sbf(UBound(sbf()) / 2 + 1) As modfun End If If TypeOf basestack.lastobj Is Group Then ' make a pointet to group Set SuperGroup = basestack.lastobj Set basestack.lastobj = Nothing Dim mm As Variant If y1 Then i = globalvar(W$, mm, , True) Set var(i) = New Group Set var(i).SuperClassList = SuperGroup var(i).IamSuperClass = True Else i = globalvar(W$, mm) Set var(i) = New Group Set var(i).SuperClassList = SuperGroup var(i).IamSuperClass = True End If Else ' something wrong End If End If End If End If End Function Function ProcDef(basestack As basetask, rest$, Lang As Long) As Boolean Dim i As Long, what$, y1 As Long, ss$, s$, p, ps$, first Dim notypes As Boolean, notypes0 As Boolean, P1 ProcDef = True again11: y1 = IsLabel(basestack, rest$, what$) If y1 >= 5 Then s$ = BlockParam(rest$) rest$ = Mid$(rest$, Len(s$) + 1) If FastSymbol(rest$, ")", True) Then If FastSymbol(rest$, "=", True) Then ss$ = vbNullString Dim ch As String Do i = 1 ch = aheadstatus(rest$, False, i) If Len(ch) = 0 Then SyntaxError: ProcDef = False: Exit Function ss$ = ss$ + Left$(rest$, i - 1) rest$ = Mid$(rest$, i) If Not FastSymbol(rest$, ",") Then Exit Do ss$ = ss$ + ", " Loop If Trim$(s$) = vbNullString Then ProcDef = MyFunction(0, basestack, Left$(what$, Len(what$) - 1) + " { =" + ss$ + "}", 1) Else ProcDef = MyFunction(0, basestack, Left$(what$, Len(what$) - 1) + " { @read " + s$ + vbCrLf + "=" + ss$ + "}", 1) End If Exit Function End If End If ElseIf y1 > 0 Then first = 0# 'MyEr "Need name for function with parenthesis", "Θέλω όνομα συνάρτησης με παρενθέσεις" If LenB(here$) = 0 Or basestack.IamThread Then MyEr "Def make Variables only in Modules and Functions", "Η Κάνε φτιάχνει μεταβλητές μόνο σε Τμήματα και Συναρτήσεις": ProcDef = False: Exit Function Dim that As Variant, oldthat As Variant, ByPass As Boolean, lcl As Boolean, notdef As Boolean, notdefone As Boolean lcl = IsLabelSymbolNew(what$, "ΤΟΠΙΚΑ", "LOCAL", Lang) If lcl Then y1 = IsLabel(basestack, rest$, what$) If y1 < 5 Then i = 0 If y1 = 3 Then that = vbNullString GoTo jumpnow ElseIf IsLabelSymbolNew(what$, "ΑΡΙΘΜΟ", "DECIMAL", Lang, i) Then that = CDec(0) ElseIf IsLabelSymbolNew(what$, "ΔΙΠΛΟ", "DOUBLE", Lang, i) Then that = 0# ElseIf IsLabelSymbolNew(what$, "ΑΠΛΟ", "SINGLE", Lang, i) Then that = 0! ElseIf IsLabelSymbolNew(what$, "ΛΟΓΙΚΟ", "BOOLEAN", Lang, i) Then that = False ElseIf IsLabelSymbolNew(what$, "ΜΑΚΡΥ", "LONG", Lang, i) Then If IsLabelSymbolNew(rest$, "ΜΑΚΡΥ", "LONG", Lang) Then that = cInt64(0) Else that = 0& End If ElseIf IsLabelSymbolNew(what$, "ΑΚΕΡΑΙΟ", "INTEGER", Lang, i) Then that = 0 ElseIf IsLabelSymbolNew(what$, "ΛΟΓΙΣΤΙΚΟ", "CURRENCY", Lang, i) Then that = 0@ ElseIf IsLabelSymbolNew(what$, "ΓΡΑΜΜΑ", "STRING", Lang, i) Then that = vbNullString ElseIf IsLabelSymbolNew(what$, "ΑΤΥΠΟ", "VARIANT", Lang, i) Then notypes = True that = Empty ElseIf IsLabelSymbolNew(what$, "ΨΗΦΙΟ", "BYTE", Lang, i) Then that = CByte(0) ElseIf IsLabelSymbolNew(what$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", Lang, i) Then that = CDate(0) ElseIf IsLabelSymbolNew(what$, "ΜΙΓΑΔΙΚΟΣ", "COMPLEX", Lang, i) Then that = nMath2.cxZero ElseIf IsLabelSymbolNew(what$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang, i) Then Set that = New BigInteger Else ByPass = True that = 0# GoTo jumpnow End If notypes0 = Not notypes If MyIsObject(that) Then Set first = that Else first = that End If ByPass = True notdefone = True notdef = True y1 = IsLabel(basestack, rest$, what$) jumpnow: If MyIsObject(that) Then Set oldthat = that Else oldthat = that End If Do While y1 < 5 If ByPass Then notdef = True If IsLabelSymbolNew(rest$, "ΩΣ", "AS", Lang) Then i = 0 notypes = False If IsLabelSymbolNew(rest$, "ΑΡΙΘΜΟΣ", "DECIMAL", Lang, i) Then that = CDec(0) ElseIf IsLabelSymbolNew(rest$, "ΔΙΠΛΟΣ", "DOUBLE", Lang, i) Then that = 0# ElseIf IsLabelSymbolNew(rest$, "ΑΠΛΟΣ", "SINGLE", Lang, i) Then that = 0! ElseIf IsLabelSymbolNew(rest$, "ΛΟΓΙΚΟΣ", "BOOLEAN", Lang, i) Then that = False ElseIf IsLabelSymbolNew(rest$, "ΜΑΚΡΥΣ", "LONG", Lang, i) Then If IsLabelSymbolNew(rest$, "ΜΑΚΡΥΣ", "LONG", Lang, 0) Then that = cInt64(0) Else that = 0& End If ElseIf IsLabelSymbolNew(rest$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang, i) Then that = 0 ElseIf IsLabelSymbolNew(rest$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang, i) Then that = 0@ ElseIf IsLabelSymbolNew(rest$, "ΓΡΑΜΜΑ", "STRING", Lang, i) Then that = vbNullString ElseIf IsLabelSymbolNew(rest$, "ΑΤΥΠΟΣ", "VARIANT", Lang, i) Then notypes = True that = CVar(0) ElseIf IsLabelSymbolNew(rest$, "ΨΗΦΙΟ", "BYTE", Lang, i) Then that = CByte(0) ElseIf IsLabelSymbolNew(rest$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", Lang, i) Then that = CDate(0) ElseIf IsLabelSymbolNew(rest$, "ΜΙΓΑΔΙΚΟΣ", "COMPLEX", Lang, i) Then that = nMath2.cxZero ElseIf IsLabelSymbolNew(rest$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang, i) Then Set that = New BigInteger ElseIf Not IsEnumAs(basestack, rest$, that) Then ExpectedEnumType Exit Function End If ElseIf y1 = 3 Then that = vbNullString Else notdef = notdefone End If ElseIf y1 <> 3 Then If VarType(that) = vbEmpty Then that = 0# End If End If If Not lcl Then If GetlocalVar(what$, i) Then VariableExist what$: ProcDef = False: Exit Function i = AllocVar() If y1 = 3 Then that = vbNullString If strid.Find(what$, (i), (i)) Then strid.ItemCreator what$, -2 End If ElseIf y1 = 1 Then If numid.Find(what$, (i), (i)) Then numid.ItemCreator what$, -2 End If End If varhash.ItemCreator here$ + "." + what$, i, deftype:=Not notypes If MyIsObject(that) Then Set p = that Else p = that End If If Not MyIsNumeric(that) Then If MyIsObject(first) Then Set that = first ElseIf Not MyIsObject(that) Then that = first ElseIf FastSymbol(rest$, "=") Then GoTo cont11112 End If End If If FastSymbol(rest$, "=") Then If notypes Or VarType(first) = vbString Then If VarType(that) = vbDate Then GoTo cont11112 If ISSTRINGA(rest$, ps$) Then p = vbNullString SwapString2Variant ps$, p GoTo cont1023 End If End If cont11112: If MyIsNumeric(p) Then If Not IsNumberD2(rest$, p, notdef And Not notypes, True) Then If VarType(p) = vbDate Then If ISSTRINGA(rest$, ps$) Then p = CDate(ps$) Else ER0001: ProcDef = False missNumber Exit Function End If ElseIf TypeOf p Is Complex Then If FastSymbol(rest$, "(") Then If Not IsNumberD2(rest$, P1, notdef And Not notypes, True) Then GoTo ER0001 End If p.r = CDbl(P1) If Not FastSymbol(rest$, ",") Then GoTo ER0001 If Not IsNumberD2(rest$, P1, notdef And Not notypes, True) Then GoTo ER0001 End If p.i = CDbl(P1) rest$ = NLtrim(rest$) If Not UCase$(Left$(rest$, 2)) = "I)" Then GoTo ER0001 Mid$(rest$, 1, 2) = " " Else GoTo ER0001 End If ElseIf ByPass And Not notdef Then If ISSTRINGA(rest$, ps$) Then p = vbNullString SwapString2Variant ps$, p Else ProcDef = False missNumber Exit Function End If Else ProcDef = False missNumber Exit Function End If End If On Error Resume Next If MyIsObject(oldthat) Then Set that = oldthat Else that = 0 that = oldthat End If If Err.Number > 0 Then If Err.Number = 6 Then OverflowValue CInt(VarType(that)) ProcDef = False Exit Function End If End If cont1023: Else If Typename(p) = "BigInteger" Then If ISSTRINGA(rest$, ps$) Then Set p = Module13.CreateBigInteger(ps$) ElseIf Not IsNumberD2(rest$, p, notdef And Not notypes, True) Then ProcDef = False SyntaxError Exit Function Else If VarType(p) = vbString Then Set p = Module13.CreateBigInteger(CStr(p)) Else Set p = Module13.CreateBigInteger(format$(Int(p), "0")) End If End If Else If Not ISSTRINGA(rest$, ps$) Then If VarType(first) = vbString Then MissString Else missNumber End If ProcDef = False Exit Function End If p = "" SwapString2Variant ps$, p End If End If End If If MyIsObject(p) Then Set var(i) = p p = vbEmpty If MyIsObject(oldthat) Then Set that = oldthat Else that = 0 that = oldthat End If ElseIf y1 = 4 Then var(i) = MyRound(p) Else var(i) = p End If jump11: If Not FastSymbol(rest$, ",") Then Exit Do DropCommentOrLine rest$ y1 = IsLabel(basestack, rest$, what$) If MyIsObject(that) Then Set that = Nothing End If If MyIsObject(first) Then Set that = first Else that = first End If Loop End If If y1 > 4 Then MyEr "Not arrays for def", "Όχι πίνακες με την Κάνε": ProcDef = False: Exit Function Else SyntaxError ProcDef = False Exit Function End If If ProcDef Then If Len(rest$) > 0 Then If Not MaybeIsSymbol(rest$, b1234) Then If Trim(rest$) <> "" Then PlaceAcommaBefore ProcDef = False End If End If End If End If End Function Function CheckTwoVal(a, b, c) CheckTwoVal = a = b Or a = c End Function Function MyLink(basestack As basetask, rest$, Lang As Long) As Boolean MyLink = True Dim myobject As mStiva, dummy$, s$, ss$, x1 As Long, it As Long, rest1$ Set myobject = basestack.soros Set basestack.Sorosref = NewmStiva s$ = vbNullString Do If IsLabelSymbolNew(rest$, "ΙΣΧΝΗ", "WEAK", Lang) Then If IsStrExp(basestack, rest$, ss$) Then If GetSub(ss$, x1) Then If sbf(x1).Extern > 0 Then basestack.soros.DataStr "{CALL EXTERN" + str$(sbf(x1).Extern) + "'" + ChrW(&H1FFD) + "}" + sbf(x1).sbgroup: x1 = 1: GoTo contlink2 Else basestack.soros.DataStr "{" + sbf(x1).sb + "}" + sbf(x1).sbgroup: x1 = 1: GoTo contlink2 End If Else basestack.soros.DataStr ss$: x1 = 1: GoTo contlink2 End If End If MissStringExpr MyLink = False Exit Function ElseIf IsLabelSymbolNew(rest$, "ΓΟΝΙΚΟ", "PARENT", Lang) Then If Len(basestack.UseGroupname) > 0 Then ss$ = Mid$(basestack.UseGroupname, 1, Len(basestack.UseGroupname) - 1) If GetVar(basestack, ss$, x1) Then ss$ = Left$(ss$, Len(ss$) - Len(var(x1).GroupName)) Dim sss$, sss1$, bck$ bck$ = CopyUntilEndOfLine(rest$) sss$ = NLtrim(bck$) Do If sss$ = vbNullString Then x1 = 0: Exit Do sss1$ = "&" + ss$ + "." + sss$ sss$ = "&" + ss$ + "." + ChrW(&HFFBF) + sss$ basestack.NoError = True s$ = vbNullString If IsStr1(basestack, sss1$, s$) Then If GetSub(s$, x1) Then basestack.soros.DataStr "{" + sbf(x1).sb + "}": x1 = 1 Else basestack.soros.DataStr s$: x1 = 1 End If If Len(bck$) > Len(sss1$) Then Mid$(rest$, 1, Len(bck$) - Len(sss1$)) = space(Len(bck$) - Len(sss1$)) Else x1 = 0: Exit Do End If SwapStrings sss1$, sss$ ElseIf IsStr1(basestack, sss$, s$) Then If GetSub(s$, x1) Then basestack.soros.DataStr "{" + sbf(x1).sb + "}": x1 = 1 Else basestack.soros.DataStr s$: x1 = 1 End If Else basestack.NoError = 0 'rest$ = bck$ + rest$ MyEr "No such variable", "Δεν υπάρχει τέτοια μεταβλητή" MyLink = False Exit Function End If Loop Until Not FastSymbol(sss$, ",") If Len(bck$) > Len(sss$) Then Mid$(rest$, 1, Len(bck$) - Len(sss$)) = space(Len(bck$) - Len(sss$)) Else x1 = 0 End If If x1 = 1 Then GoTo contlink2 basestack.NoError = 0 MyEr "Parent group problem", "Πρόβλημα γονικής ομάδας" Exit Function End If Else MyEr "No parent found", "Δεν βρήκα γονικό" MyLink = False Exit Function End If End If If Len(rest$) < 129 Then it = IsLabelDot(dummy$, rest$, ss$) Else rest1$ = Left$(rest$, 128) it = IsLabelDot(dummy$, rest1$, ss$) If Len(rest1$) = 0 Then it = IsLabelDot(dummy$, rest$, ss$) Else rest$ = Mid$(rest$, 129 - Len(rest1$)) End If End If If it = 2 Then If Len(rest$) < 129 Then it = IsLabelDot(dummy$, rest$, ss$) Else rest1$ = Left$(rest$, 128) it = IsLabelDot(dummy$, rest1$, ss$) If Len(rest1$) = 0 Then it = IsLabelDot(dummy$, rest$, ss$) Else rest$ = Mid$(rest$, 129 - Len(rest1$)) End If End If End If If it = 0 Then IsStr1 basestack, rest$, ss$ If Len(ss$) > 0 Then If Left$(ss$, 1) = "&" Then ss$ = Mid$(ss$, 2) If it < 0 Then IsLabel basestack, (ss$), ss$ If it > 4 Then ss$ = ss$ + ")" If Not FastSymbol(rest$, ")") Then it = 0 End If ' x1 = 1 ' aheadstatus rest$, False, x1 basestack.NoError = True ss$ = "&" + ss$ bck$ = ss$ If IsStr1(basestack, ss$, s$) Then basestack.soros.DataStr s$ GoTo contLoop Else If it > 4 Then it = rinstr(bck$, ".") bck$ = Left$(bck$, it) + ChrW(&HFFBF) + Mid$(bck$, it + 1) If IsStr1(basestack, bck$, s$) Then If basestack.UseGroupname = vbNullString Then MyLink = False MyEr "Can't make reference, it's hidden", "Δεν μπορώ να φτιάξω αναφορά, είναι κρυμμένο" Exit Function End If basestack.soros.DataStr s$ GoTo contLoop End If Else it = rinstr(bck$, ".") ss$ = Left$(bck$, it) + ChrW(&HFFBF) + Mid$(bck$, it + 1) End If If IsStr1(basestack, ss$, s$) Then If basestack.UseGroupname = vbNullString Then MyLink = False MyEr "Can't make reference, it's hidden", "Δεν μπορώ να φτιάξω αναφορά, είναι κρυμμένο" Exit Function End If End If End If basestack.NoError = False basestack.soros.DataStr s$ End If contLoop: Loop While FastSymbol(rest$, ",") contlink2: basestack.NoError = False If basestack.soros.Total = 0 Then MyEr "Nothing to link", "Τίποτα για να ενώσω" ElseIf IsLabelSymbolNew(rest$, "ΤΟΠΙΚΑ", "LOCAL", Lang) Then If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then MyLink = MyRead8(0, basestack, rest$, Lang) ElseIf IsLabelSymbolNew(rest$, "ΣΤΗ", "TO", Lang) Then MyLink = MyRead8(0, basestack, rest$, Lang) Else MissClause "TO", "ΣΤΟ" End If Else If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then MyLink = MyRead8(2, basestack, rest$, Lang) ElseIf IsLabelSymbolNew(rest$, "ΣΤΗ", "TO", Lang) Then MyLink = MyRead8(2, basestack, rest$, Lang) Else MissClause "TO", "ΣΤΗ" End If End If exitlink: Set basestack.Sorosref = myobject Set myobject = Nothing End Function Function MyDim(basestack As basetask, rest$, Lang As Long, Optional ByVal dNew As Boolean, Optional ByVal fromthere As Long = 0) As Boolean Dim par As Boolean, pppp As mArray, it As Long, k As Long, usehandler As mHandler Dim p As Variant, W$, s$, X As Variant, i As Long, f As Long, Reverse As Boolean, ss$, uselocalbase As Boolean, usethisbase As Long Dim oldbase As Long, common As Boolean, rest1$, zeroitem As Object, tstArray As iBoxArray MyDim = True Reverse = IsLabelSymbolNew(rest$, "OLE", "OLE", Lang) If dNew Then par = True Else par = IsLabelSymbolNew(rest$, "ΝΕΟ", "NEW", Lang) End If common = IsLabelSymbolNew(rest$, "ΚΟΙΝΟΣ", "COMMON", Lang) If Not common Then common = IsLabelSymbolNew(rest$, "ΚΟΙΝΟΙ", "COMMON", Lang) uselocalbase = IsLabelSymbolNew(rest$, "ΒΑΣΗ", "BASE", Lang) If uselocalbase Then If FastSymbol(rest$, "1") Then oldbase = ArrBase ArrBase = 1 ElseIf FastSymbol(rest$, "0") Then oldbase = ArrBase ArrBase = 0 End If If Not par Then If IsLabelSymbolNew(rest$, "ΣΤΟ", "TO", Lang) Then Do usethisbase = ArrBase If Len(rest$) < 129 Then it = Abs(IsLabelDIM(basestack, rest$, W$)) Else rest1$ = Left$(rest$, 128) it = Abs(IsLabelDIM(basestack, rest1$, W$)) If Len(rest1$) = 0 Then it = Abs(IsLabelDIM(basestack, rest$, W$)) Else rest$ = Mid$(rest$, 129 - Len(rest1$)) End If End If If it = 0 Then MissArrayName: Exit Function If basestack.priveflag Then W$ = ChrW(&HFFBF) + W$ End If If Not IsSymbol(rest$, ")") Then GoTo ex1 If neoGetArray(basestack, W$, tstArray, here$ <> "") Then If Not tstArray.arr Then Set pppp = Nothing: GoTo ex1 If TypeOf tstArray Is mArray Then Set pppp = tstArray If pppp.IhaveClass And pppp.GroupRef Is Nothing Then Set pppp = Nothing: GoTo ex1 pppp.SerialItem 0, -usethisbase, 12 pppp.common = common End If End If Loop Until Not FastSymbol(rest$, ",") GoTo ex1 End If End If If Not FastSymbol(rest$, ",") Then MyDim = True: GoTo ex1 End If ' for security usethisbase = ArrBase Do ArrBase = usethisbase If Len(rest$) < 129 Then it = Abs(IsLabelDIM(basestack, rest$, W$)) Else rest1$ = Left$(rest$, 128) it = Abs(IsLabelDIM(basestack, rest1$, W$)) If Len(rest1$) = 0 Then it = Abs(IsLabelDIM(basestack, rest$, W$)) Else rest$ = Mid$(rest$, 129 - Len(rest1$)) End If End If If it = 0 Then MissArrayName: Exit Function If basestack.priveflag Then W$ = ChrW(&HFFBF) + W$ ElseIf Len(basestack.UseGroupname) > 0 Then If it = 6 Then If strfunid.Find(W$, i) Then If i > 0 Then strfunid.ItemCreator W$, -i End If ElseIf it = 5 Then If funid.Find(W$, i) Then If i > 0 Then funid.ItemCreator W$, -i End If End If Else End If k = MyTrimL(rest$) If Mid$(rest$, k, 1) = ")" Then Mid$(rest$, k, 1) = ChrW(8) If Len(basestack.UseGroupname) > 0 Then If neoGetArray(basestack, W$, tstArray, True, , , , , basestack.tpointer) Then GoTo cont11134 Else GoTo cont33341 End If ElseIf neoGetArray(basestack, W$, tstArray, True, , Not Len(here$) = 0, , , fromthere) And Not par Then ' cont11134: If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If If pppp.IhaveClass And pppp.GroupRef Is Nothing Then Set pppp = Nothing: GoTo ex1 pppp.common = common ' If reverse Then pppp.RevOrder = True If uselocalbase Then pppp.myarrbase = -ArrBase Select Case it Case 5, 6, 7 If Len(here$) = 0 Then GlobalArrResize pppp, basestack, basestack.GroupName + W$, rest$, i Else GlobalArrResize pppp, basestack, W$, rest$, i End If p = i If i < 0 Then it = 0 Case Else it = 0 End Select Else cont33341: Select Case it Case 5, 6, 7 f = -1 If Len(here$) = 0 Then GlobalArr basestack, basestack.GroupName + W$, rest$, i, f, , Reverse Else If Len(basestack.GroupName) = 0 Then If Len(here$) > 0 Then If subHash.Find(here$ + "." + W$ + ")", i) Then If i = -1 Then MyEr "bad nam for array - used for static function", "κακό όνομα για πίνακα χρησιμοποιείται για στατική συνάρτηση" Exit Function End If End If End If End If GlobalArr basestack, W$, rest$, i, f, , Reverse End If var(f).common = common p = i If i < 0 Then it = 0 Case Else it = 0 End Select End If Select Case it Case 5 X = 0 If FastSymbol(rest$, "=") Then If IsExp(basestack, rest$, X) Then Set zeroitem = basestack.lastobj enter1234: If neoGetArray(basestack, W$, tstArray) Then If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If pppp.common = common If Not basestack.lastobj Is Nothing Then If IsGroup(basestack.lastobj) Then If basestack.lastobj.IamSuperClass Then pppp.CopyGroupObj basestack.lastobj.SuperClassList, pppp.GroupRef Set pppp.GroupRef = basestack.lastobj.SuperClassList Set pppp.GroupRef.SuperClassList = basestack.lastobj.SuperClassList Else Set pppp.GroupRef = basestack.lastobj End If pppp.IhaveClass = True Set basestack.lastobj = Nothing pppp.SerialItem 0, 0, 3 ElseIf IsObjLambda(basestack.lastobj) Then pppp.FillLambda basestack ElseIf IsObjmHandler(basestack.lastobj) Then Set usehandler = basestack.lastobj If usehandler.t1 = 4 Then pppp.Fillobj basestack Else Set basestack.lastobj = Nothing Set usehandler = Nothing Else Set basestack.lastobj = Nothing If Not zeroitem Is Nothing Then GoTo cont95959 End If Else If Not zeroitem Is Nothing Then cont95959: If pppp.MyTypeToBe <> 0 And pppp.MyTypeToBe <> 12 Then If pppp.MyTypeToBe = 201 Or pppp.MyTypeToBe = 9 Then Set X = zeroitem Set zeroitem = Nothing pppp.SerialItem X, 0, 3 Else w1112: WrongType MyDim = False Exit Function End If Else Set basestack.lastobj = zeroitem Set zeroitem = Nothing pppp.Fillobj basestack Set basestack.lastobj = Nothing End If Else If pppp.MyTypeToBe = 201 Then Set X = Module13.CreateBigInteger(format(Int(X), "0")) pppp.SerialItem X, 0, 3 ElseIf pppp.MyTypeToBe = 12 Then If Typename(pppp.item(0)) = "BigInteger" Then Set basestack.lastobj = Module13.CreateBigInteger(format(Int(X), "0")) pppp.Fillobj basestack Set basestack.lastobj = Nothing Else pppp.SerialItem X, 0, 3 End If Else pppp.SerialItem X, 0, 3 End If End If End If Else it = 0 End If Else If IsStrExp(basestack, rest$, s$, False) Then X = vbNullString SwapString2Variant s$, X GoTo enter1234 Else MissNumExpr MyDim = False GoTo ex1 End If End If ElseIf FastSymbol(rest$, "<<", , 2) Then f = 1 s$ = aheadstatus(rest$, True, f) If f > 0 Then s$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) If neoGetArray(basestack, W$, tstArray) Then If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If pppp.common = common For i = 0 To pppp.UpperMonoLimit If IsExp(basestack, (s$), X) Then If Not basestack.lastobj Is Nothing Then If IsObjGroup(basestack.lastobj) Then Set pppp.GroupRef = Nothing pppp.IhaveClass = False If basestack.lastobj.IamSuperClass Then Dim myobj As Object pppp.CopyGroupObj basestack.lastobj.SuperClassList, myobj Set myobj.SuperClassList = basestack.lastobj.SuperClassList Set pppp.item(i) = myobj Set myobj = Nothing Else Set pppp.item(i) = basestack.lastobj pppp.item(i).ToDelete = False End If ElseIf IsObjmHandler(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsObjmStiva(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsobjArray(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj Else Set basestack.lastobj = Nothing badsupport MyDim = False GoTo ex1 Exit For End If Else pppp.item(i) = X End If Else Set basestack.lastobj = Nothing MyDim = False MissNumExpr GoTo ex1 Exit For End If Next i Set basestack.lastobj = Nothing Else it = 0 End If End If End If Case 7 X = 0 If FastSymbol(rest$, "=") Then If IsExp(basestack, rest$, X) Then If neoGetArray(basestack, W$, tstArray) Then ''basestack.GroupName & If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If pppp.common = common If IsObjLambda(basestack.lastobj) Then pppp.FillLambda basestack Else pppp.SerialItem Int(X), 0, 3 End If End If Else MissNumExpr MyDim = False GoTo ex1 End If ElseIf FastSymbol(rest$, "<<", , 2) Then f = 1 s$ = aheadstatus(rest$, True, f) If f > 0 Then s$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) If neoGetArray(basestack, W$, tstArray) Then If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If pppp.common = common For i = 0 To pppp.UpperMonoLimit If IsExp(basestack, (s$), X) Then If IsObjLambda(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf basestack.lastobj Is Nothing Then pppp.item(i) = Int(X) Else Set basestack.lastobj = Nothing MyEr "Only Lambda objects here", "Μόνο λάμδα αντικείμενα εδώ" MyDim = False GoTo ex1 Exit For End If Else Set basestack.lastobj = Nothing MyDim = False MissNumExpr GoTo ex1 End If Next i Set basestack.lastobj = Nothing Else MissNumExpr GoTo ex1 it = 0 End If End If End If Case 6 s$ = vbNullString If FastSymbol(rest$, "=") Then If IsStrExp(basestack, rest$, s$) Then If neoGetArray(basestack, W$, tstArray) Then '' basestack.GroupName & If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If pppp.common = common If IsObjLambda(basestack.lastobj) Then pppp.FillLambda basestack ElseIf IsObjGroup(basestack.lastobj) Then If basestack.lastobj.IamSuperClass Then pppp.CopyGroupObj basestack.lastobj.SuperClassList, pppp.GroupRef Set pppp.GroupRef = basestack.lastobj.SuperClassList Set pppp.GroupRef.SuperClassList = basestack.lastobj.SuperClassList Else Set pppp.GroupRef = basestack.lastobj End If pppp.IhaveClass = True Set basestack.lastobj = Nothing pppp.SerialItem 0, 0, 3 Else pppp.SerialItem s$, 0, 3 End If End If Else MissStringExpr MyDim = False GoTo ex1 End If ElseIf FastSymbol(rest$, "<<", , 2) Then f = 1 s$ = aheadstatus(rest$, True, f) If f > 0 Then s$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) If neoGetArray(basestack, W$, tstArray) Then If Not GetPPPP(tstArray, pppp) Then conflictname Set tstArray = Nothing GoTo ex1 End If pppp.common = common For i = 0 To pppp.UpperMonoLimit If IsStrExp(basestack, (s$), ss$) Then If IsObjGroup(basestack.lastobj) Then Set pppp.GroupRef = Nothing pppp.IhaveClass = False Set pppp.item(i) = basestack.lastobj ElseIf IsObjLambda(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsObjmHandler(basestack.lastobj) Then ' tuple also Set pppp.item(i) = basestack.lastobj ElseIf IsObjmStiva(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsobjArray(basestack.lastobj) Then ' marray and tuple Set pppp.item(i) = basestack.lastobj ElseIf basestack.lastobj Is Nothing Then pppp.item(i) = ss$ Else Set basestack.lastobj = Nothing badsupport MyDim = False GoTo ex1 Exit For End If Else Set basestack.lastobj = Nothing MyDim = False MissStringExpr GoTo ex1 Exit For End If Next i Set basestack.lastobj = Nothing Else it = 0 MyDim = False MissStringExpr GoTo ex1 End If End If End If End Select If it = 0 Then BadDim rest$ = basestack.GroupName + W$ + rest$ MyDim = False GoTo ex1 End If If Not pppp Is Nothing Then If basestack.finalFlag Then pppp.Final = True ElseIf f > 0 Then var(f).Final = basestack.finalFlag End If Loop Until Not FastSymbol(rest$, ",") ex1: If uselocalbase Then ArrBase = oldbase End If Set basestack.lastobj = Nothing Set basestack.lastpointer = Nothing End Function Function MySeek(basestack As basetask, rest$) As Boolean Dim X As Variant, t As Ftypes MySeek = True IsSymbol3 rest$, "#" ' OPTIONAL ...SEEK #I, 10020 ΒΥΤΕ If IsExp(basestack, rest$, X, , True) Then X = Int(X) t = Fkind(X) If t = FnoUse Then MySeek = False MyEr "not valid file number", "λάθος αριθμός αρχείου" Exit Function End If If t = Frandom Then MySeek = False MyEr "not valid file type", "λάθος ΤΥΠΟΣ αρχείου" Exit Function End If If Not FastSymbol(rest$, ",") Then MissNumExpr Else Dim p If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then FileSeek(X) = Int(p) Else MissNumExpr End If End If End If End Function Function MyClose(basestack As basetask, rest$, Lang As Long) As Boolean Dim par As Boolean, p As Variant, ss$ MyClose = True If Not IsLabelSymbolNew(rest$, "ΒΑΣΗ", "BASE", Lang) Then par = False Do IsSymbol3 rest$, "#" ' optional If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then If p < 0 Then Else p = Int(p) If Fkind(p) <> FnoUse Then CloseHandler p End If End If Else If par Then MyClose = False Else closeAll End If Exit Do End If par = True Loop Until Not FastSymbol(rest$, ",") Else Do If IsStrExp(basestack, rest$, ss$) Then On Error Resume Next If (ss$ Like "*.mdb") Or (ss$ Like "*:\*") Then ss$ = mylcasefILE(ss$) End If RemoveOneConn ss$ End If Loop Until Not FastSymbol(rest$, ",") End If End Function Private Function MyMod(r1, po) As Variant MyMod = r1 - Fix(r1 / po) * po End Function Function Appfields(basestack As basetask, rest$) As Boolean Dim s$, p As Variant If IsExp(basestack, rest$, p) Then Appfields = AddInventory(basestack, rest$) ElseIf IsStrExp(basestack, rest$, s$) Then Appfields = True append_table basestack, s$, rest$, False Else SyntaxError Appfields = False End If Set basestack.lastobj = Nothing Exit Function End Function Function rValue(bstack As basetask, ob As Object) As Variant If ob Is Nothing Or TypeOf ob Is Group Then Set bstack.lastobj = ob rValue = 0 ElseIf TypeOf ob Is PropReference Then Dim aProp As PropReference Set bstack.lastobj = Nothing Set aProp = ob rValue = aProp.Value If aProp.LastHasObject Then Set bstack.lastobj = aProp.lastobj aProp.clearlastobject If Not bstack.lastobj Is Nothing Then rValue = 0 End If ElseIf TypeOf ob Is mEvent Then CopyEvent ob, bstack rValue = 0 ElseIf TypeOf ob Is lambda Then CopyLambda ob, bstack rValue = 0 ElseIf TypeOf ob Is mHandler Then CopyHandler ob, bstack rValue = 0 ElseIf TypeOf ob Is iBoxArray Then Set bstack.lastobj = CopyArray(ob) rValue = 0 ElseIf TypeOf ob Is Document Then rValue = ob.textDoc Set bstack.lastobj = Nothing Else Set bstack.lastobj = ob rValue = 0 End If End Function Sub refreshGui() Dim X As Form For Each X In Forms If Typename$(X) = "GuiM2000" Then If X.enabled Then X.Refresh End If Next Set X = Nothing End Sub Sub MouseShow(Yes As Boolean) Dim k As Long, b1 As Boolean If Yes Then k = ShowCursor(True) k1 = k = -1 If k < 0 Then k = ShowCursor(True) Do While k < 0 If k = -1 And k1 Then Exit Sub ' no mouse found k = ShowCursor(True) Loop End If Else k = ShowCursor(False) Do While k >= 0 k = ShowCursor(False) Loop End If End Sub Function GetAnewEvent() As Variant Dim aa As New ComShinkEvent, bb As New mHandler 'Set aa.Callback = Form1 Set bb.objref = aa bb.t1 = 3 Set GetAnewEvent = bb End Function Public Function CallEventFromCOM1(evCom As ComShinkEvent, aString$, what$, NumVar As Long, vrs(), ref() As Long, exclude As Boolean, ItemIndex As Long) As Boolean Dim tr As Boolean, extr As Boolean, olescok As Boolean Dim f$, F1$, klm As Long, ohelp As Object CallEventFromCOM1 = True F1$ = evCom.modulename$ f$ = UCase(F1$ + "_" + aString$ + "()") ' No greek If Not subHash.Find(f$, klm) Then exclude = True: Exit Function extr = extreme extreme = True tr = trace trace = False Dim n$, bb As mStiva, oldbstack As mStiva, nowtotal As Long Dim bstack As basetask Set bstack = New basetask Set bstack.Owner = Form1.DIS bstack.IamAnEvent = True Dim i As Long i = evCom.VarIndex If Not evCom.StaticCollection Is Nothing Then If evCom.StaticCollection.ExistKey(aString$) Then Set bstack.StaticCollection = evCom.StaticCollection.ValueObj End If End If Dim j As Long, k As Long, s1$, S2$ Dim ohere$ ohere$ = here$ here$ = vbNullString If evCom.Attached Then Set oldbstack = bstack.soros Set bb = NewmStiva Set bstack.Sorosref = bb PushStage bstack, False If ItemIndex > -1 Then bb.DataVal CVar(ItemIndex) End If For k = 1 To NumVar If ref(k) Then Select Case VarType(vrs(k)) Case vbString globalvarGroup "EV" & (i + k) & "$", vrs(k) bb.DataStr "EV" & (i + k) & "$" Case Is >= vbArray globalvarGroup "EV" & (i + k) & "(", RetM2000array(vrs(k)) bb.DataStr "EV" & (i + k) Case Else globalvarGroup "EV" & (i + k), vrs(k) bb.DataStr "EV" & (i + k) End Select Else Select Case VarType(vrs(k)) Case vbString bb.DataStr CStr(vrs(k)) Case Is >= vbArray Set ohelp = RetM2000array(vrs(k)) bb.DataObj ohelp Set ohelp = Nothing Case Else If MyIsObject(vrs(k)) Then Set ohelp = vrs(k) bb.DataObj ohelp Set ohelp = Nothing Else bb.DataVal vrs(k) End If End Select End If Next k bb.DataStr (what$) bb.DataObj MakeitObjectGeneric(evCom.VarIndex) here$ = evCom.modulenameonly If FastCallModule(bstack, klm) <> 1 Then GoTo conthere End If here$ = vbNullString If NumVar > 0 Then For k = LBound(vrs()) To UBound(vrs()) - 1 + LBound(vrs()) If ref(k) Then Select Case VarType(vrs(k)) Case vbString varhash.Find2 "EV" & (i + k) & "$", j, True vrs(k) = var(j) Case Is >= vbArray varhash.Find2 "EV" & (i + k) & "(", j, True RetComArray var(j), vrs(k) Case Else varhash.Find2 "EV" & (i + k), j, True vrs(k) = var(j) End Select End If Next k End If conthere: PopStage bstack Set bstack.Sorosref = oldbstack Set oldbstack = Nothing bb.Recycle Set bb = Nothing End If If Not bstack.StaticCollection Is Nothing Then If evCom.StaticCollection Is Nothing Then Set evCom.StaticCollection = New FastCollection If Not evCom.StaticCollection.ExistKey(aString$) Then evCom.StaticCollection.AddKey aString$, bstack.StaticCollection End If End If here$ = ohere$ extreme = extr trace = tr End Function Sub RetComArray(varFrom As Variant, varTo As Variant) Dim ar As mArray, v() Set ar = varFrom ar.CopyBackSerialize v() varTo = v() End Sub Function FastCallModule(bstack As basetask, mod_id As Long) As Long Dim i As Long, frm$ 'If checkbreakEsc(bstack) Then FastCallModule = 0: Exit Function frm$ = Mid$(sbf(mod_id).sb, 1) FastCallModule = Execute(bstack, frm$, False, False) End Function Function MakeATypeLib(v As Variant, Optional usetypelib As Boolean = False) As FastCollection Dim obj As Object, vv As FastCollection ' create the requested object Set obj = v If TypeOf obj Is ExtControl Then Set obj = obj.Value If usetypelib Then ' find typelib and load it Set MakeATypeLib = New FastCollection Else If Not GetAllMembers(vv, obj) Then Err.Raise &H80004002 Set MakeATypeLib = vv Set vv = Nothing End If Set obj = Nothing End Function Function FindPrevOriginal(bstack As basetask) As Long Dim curparent As basetask, cur As basetask 'If bstack.IamThread Then 'FindPrevOriginal = bstack.Parent.OriginalCode 'Exit Function 'End If Set cur = bstack Set curparent = cur.Parent If curparent Is Nothing Then FindPrevOriginal = cur.OriginalCode: Exit Function If curparent.OriginalCode = 0 Then FindPrevOriginal = cur.OriginalCode: Exit Function Do While curparent.OriginalCode = cur.OriginalCode And curparent.OriginalCode <> 0 Set cur = curparent Set curparent = cur.Parent If curparent Is Nothing Then FindPrevOriginal = cur.OriginalCode: Exit Function Loop FindPrevOriginal = curparent.OriginalCode End Function Function iter(bstack As basetask, rest$, Lang As Long) As Boolean ' each( array or inventory, start: 1 by default, or -1 for end of list, end: -1 to end (optional), or we can set it) Dim pppp As iBoxArray, w1 As Long, s$, num As Long, st As Variant, en As Variant, usehandler As mHandler, usehandler1 As mHandler Dim va As Variant w1 = Abs(IsLabel(bstack, rest$, s$)) If w1 > 4 Then If neoGetArray(bstack, s$, pppp) Then If pppp.arr Then If FastSymbol(rest$, ")") Then If Not IsSymbol(rest$, ",") Then ' READ KEYWORDS st = 1: en = -1 If IsLabelSymbolNew(rest$, "ΑΡΧΗ", "START", Lang) Then st = 1 ElseIf IsLabelSymbolNew(rest$, "ΤΕΛΟΣ", "END", Lang) Then st = -1 ElseIf IsExp(bstack, rest$, st, , True) Then st = Int(st) Else st = 1 End If If IsLabelSymbolNew(rest$, "ΕΩΣ", "TO", Lang) Then If IsLabelSymbolNew(rest$, "ΑΡΧΗ", "START", Lang) Then en = 1 ElseIf IsLabelSymbolNew(rest$, "ΤΕΛΟΣ", "END", Lang) Then en = -1 ElseIf IsExp(bstack, rest$, en, , True) Then en = Int(en) Else MyEr "To where?", "Έως που;" Exit Function End If Else en = -1 End If Else If Not IsExp(bstack, rest$, st) Then st = 1 If Not IsSymbol(rest$, ",") Then en = -1 ElseIf Not IsExp(bstack, rest$, en) Then MissNumExpr Exit Function End If End If Set usehandler = New mHandler Set usehandler.objref = pppp Set bstack.lastobj = usehandler PlaceIteratorData bstack, var(0), st, en iter = True Exit Function End If End If End If ElseIf GetVar(bstack, s$, w1) Then If Not MyIsObject(var(w1)) Then GoTo err11 ElseIf var(w1) Is Nothing Then GoTo err11 End If If TypeOf var(w1) Is mHandler Then Set va = var(w1) conthere111: If Not IsSymbol(rest$, ",") Then st = 1: en = -1 If IsLabelSymbolNew(rest$, "ΑΡΧΗ", "START", Lang) Then st = 1 ElseIf IsLabelSymbolNew(rest$, "ΤΕΛΟΣ", "END", Lang) Then st = -1 ElseIf IsExp(bstack, rest$, st, , True) Then st = Int(st) Else st = 1 End If If IsLabelSymbolNew(rest$, "ΕΩΣ", "TO", Lang) Then If IsLabelSymbolNew(rest$, "ΑΡΧΗ", "START", Lang) Then en = 1 ElseIf IsLabelSymbolNew(rest$, "ΤΕΛΟΣ", "END", Lang) Then en = -1 ElseIf IsExp(bstack, rest$, en, , True) Then en = Int(en) Else MyEr "To where?", "Έως που;" Exit Function End If Else en = -1 End If Else If Not IsExp(bstack, rest$, st, , True) Then st = 1 If Not IsSymbol(rest$, ",") Then en = -1 ElseIf Not IsExp(bstack, rest$, en, , True) Then MissNumExpr Exit Function End If Set usehandler = New mHandler Set bstack.lastobj = usehandler Set usehandler1 = va usehandler.t1 = usehandler1.t1 GoTo con12345 End If If Not TypeOf va Is mHandler Then On Error GoTo there1 If Not TypeOf var(w1).objref Is iBoxArray Then err11: Set bstack.lastobj = Nothing MyEr "Not proper object for iterator", "Δεν είναι σωστό αντικείμενο για επανάληψη" Exit Function End If End If there1: Err.Clear Set bstack.lastobj = New mHandler con12345: PlaceIteratorData bstack, va, st, en iter = True End If ElseIf Not bstack.StaticCollection Is Nothing Then If bstack.ExistVar(s$, iter) Then bstack.ReadVar s$, va GoTo conthere111 End If End If End Function Function ClearLabels() If sb2used > 0 Then Dim i As Long For i = 1 To sb2used Set sbf(i).subs = Nothing Set sbf(i).Pad = Nothing Next i End If End Function Function MyIsNumericPointer(v As Variant) As Boolean Select Case MemInt(VarPtr(v)) Case Is < 8, 11, 17, 14, 20, 36 MyIsNumericPointer = True End Select End Function Function CheckInt64(v As Variant) As Boolean CheckInt64 = MemByte(VarPtr(v)) = 20 End Function Function MyIsNumeric(v As Variant) As Boolean Select Case MemByte(VarPtr(v)) Case Is < 8, 11, 17, 14, 20, 36 MyIsNumeric = True End Select End Function Function MyIsPureNumeric(v As Variant) As Boolean Select Case MemByte(VarPtr(v)) Case Is < 8, 11, 17, 14, 20 MyIsPureNumeric = True End Select End Function Function MyIsNumeric2(v As Variant, n As Integer) As Boolean n = MemInt(VarPtr(v)) Select Case n Case Is < 8, 11, 17, 14, 20 MyIsNumeric2 = True End Select End Function Function IsNumericPrint(v As Variant) As Boolean Select Case MemByte(VarPtr(v)) Case 0 ' nothing Case Is < 8, 11, 17, 14, 20, 36 IsNumericPrint = True End Select End Function Function MyIsUnknown(v As Variant) As Boolean MyIsUnknown = MemByte(VarPtr(v)) = 13 End Function Function MyIsObject(v As Variant) As Boolean MyIsObject = MemByte(VarPtr(v)) = 9 End Function Function MyVal(v As Variant) As Variant On Error GoTo there1245 MyVal = v Exit Function there1245: On Error GoTo there1246 MyVal = val(v) there1246: End Function Function ThisPointer(bstack As basetask, w3 As Long) As Boolean ' return var(r) Dim s1$ Set bstack.lastobj = Nothing If Len(bstack.UseGroupname) > 0 Then s1$ = Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) If GetVar(bstack, s1$, w3) Then ThisPointer = True ElseIf Len(bstack.fHere) = 0 Then ElseIf GetVar(bstack, bstack.fHere + "." + s1$, w3) Then ThisPointer = True ElseIf GetVar(bstack, s1$, w3, True) Then ThisPointer = True End If Else there: 's1$ = "." s1$ = vbNullString If bstack.GetDotNew(s1$, 1) Then If Len(s1$) = 0 Then Exit Function s1$ = Left$(s1$, Len(s1$) - 1) If GetVar(bstack, s1$, w3) Then ThisPointer = True End If End If End If End Function Function This1(bstack As basetask, original$, r As Variant) As Boolean ' return a copy Dim s1$, w3 As Long Set bstack.lastobj = Nothing If Len(bstack.UseGroupname) > 0 Then If bstack.tpointer > 0 Then If var(bstack.tpointer).GroupName = bstack.UseGroupname Then Set bstack.lastobj = CopyGroupObj(var(bstack.tpointer)) Else GoTo cont1001 End If Else cont1001: s1$ = Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) If GetVar(bstack, s1$, w3) Then Set bstack.lastobj = CopyGroupObj(var(w3)) ElseIf GetVar(bstack, bstack.fHere + "." + s1$, w3) Then Set bstack.lastobj = CopyGroupObj(var(w3)) ElseIf GetVar(bstack, s1$, w3, True) Then Set bstack.lastobj = CopyGroupObj(var(w3)) End If End If Else there: s1$ = vbNullString If bstack.GetDotNew(s1$, 1) Then If Len(s1$) = 0 Then If GetVar(bstack, original$, w3) Then If MyIsObject(var(w3)) Then Set bstack.lastobj = var(w3) r = 0 Else r = var(w3) End If This1 = True Else MyEr "Not Defined variable " + original$, "Δεν έχει οριστεί μεταβλητή " + original$ This1 = False End If Exit Function Else s1$ = Left$(s1$, Len(s1$) - 1) If GetVar(bstack, s1$, w3) Then If MyIsObject(var(w3)) Then If TypeOf var(w3) Is Group Then Set bstack.lastobj = CopyGroupObj(var(w3)) Else Set bstack.lastobj = var(w3) End If r = 0 Else r = var(w3) End If This1 = True Exit Function End If End If End If End If r = 0 This1 = True End Function Function StackItem(bstack As basetask, a$, r) As Boolean Dim p As Variant, w3 As Long, anything1 As Object, anything As mStiva w3 = 1 If IsExp(bstack, a$, p) Then If bstack.lastobj Is Nothing Then Set anything1 = bstack.soros w3 = Abs(CLng(Fix(p))) ElseIf Not CheckStackObj(bstack, anything1, w3) Then MyEr "Not a stack object", "Δεν είναι αντικείμενο σωρού" Exit Function ElseIf FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then w3 = Abs(CLng(Fix(p))) End If End If Set anything = anything1 backitem: If anything.Total < w3 Then MyErMacro a$, "Stack item not found at position " + CStr(w3), "Δεν υπάρχει τιμή σωρού στη θέση " + CStr(w3) Set bstack.lastobj = Nothing StackItem = False: Exit Function ElseIf anything.StackItemType(w3) = "N" Then r = anything.StackItem(w3) StackItem = FastSymbol(a$, ")", True) Exit Function ElseIf anything.StackItemType(w3) = "L" Then r = anything.StackItem(w3) StackItem = FastSymbol(a$, ")", True) Exit Function ElseIf anything.StackItemType(w3) = "*" Then r = 0 Set bstack.lastobj = anything.StackPickRef(w3).ObjectRef StackItem = FastSymbol(a$, ")", True) Exit Function Else MyErMacro a$, "Stack item isn't number at position " + CStr(w3), "Η τιμή του σωρού δεν είναι αριθμός στη θέση " + CStr(w3) StackItem = False End If Exit Function Else w3 = 1 Set anything = bstack.soros GoTo backitem End If End Function Public Function LambdaList(bstack As basetask) As String On Error Resume Next LambdaList = var(-bstack.OriginalCode).Code$ End Function Sub PrepareLabel(bstack As basetask) If Not bstack.IamLambda Then Dim mmm$ If SecureNames Then mmm$ = sbf(bstack.OriginalCode).goodname Else mmm$ = here$ End If mmm$ = CleanStr(mmm$, ChrW(-65)) If InStr(mmm$, "».") > 0 Then mmm$ = Mid$(mmm$, InStr(mmm$, "».") + 2) End If ' If AscW(MMM$) = 8191 Then MMM$ = Mid$(MMM$, 8) If bstack.fHere <> "" And InStr(bstack.fHere, "(") > 0 Then mmm$ = bstack.fHere + "." + mmm$ End If If InStr(mmm$, ChrW(8191)) > 0 Then DropLeft ChrW(8191), mmm$ If InStr(mmm$, ChrW(8191)) > 0 Then DropLeft ChrW(8191), mmm$ End If If InStr(mmm$, ".") > 0 Then DropLeft ".", mmm$ GoTo conthere Else If Right$(mmm$, 2) = "()" Then mmm$ = Left$(mmm$, Len(mmm$) - 2) End If If pagio$ = "GREEK" Then Form2.Label1prompt(0) = "Τελεστής " Else Form2.Label1prompt(0) = "Operator " End If End If Else conthere: If bstack.IamThread Then If pagio$ = "GREEK" Then Form2.Label1prompt(0) = "ΝΗΜΑ(" & (bstack.Process.id) & "): " Else Form2.Label1prompt(0) = "THREAD(" & (bstack.Process.id) & "): " End If Else If pagio$ = "GREEK" Then If bstack.fHere <> "" Or Right$(mmm$, 2) = "()" Then If bstack.IamLambda Then If Right$(here$, 3) = "$()" Then Form2.label1(0) = "ΛΑΜΔΑ$()" Else Form2.label1(0) = "ΛΑΜΔΑ()" End If Exit Sub Else Form2.Label1prompt(0) = "Συνάρ.: " End If Else Form2.Label1prompt(0) = "Τμήμα: " End If Else If bstack.fHere <> "" Or Right$(mmm$, 2) = "()" Then If bstack.IamLambda Then If Right$(here$, 3) = "$()" Then Form2.label1(0) = "LAMBDA$()" Else Form2.label1(0) = "LAMBDA()" End If Exit Sub Else Form2.Label1prompt(0) = "Func.: " End If Else Form2.Label1prompt(0) = "Module: " End If End If End If End If If GetThisModuleName(mmm$) Then If Left$(mmm$, 1) = "‹" Then Form2.label1(0) = GetName$(mmm$) Else Form2.label1(0) = mmm$ End If Else Form2.label1(0) = GetName$(mmm$) End If End Sub Private Function CompareStr2(a$, b$) As Long On Error GoTo comperr If UserCodePage = DefCodePage Then CompareStr2 = StrComp(a$, b$, vbTextCompare) Else CompareStr2 = -2 + CompareString(Clid, &H1001, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$)) End If Exit Function comperr: CompareStr2 = -2 + CompareString(0, 0, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$)) End Function Private Function CompareStr3(a As Variant, b As Variant) As Long On Error GoTo comperr If Not mTextCompare Then CompareStr3 = StrComp(a, b) ElseIf UserCodePage = DefCodePage Then CompareStr3 = StrComp(a, b, vbTextCompare) Else CompareStr3 = -2 + CompareString(Clid, &H1001, StrPtr(a), Len(a), StrPtr(b), Len(b)) End If Exit Function comperr: Err.Clear If mTextCompare Then If MyIsObject(a) Or MyIsObject(b) Then Else CompareStr3 = -2 + CompareString(0, 0, StrPtr(a), Len(a), StrPtr(b), Len(b)) Exit Function End If End If MyEr "Not string found", "Δεν βρήκα αλφαριθμητικό" End Function Function CheckTwo(V1&, V2&) As Boolean Dim one As Group, two As Group If VarTypeName(var(V1&)) <> mGroup Then Dim a1 As Variant, b1 As Variant If VarTypeName(var(V1&)) = mHdlr Then Dim a As Object Set a = var(V1&) CheckLastHandler a If a.indirect >= 0 And a.indirect <= var2used Then Set a = var(a.indirect) End If Set a1 = a Else If MyIsObject(var(V1&)) Then Set a1 = var(V1&) Else a1 = var(V1&) End If End If If VarTypeName(var(V2&)) = mHdlr Then Dim b As Object Set b = var(V2&) CheckLastHandler b If b.indirect >= 0 And b.indirect <= var2used Then Set b = var(b.indirect) End If Set b1 = b Else If MyIsObject(var(V2&)) Then Set b1 = var(V2&) Else b1 = var(V2&) End If End If CheckTwo = Typename(a1) = Typename(b1) ElseIf VarTypeName(var(V2&)) = mGroup Then Set one = var(V1&) If one.IamApointer Then Set one = one.link End If Set two = var(V2&) If two.IamApointer Then Set two = two.link End If If one.IamSuperClass Then If two.IamSuperClass Then CheckTwo = False ' no two superclass as the same, (maybe they have the same kind of members) ' because superclass may have unique members, but also have unique values Else ' check if second is kind of superclass CheckTwo = one.SuperClassList Is two.SuperClassList End If Else ' check first if has the same superclass If one.SuperClassList Is two.SuperClassList Then If two.IamSuperClass Then ' so v1& as V2& if v2& is a superclass (same as before) CheckTwo = True Else ' so now we have to check lists Dim ms As mStiva2, ms2 As mStiva2 Set ms = one.PrepareSorosToCompare(var()) Set ms2 = two.PrepareSorosToCompare(var()) ' check ms2 against ms ' every time we found one in ms2 we remove it from both Dim i As Long, j As Long again: For i = 1 To ms2.Total For j = 1 To ms.Total If ms.StackItem(j) = ms2.StackItem(i) Then If i > 1 Then ms2.MakeTopItem i If j > 1 Then ms.MakeTopItem j ms.drop 1 ms2.drop 1 GoTo again End If Next j Next i CheckTwo = ms2.Total = 0 End If End If End If End If End Function Function ProcessIf(flag As Variant, bstack As basetask, rest$, r As Variant) As Boolean Dim mode As Boolean, usehandler As mHandler mode = flag < 1 If bstack.lastobj Is Nothing Then flag = Int(Abs(flag > 0) * (flag - 1) - (flag <= 0) * (flag + 1) + 1) Else If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If usehandler.t1 = 4 Then Set bstack.lastobj = Nothing Set usehandler = Nothing flag = Int(Abs(flag > 0) * (flag - 1) - (flag <= 0) * (flag + 1) + 1) End If Else flag = 1 End If End If Dim nowpos As Double, w1 As Long, s$ nowpos = 1 ProcessIf = True If Not FastSymbol(rest$, "->", True, 2) Then Exit Function Do If flag = nowpos Then If MaybeIsSymbol(rest$, ",)") Then If mode Then r = flag = 1 Else r = 0 End If Else If Not IsExp(bstack, rest$, r) Then MissNumExpr ProcessIf = False Exit Function End If End If ProcessIf = True Else If Not MaybeIsSymbol(rest$, ",)") Then w1 = 1 s$ = aheadstatus(rest$, True, w1) If s$ = vbNullString Then Exit Do Mid$(rest$, 1, w1 - 1) = space$(w1 - 1) End If End If If Not FastSymbol(rest$, ",") Then Exit Do nowpos = nowpos + 1 If mode Then If nowpos > 2 Then MyEr "To many expressions", "Πολλές εκφράσεις" Loop If nowpos = 1 Then MyEr "Need two expressions", "Χρειάζομαι δυο εκφράσεις" If Not FastSymbol(rest$, ")") Then ProcessIf = False End Function Function ProcessIfStr(ByVal flag As Double, bstack As basetask, rest$, ss As String) As Boolean Dim mode As Boolean mode = flag < 1 flag = Int(Abs(flag > 0) * (flag - 1) - (flag <= 0) * (flag + 1) + 1) 'Set bstack.lastobj = Nothing Dim nowpos As Double, w1 As Long, s$ nowpos = 1 ProcessIfStr = True If Not FastSymbol(rest$, "->", True, 2) Then Exit Function Do If flag = nowpos Then If MaybeIsSymbol(rest$, ",)") Then ss = vbNullString Else If Not IsFlatStringExpr(bstack, rest$, ss) Then MissStringExpr ProcessIfStr = False Exit Function End If End If ProcessIfStr = True Else If Not MaybeIsSymbol(rest$, ",)") Then w1 = 1 s$ = aheadstatus(rest$, True, w1) If s$ = vbNullString Then Exit Do Mid$(rest$, 1, w1 - 1) = space$(w1 - 1) End If End If If Not FastSymbol(rest$, ",") Then Exit Do nowpos = nowpos + 1 If mode Then If nowpos > 2 Then MyEr "To many expressions", "Πολλές εκφράσεις" Loop If nowpos = 1 Then MyEr "Need two xpressions", "Χρειάζομαι δυο εκφράσεις" If Not FastSymbol(rest$, ")") Then ProcessIfStr = False End Function Function GETarrayFROMstr(a$, b$) As mHandler Dim pppp As tuple, aa() As String aa = Split(a$, b$) Set pppp = New tuple If UBound(aa) = -1 Then Else Dim i As Long pppp.PushDim UBound(aa) + 1 pppp.PushEnd For i = 0 To UBound(aa) pppp.item(i) = aa(i) Next i End If Set GETarrayFROMstr = New mHandler GETarrayFROMstr.t1 = 3 Set GETarrayFROMstr.objref = pppp End Function Function CheckThis(bstack As basetask, W$, b$, v As Long, Lang As Long) As Long Dim bb$ If Len(W$) > 3 Then If Lang = 1 Then If Left$(W$, 1) = "T" Then If Left$(W$, 4) = "THIS" Then If Len(W$) = 4 Then bb$ = vbNullString If bstack.GetDotNew(bb$, 1) < 0 Then If Len(bb$) = 0 Then CheckThis = -1: Exit Function If GetGlobalVar(Left$(bb$, Len(bb$) - 1), v) Then W$ = Left$(bb$, Len(bb$) - 1): GoTo found If GetlocalVar(Left$(bb$, Len(bb$) - 1), v) Then W$ = Left$(bb$, Len(bb$) - 1): GoTo found If GetGlobalVar(W$, v) Then GoTo found End If ElseIf Mid$(W$, 5, 1) = "." Then If Len(bstack.UseGroupname) > 0 Then bb$ = bstack.UseGroupname + Mid$(W$, 6) If varhash.Find(bb$, v) Then SwapStrings W$, bb$: GoTo found bb$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(W$, 6) If varhash.Find(bb$, v) Then SwapStrings W$, bb$: GoTo found Else bb$ = vbNullString If bstack.GetDotNew(bb$, 1) < 0 Then If Len(bb$) = 0 Then CheckThis = -1: Exit Function W$ = Left$(bb$, Len(bb$) - 1) + Mid$(W$, 5) If GetGlobalVar(W$, v) Then GoTo found End If End If End If End If End If Else If Left$(W$, 1) = "Α" Then If Left$(W$, 4) = "ΑΥΤΟ" Then If Len(W$) = 4 Then If bstack.GetDotNew(bb$, 1) < 0 Then If Len(bb$) = 0 Then CheckThis = -1: Exit Function If GetGlobalVar(Left$(bb$, Len(bb$) - 1), v) Then W$ = Left$(bb$, Len(bb$) - 1): GoTo found If GetlocalVar(Left$(bb$, Len(bb$) - 1), v) Then W$ = Left$(bb$, Len(bb$) - 1): GoTo found If GetGlobalVar(W$, v) Then GoTo found End If ElseIf Mid$(W$, 5, 1) = "." Then If Len(bstack.UseGroupname) > 0 Then bb$ = bstack.UseGroupname + Mid$(W$, 6) If varhash.Find(bb$, v) Then SwapStrings W$, bb$: GoTo found bb$ = bstack.UseGroupname + ChrW(&HFFBF) + Mid$(W$, 6) If varhash.Find(bb$, v) Then SwapStrings W$, bb$: GoTo found Else bb$ = vbNullString If bstack.GetDotNew(bb$, 1) < 0 Then If Len(bb$) = 0 Then CheckThis = -1: Exit Function W$ = Left$(bb$, Len(bb$) - 1) + Mid$(W$, 5) If GetGlobalVar(W$, v) Then GoTo found End If End If End If End If End If End If End If Exit Function found: CheckThis = 1 If FastSymbol(b$, "=") Then Exit Function If FastSymbol(b$, "<=", , 2) Then Exit Function If FastSymbol(b$, "->", , 2) Then CheckThis = 3: Exit Function CheckThis = 2 End Function Function myHwnd(bstack As basetask) As Double If Typename(bstack.Owner) = "GuiM2000" Then myHwnd = bstack.Owner.hWnd Else If ttl Then myHwnd = Form3.hWnd Else myHwnd = bstack.Owner.hWnd End If End If End Function Function GetName(ByVal part$) As String Dim s$ again: If InStrRev(part$, ChrW(&H1FFF)) > 0 Then If InStr(part$, ".") > 0 Then part$ = Mid$(part$, InStr(part$, ".") + 1) GoTo again End If End If If LenB(part$) = 0 Then Exit Function If InStr(part$, "».") > 0 Then part$ = Mid$(part$, InStr(part$, "».") + 2) If InStr(part$, ChrW(&H1FFF)) > 0 Then If InStr(part$, ".") > 0 Then part$ = Mid$(part$, InStr(part$, ".") + 1) GoTo again End If End If ElseIf InStr(part$, "»") > 0 Then part$ = Mid$(part$, rinstr(part$, "»", 1) + 2) If InStr(part$, ChrW(&H1FFF)) > 0 Then If InStr(part$, ".") > 0 Then part$ = Mid$(part$, InStr(part$, ".") + 1) GoTo again End If End If If iRVAL22(part$) > 0 Then part$ = sbf(iRVAL22(part$)).goodname GoTo again End If ElseIf InStr(part$, "›") > 0 Then If Left$(part$, 1) = "‹" Then part$ = sbf(val(Mid$(part$, 2))).goodname + Mid$(part$, InStr(part$, "›") + 1) End If ElseIf iRVAL22(part$) > 0 Then If InStr(part$, "»«") = 0 Then GetName = vbNullString 'part$ Exit Function Else part$ = sbf(iRVAL22(part$)).goodname End If If Left$(part$, 1) = "‹" Then part$ = sbf(val(Mid$(part$, 2))).goodname + Mid$(part$, InStr(part$, "›") + 1) End If GoTo again End If GetName = part$ End Function Sub FeedArray(pppp As iBoxArray, v As Long, fromthis As Object, Optional convert As Boolean = False) Dim mm As mStiva, myobject As Object, p As Variant, usehandler As mHandler Set mm = fromthis Do While Not mm.IsEmpty If v >= pppp.Count Then Exit Do If mm.PopType = ">" Then mm.drop 1 pppp.item(v) = 0& v = v + 1 ElseIf mm.StackItemTypeIsObject(1) Then pppp.item(v) = -1 Set myobject = mm.PopObj If Typename$(myobject) = mGroup Then If myobject.IamFloatGroup Then Set pppp.item(v) = myobject Else BadGroupHandle Set myobject = Nothing Exit Sub End If ElseIf Typename$(myobject) = "lambda" Then Set pppp.item(v) = myobject ElseIf Typename$(myobject) = myArray Then If myobject.arr Then Set pppp.item(v) = CopyArray(myobject) Else Set pppp.item(v) = myobject End If ElseIf Typename$(myobject) = "tuple" Then If myobject.arr Then Set pppp.item(v) = CopyArray(myobject) Else Set pppp.item(v) = myobject End If ElseIf Typename$(myobject) = mHdlr Then If myobject.indirect > -0 Then Set pppp.item(v) = myobject Else p = myobject.t1 If CheckDeepAny(myobject) Then If TypeOf myobject Is mHandler Then Set pppp.item(v) = myobject Else Set usehandler = New mHandler Set pppp.item(v) = usehandler usehandler.t1 = p Set usehandler.objref = myobject End If End If End If Else Set pppp.item(v) = myobject End If Set myobject = Nothing Else If pppp.ItemType(v) = doc Then If mm.PopType = "S" Then CheckVar pppp.item(v), mm.PopStr Else ' ERROR Set pppp.item(v) = New Document mm.drop 1 End If ElseIf Not mm.PopType = "S" Then If convert Then pppp.item(v) = MyRound(mm.StackItem(1), 0) mm.drop 1 Else pppp.item(v) = mm.StackItem(1) mm.drop 1 End If Else pppp.item(v) = mm.StackItem(1) mm.drop 1 End If End If v = v + 1 Loop Set fromthis = Nothing End Sub Function CurrentStackSize() As Double 'If IsWine Then Exit Function On Error GoTo 1000 Dim endaddress As Long ua = startaddress UB = VarPtr(endaddress) ' IN IDE USING BREAK ON ALL ERROR STOP HERE - THIS IS OK ' CHANGE THE ERROR LEVEL AND AFTER THAT CHANGE IT AGAIN CurrentStackSize = uintnew(ua) - uintnew(UB) - 300 ' - (1 - m_bInIDE) * 93 Exit Function 1000 Err.Raise 8000 End Function Function ClaimStack() As Long If IsWine Then Exit Function Static once11 As Boolean ClaimStack = findstack If once11 Then Exit Function once11 = True repeatme ClaimStack = findstack End Function Function repeatme() On Error GoTo there findstack = CurrentStackSize() On Error GoTo there repeatme there: End Function Function GetModuleName(b As basetask, where$) As String If SecureNames Then If b.OriginalCode < 0 Then If var2used <= -b.OriginalCode Then Exit Function GetModuleName = GetName(var(-b.OriginalCode).Name) Else GetModuleName = GetName(sbf(b.OriginalCode).goodname) End If Else GetModuleName = GetName(StripRVAL(where$)) End If End Function Private Function compareStr4(a$, b$) As Long ' here is not byval as in fastcollection Dim i As Long, j As Long, a1$, b1$, P1 As Variant, P2 As Variant, n$, k As Long, k1 As Long If CompareString(Clid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$)) = 2 Then Exit Function n$ = "[-0-9.]" k = Sgn(Len(a$) - Len(b$)) k1 = k again: j = IIf(Len(a$) >= Len(b$), Len(b$), Len(a$)) For i = 1 To j If Mid$(a$, i, 1) Like n$ Then a1$ = Mid$(a$, i) b1$ = Mid$(b$, i) IsNumberD2 a1$, P1 If IsNumberD2(b1$, P2) Then compareStr4 = Sgn(MyRound(P1, 8) - MyRound(P2, 8)) If compareStr4 = 0 Then If Len(a1$) * Len(b1$) <> 0 Then If Len(n$) > 6 Then n$ = "[-0-9]" k = Sgn(Len(a1$) - Len(b1$)) a$ = a1$ b$ = b1$ GoTo again End If If Len(a1$) + Len(b1$) = 0 Then compareStr4 = k Else compareStr4 = Sgn(Len(a1$) - Len(b1$)) End If Exit Function End If Exit Function Else a$ = Mid$(a$, i) b$ = Mid$(b$, i) IsNumberD2 a$, P1 If Len(a$) > 0 Then Select Case CompareString(Clid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$)) Case 1, 3 compareStr4 = -1 Case 2 If k > 0 Then compareStr4 = -1 Else compareStr4 = 1 End If End Select Else compareStr4 = -1 End If End If Exit Function ElseIf Mid$(b$, i, 1) Like n$ Then a$ = Mid$(a$, i) b$ = Mid$(b$, i) IsNumberD2 b$, P1 If Len(b$) > 0 Then Select Case CompareString(Clid, &H1000, StrPtr(a$), Len(a$), StrPtr(b$), Len(b$)) Case 3 compareStr4 = 1 Case 1, 2 If k < 0 Then compareStr4 = 1 Else compareStr4 = -1 End If End Select Else compareStr4 = 1 End If Exit Function End If compareStr4 = -2 + CompareString(Clid, 0, StrPtr(a$) + i * 2 - 2, 1, StrPtr(b$) + i * 2 - 2, 1) If compareStr4 <> 0 Then Exit Function End If Next i compareStr4 = Sgn(Len(a$) - Len(b$)) If compareStr4 = 0 Then compareStr4 = k1 End Function Private Function checkbreak(bstack As basetask, b$, once As Boolean) As Boolean Static Busy As Boolean Dim btimer As Long checkbreak = NOEXECUTION If lckfrm > 0 Then Exit Function Call GetSystemTimeAsFileTime(basictimer) btimer = MemLong(VarPtr(basictimer)) If (btimer And &H380000) = (timestamp And &H380000) Then Exit Function timestamp = btimer If Forms.Count > 5 Then Exit Function If Busy Then Exit Function If Not bstack.IamAnEvent Then If bstack.TaskMain Then Exit Function If KeyPressed2(&H11, &H43) Then Busy = True Form1.EXECSTOP timestamp = MemLong(VarPtr(basictimer)) Busy = False checkbreak = NOEXECUTION Exit Function ElseIf KeyPressedLong(&H13) = 0 Then Exit Function End If Busy = True ResetBreak If Form1.mybreak1() Then Modalid = 0 If Not TaskMaster Is Nothing Then TaskMaster.Dispose: MusicMaster.Dispose NOEXECUTION = True MOUT = True MKEY$ = "@Start" + Chr$(13) b$ = " " MyEr "", "" once = False Prefresh(GetCode(bstack.Owner)).k1 = 0 MyDoEvents0 bstack.Owner checkbreak = True End If End If ResetBreak Call GetSystemTimeAsFileTime(basictimer) timestamp = MemLong(VarPtr(basictimer)) Busy = False End Function Private Function checkbreakEsc(bstack As basetask) As Boolean Static Busy As Boolean, tmstp As Long Dim btimer As Long If bstack Is Nothing Then checkbreakEsc = True: Exit Function If lckfrm > 0 Then Call GetSystemTimeAsFileTime(basictimer) tmstp = MemLong(VarPtr(basictimer)) If MusicTaskNum > 0 Then If Not SLOW Then If Not (tmstp And &HE0000) = (musicstamp And &HE0000) Then musicstamp = tmstp If MusicMaster.PlayMusic Then MusicMaster.TimerTick End If tmstp = MemLong(VarPtr(basictimer)) End If End If End If checkbreakEsc = NOEXECUTION 'Or checkbreakEsc Exit Function End If Call GetSystemTimeAsFileTime(basictimer) tmstp = MemLong(VarPtr(basictimer)) If MusicTaskNum > 0 Then If Not SLOW Then If Not (tmstp And &HE0000) = (musicstamp And &HE0000) Then musicstamp = tmstp If MusicMaster.PlayMusic Then MusicMaster.TimerTick End If tmstp = MemLong(VarPtr(basictimer)) End If End If End If If Not extreme Then If (tmstp And &H3800) = (timestamp And &H3800) Then Exit Function If escok Then If myexit2(bstack) Then checkbreakEsc = True: Exit Function Else If (tmstp And &H3800000) = (timestamp And &H3800000) Then Exit Function End If timestamp = tmstp If Forms.Count > 5 Then Exit Function If Busy Then Exit Function If Not bstack.IamAnEvent Then If bstack.TaskMain Then Exit Function If KeyPressed2(&H11, &H43) Then Busy = True Form1.EXECSTOP Call GetSystemTimeAsFileTime(basictimer) timestamp = MemLong(VarPtr(basictimer)) Busy = False checkbreakEsc = NOEXECUTION Exit Function ElseIf KeyPressedLong(&H13) = 0 Then Exit Function End If Busy = True ResetBreak If Form1.mybreak1() Then Modalid = 0 If Not TaskMaster Is Nothing Then TaskMaster.Dispose NOEXECUTION = True MOUT = True MKEY$ = "@Start" + Chr$(13) 'b$ = " " MyEr "", "" 'once = False Prefresh(GetCode(bstack.Owner)).k1 = 0 MyDoEvents0 bstack.Owner checkbreakEsc = True End If End If ResetBreak Call GetSystemTimeAsFileTime(basictimer) timestamp = MemLong(VarPtr(basictimer)) Busy = False End Function Public Sub ClearStr(a$) Dim i As Long, j As Long While FastSymbol(a$, vbCrLf, , 2) i = 1 While FastOperator(a$, vbCrLf, i, 2) Wend j = Len(a$) If j = 0 Then Exit Sub i = MyTrimL(a$) If i > j Then Exit Sub Wend End Sub Private Function IsRandom(bstack As basetask, a$, r As Variant) As Boolean If FastSymbol(a$, "!") Then If IsExp(bstack, a$, r, , True) Then '' CHOOSE SEED AND SAVEIT TO BASESTACK On Error Resume Next simplestack1 = rndbase RandomizeIt rndbase, signlong2(r) If Err Then Err.Clear r = 0 End If Else rndbase = simplestack1 End If ElseIf IsExp(bstack, a$, r, , True) Then r = Int(r) If FastSymbol(a$, ",") Then Dim p As Variant If Not IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then IsRandom = False: Exit Function p = MyRound(p) Dim pp As Variant If p > r Then pp = p: p = r: r = pp Else p = 0 End If r = Int((r - p + 1) * RndM(rndbase) + p) On Error GoTo 0 IsRandom = True Else Call GetSystemTimeAsFileTime(basictimer) RandomizeIt rndbase, MemLong(VarPtr(basictimer)) r = True End If IsRandom = FastSymbol(a$, ")", True) End Function Private Function IsArrayFun(bstack As basetask, a$, r As Variant) As Boolean Dim s$, w1 As Long, pppp As iBoxArray, anything As Object, p As Variant, ms As mStiva, usehandler As mHandler, RF As refArray Dim myGroup As Group If IsStrExp(bstack, a$, s$) Then If bstack.lastobj Is Nothing Then If Right$("!!" + s$, 2) = "()" Then Mid$(s$, Len(s$), 1) = " " s$ = RTrim$(s$) Else w1 = InStr("!" + s$, "(") - 1 If w1 > 0 And w1 <= Len(s$) Then s$ = Left$(s$, w1) ElseIf neoGetArray(bstack, s$, pppp) Then GoTo check123678 Else s$ = s$ + "(" End If End If If neoGetArray(bstack, s$, pppp) Then check123678: If Not pppp.arr Then NotArray: Exit Function If FastSymbol(a$, ",") Then IsArrayFun = NeoGetArrayItem(pppp, bstack, s$, w1, a$) Else IsArrayFun = FastSymbol(a$, ")", True) w1 = 0 ' w1 = pppp.index End If checkIterator: If Not pppp.IsEmpty Then If MyIsObject(pppp.item(w1)) Then Set anything = pppp.item(w1) If Not anything Is Nothing Then If TypeOf anything Is Group Then bstack.soros.CopyGroupObj pppp.item(w1), anything Set bstack.lastobj = anything Else Set bstack.lastobj = anything End If Else Set bstack.lastobj = Nothing End If r = 0 Else Set bstack.lastobj = Nothing r = pppp.itemnumeric(w1) End If Else mEmptyArray End If Else Set bstack.lastobj = Nothing NotArray End If Exit Function ElseIf IsobjArray(bstack.lastobj) Then Set pppp = bstack.lastobj GoTo check123678 Else Set bstack.lastobj = Nothing SyntaxError End If ElseIf IsExp(bstack, a$, p, nostring:=True) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If usehandler.indirect >= 0 Then Set pppp = var(usehandler.indirect) If usehandler.UseIterator Then pppp.index = usehandler.index_cursor End If GoTo check123678 ElseIf IsobjArray(usehandler.objref) Then Set pppp = usehandler.objref If usehandler.UseIterator Then pppp.index = usehandler.index_cursor End If If usehandler.UseIterator Then If Not pppp.arr Then NotArray: Exit Function If FastSymbol(a$, ",") Then Set bstack.lastobj = Nothing Set usehandler = Nothing IsArrayFun = IsExp(bstack, a$, r, , True) IsArrayFun = FastSymbol(a$, ")", True) w1 = r Else IsArrayFun = FastSymbol(a$, ")", True) w1 = pppp.index End If If Not IsArrayFun Then Exit Function GoTo checkIterator Else GoTo check123678 End If ElseIf TypeOf usehandler.objref Is mStiva Then Set ms = usehandler.objref Set bstack.lastobj = Nothing Set usehandler = Nothing If FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then Set bstack.lastobj = ms.ExportArray(CLng(MyRound(p))) End If Else ' Set usehandler = New mHandler ' usehandler.t1 = 3 ' Set usehandler.objref = ms.ExportArray(ms.Count) ' Set bstack.lastobj = usehandler Set bstack.lastobj = ms.ExportArray(ms.Count) End If Set ms = Nothing IsArrayFun = FastSymbol(a$, ")", True) Exit Function ElseIf TypeOf usehandler.objref Is FastCollection Then If FastSymbol(a$, "!") Then Set bstack.lastobj = usehandler.objref.ExportKeys Else Set bstack.lastobj = usehandler.objref.ExportValues End If Set usehandler = Nothing IsArrayFun = FastSymbol(a$, ")", True) Exit Function Else Set bstack.lastobj = Nothing NotArray End If ElseIf IsobjArray(bstack.lastobj) Then If FastSymbol(a$, ")") Then IsArrayFun = True Exit Function End If Set pppp = bstack.lastobj GoTo check123678 ElseIf TypeOf bstack.lastobj Is refArray Then Dim pppp0 As mArray Set pppp0 = New mArray Set RF = bstack.lastobj pppp0.SupportRefArray CVar(RF) Set bstack.lastobj = pppp0 IsArrayFun = FastSymbol(a$, ")", True) End If End If Else Set bstack.lastobj = New mArray IsArrayFun = FastSymbol(a$, ")", True) End If End Function Private Function IsStackObj(v$, bstack As basetask, a$, r As Variant) As Boolean Dim anything As Object, anything2 As Object, p As Variant, usehandler As mHandler, ms As mStiva Set usehandler = New mHandler Set anything = usehandler usehandler.t1 = 3 If FastSymbol(a$, ":=", , 2) Then If Not GetData(bstack, a$, anything2) Then Exit Function End If Set usehandler.objref = anything2 Set anything2 = Nothing ElseIf IsLabelSymbolNew(a$, "ΚΑΤΩ", "DOWN", Abs(AscW(v$) = 83)) Then If IsExp(bstack, a$, p) Then If Not bstack.lastobj Is Nothing Then Set anything2 = bstack.lastobj If TypeOf anything2 Is mHandler Then Set usehandler = anything2 If usehandler.t1 = 3 Then If Not usehandler.objref Is Nothing Then If TypeOf usehandler.objref Is mStiva Then Set ms = NewmStiva FastSymbol a$, "," If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then ms.SplitStackBottom anything2, CLng(Fix(p)) End If Set usehandler = anything Set usehandler.objref = ms GoTo normalexit End If End If End If End If End If End If NoStackObjectFound a$ ElseIf IsLabelSymbolNew(a$, "ΑΝΩ", "UP", Abs(AscW(v$) = 83)) Then If IsExp(bstack, a$, p) Then If Not bstack.lastobj Is Nothing Then Set anything2 = bstack.lastobj If TypeOf anything2 Is mHandler Then Set usehandler = anything2 If usehandler.t1 = 3 Then If Not usehandler.objref Is Nothing Then If TypeOf usehandler.objref Is mStiva Then Set ms = NewmStiva FastSymbol a$, "," If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then ms.SplitStackTop anything2, CLng(Fix(p)) End If Set usehandler = anything Set usehandler.objref = ms GoTo normalexit End If End If End If End If End If End If NoStackObjectFound a$ Else Set usehandler.objref = NewmStiva End If normalexit: Set bstack.lastobj = anything r = 0 IsStackObj = True End Function Private Function IsStack(bstack As basetask, a$, r As Variant) As Boolean Dim anything As Object, pppp As iBoxArray, p As Variant, anything2 As Object, usehandler As mHandler, usestiva As mStiva If IsExp(bstack, a$, r) Then If CheckStackObj(bstack, anything) Then If TypeOf anything Is iBoxArray Then Set pppp = anything Set usestiva = NewmStiva usestiva.MergeBottomCopyArray pppp Set usehandler = New mHandler Set bstack.lastobj = usehandler usehandler.t1 = 3 Set usehandler.objref = usestiva Set usestiva = Nothing Set usehandler = Nothing IsStack = FastSymbol(a$, ")", True) Exit Function End If If Not TypeOf anything Is mStiva Then GoTo stack12948 If FastSymbol(a$, ",") Then stack99981: Set usestiva = anything If IsExp(bstack, a$, p) Then If p <> 0 Then Set anything = usestiva.CopyMe2(CLng(Fix(p))) Else If Not bstack.lastobj Is Nothing Then If CheckStackObj(bstack, anything2) Then Set usestiva = anything2 Set anything2 = usestiva.CopyMe() Set usestiva = anything Set anything = usestiva.MergeFromOther(anything2) If FastSymbol(a$, ",") Then GoTo stack99981 Else GoTo stack129481 End If Else stack129481: NoStackObjectToMerge End If End If Else missParam a$ Exit Function End If Else Set usestiva = anything Set anything = usestiva.CopyMe() End If Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = anything Set bstack.lastobj = usehandler Set anything = Nothing Set usehandler = Nothing Set usestiva = Nothing Else stack12948: MyEr "Not a stack object", "Δεν βρήκα αντικείμενο σωρού" End If IsStack = FastSymbol(a$, ")", True) Exit Function Else missParam a$ End If End Function Private Function IsCeil(bstack As basetask, a$, r As Variant) As Boolean Dim pp As Variant If IsExp(bstack, a$, r, , True) Then ''On Error Resume Next If FastSymbol(a$, ")") Then r = IIf(Fix(r) = r, r, Int(r) + 1) IsCeil = True Else missParam a$ End If End If End Function Private Function IsFloor(bstack As basetask, a$, r As Variant) As Boolean Dim pp As Variant If IsExp(bstack, a$, r, , True) Then ''On Error Resume Next If FastSymbol(a$, ")") Then r = Int(r) IsFloor = True Else missParam a$ End If End If End Function Private Function IsRound(bstack As basetask, a$, r As Variant) As Boolean Dim pp As Variant, i As Integer If IsExp(bstack, a$, r, , True) Then On Error Resume Next If FastSymbol(a$, ")") Then If TypeOf r Is Complex Then r.r = MyRound(r.r, 13) r.i = MyRound(r.i, 13) Else r = MyRound(r, 13) End If IsRound = True ElseIf FastSymbol(a$, ",", True) Then If IsExp(bstack, a$, pp, , True) Then i = CInt(pp) If TypeOf r Is Complex Then r.r = MyRound(r.r, i) r.i = MyRound(r.i, i) Else r = MyRound(r, i) End If If Err.Number > 0 Then Err.Clear IsRound = FastSymbol(a$, ")", True) End If Else missParam a$ End If End If End Function Private Function IsInt(bstack As basetask, a$, r As Variant) As Boolean If IsExp(bstack, a$, r, , True) Then On Error Resume Next Set bstack.lastobj = Nothing r = Int(r) If Err.Number > 0 Then MyErMacro a$, "long conversion failed", "Η μετατροπή σε ακέραιο απέτυχε" Exit Function End If On Error GoTo 0 IsInt = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsUint(bstack As basetask, a$, r As Variant) As Boolean Dim z As Integer, i As Long If IsExp(bstack, a$, r, , True) Then z = VarType(r) If z = vbInteger Then On Error Resume Next r = UINT(r) On Error GoTo 0 ElseIf z = 20 Then If r < 0 Then r = CDec(r) + maxlonglong Else r = CDec(r) End If ElseIf z = vbLong Then i = r r = Zero64 PutMem4 VarPtr(r) + 8, i Else On Error Resume Next If r > 2147483647# Then MyErMacro a$, "Overflow long, expect lower than (2147483648)", "Υπερχείλιση ακεραίου, περιμένω μικρότερο από (2147483648)" Exit Function ElseIf r < -2147483648# Then MyErMacro a$, "Overflow long, expect greater than (-2147483649)", "Υπερχείλιση ακεραίου, περιμένω μεγαλύτερο από (-2147483649)" IsUint = False Exit Function End If r = uintnew(r) If Err.Number > 0 Then MyErMacro a$, "Sign to Unsigned long failed", "Η μετατροπή ακεραίου με πρόσημο σε ακέραιο χωρίς πρόσημο απέτυχε" IsUint = False Exit Function End If On Error GoTo 0 End If IsUint = FastSymbol(a$, ")", True) Exit Function Else missParam a$ End If End Function Private Function IsSint(bstack As basetask, a$, r As Variant) As Boolean Dim p As Variant, rB As Byte, ri As Integer, dn As Long, rd As Double, usehandler As mHandler p = 4 If IsExp(bstack, a$, r) Then If Not bstack.lastobj Is Nothing Then If Not TypeOf bstack.lastobj Is mHandler Then: Exit Function Set usehandler = bstack.lastobj With usehandler If .t1 = 4 Then Set bstack.lastobj = Nothing: GoTo conthere If .t1 <> 2 Then GoTo err1256 If Not TypeOf .objref Is MemBlock Then GoTo err1256 If Not FastSymbol(a$, ",") Then GoTo err1256 If Not IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then GoTo err1256 Select Case .objref.ItemSize Case 1 If .objref.ValidArea2(p, 1) Then GetMem1 .objref.GetPtr(p), rB r = CInt(cUbyte(rB)) Else GoTo err1256 End If Case 2 If .objref.ValidArea2(p, 2) Then GetMem2 .objref.GetPtr(p), ri r = ri Else GoTo err1256 End If Case 8 If .objref.ValidArea2(p, 8) Then GetMem8 .objref.GetPtr(p), rd r = rd Else GoTo err1256 End If Case 4 If .objref.ValidArea2(p, 4) Then GetMem4 .objref.GetPtr(p), dn r = dn Else err1256: Set bstack.lastobj = Nothing Set usehandler = Nothing MyErMacro a$, "Wrong Size-Position for reading buffer", "Λάθος Μέγεθος-θέση, για διάβασμα Διάρθρωσης" Exit Function End If End Select End With Set bstack.lastobj = Nothing Set usehandler = Nothing IsSint = FastSymbol(a$, ")", True) Exit Function End If conthere: If FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If p = 4 Then GoTo contsint1 On Error Resume Next If r < 0 Then MyErMacro a$, "Unsigned Integer can't be negative", "Ο χωρίς πρόσημο ακέραιος δεν μπορεί να είναι αρνητικός" Exit Function End If If p = 8 Then r = SignInt64(r) ElseIf p = 2 Then r = cUint(signlong(r)) Else r = cUbyte(signlong(r)) End If If Err.Number > 0 Then If p <= 4 Then Err.Clear r = SignInt64(r) End If If Err.Number > 0 Then Unsignlongfailed a$ IsSint = False Exit Function End If End If On Error GoTo 0 IsSint = FastSymbol(a$, ")", True) Exit Function End If Else contsint1: On Error Resume Next If r < 0 Then Unsignlongnegative a$ Exit Function End If r = signlong(r) If Err.Number > 0 Then Err.Clear r = SignInt64(r) If Err.Number > 0 Then Unsignlongfailed a$ IsSint = False Exit Function End If End If End If On Error GoTo 0 IsSint = FastSymbol(a$, ")", True) Exit Function Else missParam a$ End If End Function Private Function IsUsgn(bstack As basetask, a$, r As Variant) As Boolean If IsExp(bstack, a$, r, , True) Then On Error Resume Next If r > Pow2minusOne(32) Then r = Pow2minusOne(32) r = Fix(r) If r < 0 Then r = 0 On Error GoTo 0 IsUsgn = FastSymbol(a$, ")", True) Exit Function Else missParam a$ End If End Function Private Function IsLOWORD(bstack As basetask, a$, r As Variant) As Boolean If IsExp(bstack, a$, r, , True) Then On Error Resume Next r = Int((r - Int(r / 65536#) * 65536#)) If Err.Number > 0 Then WrongArgument a$ Exit Function End If On Error GoTo 0 IsLOWORD = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsHIWORD(bstack As basetask, a$, r As Variant) As Boolean If IsExp(bstack, a$, r, , True) Then On Error Resume Next r = Int(Int(r / 256) / 256) If Err.Number > 0 Then WrongArgument a$ IsHIWORD = False Exit Function End If On Error GoTo 0 IsHIWORD = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsLen(bstack As basetask, a$, r As Variant) As Boolean Dim anything As Object, p As Variant, s$, usehandler As mHandler, rA As refArray If IsExp(bstack, a$, p) Then len1234: If bstack.lastobj Is Nothing Then GoTo bypass1 If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj While Typename$(usehandler.objref) = mHdlr Set usehandler = bstack.lastobj Set bstack.lastobj = usehandler.objref Wend Set bstack.lastobj = Nothing With usehandler If .indirect < 0 Then If .t1 = 1 Then r = .objref.Count IsLen = FastSymbol(a$, ")", True) Exit Function ElseIf .t1 = 2 Then r = .objref.SizeByte() IsLen = FastSymbol(a$, ")", True) Exit Function ElseIf .t1 = 3 Then ' if CheckDeepAny Set anything = usehandler If CheckDeepAny(anything) Then If Typename(anything) = mHdlr Then Set usehandler = anything r = usehandler.objref.Count Else r = anything.Count End If Else r = 0 End If IsLen = FastSymbol(a$, ")", True) Exit Function ElseIf .t1 = 5 Then r = .objref.structLen IsLen = FastSymbol(a$, ")", True) Exit Function ElseIf .t1 = 0 Then r = 0 On Error Resume Next r = .objref.Count On Error GoTo 0 IsLen = FastSymbol(a$, ")", True) Exit Function ElseIf .t1 = 4 Then r = usehandler.index_start IsLen = FastSymbol(a$, ")", True) Exit Function End If Else IsLen = FastSymbol(a$, ")", True) r = -1 End If End With ElseIf IsobjArray(bstack.lastobj) Then r = bstack.lastobj.Count IsLen = FastSymbol(a$, ")", True) Set bstack.lastobj = Nothing Exit Function ElseIf TypeOf bstack.lastobj Is refArray Then Set rA = bstack.lastobj If rA.MarkTwoDimension Then If FastSymbol1(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then p = Abs(Int(p)) r = rA.Count(p) Else missParam a$ Exit Function End If Else r = rA.Count End If Else r = rA.Count(0) End If IsLen = FastSymbol(a$, ")", True) Set bstack.lastobj = Nothing Exit Function Else bypass1: If VarType(p) = vbString Then r = CDbl(Len(p) - (LenB(p) Mod 2 = 1) / 2#) IsLen = FastSymbol(a$, ")", True) Exit Function ElseIf MemInt(VarPtr(p)) = 36 Then r = LenB(p) IsLen = FastSymbol(a$, ")", True) Exit Function Else r = -1 End If IsLen = FastSymbol(a$, ")", True) Set bstack.lastobj = Nothing End If missParam a$ ElseIf IsStrExp(bstack, a$, s$) Then If bstack.lastobj Is Nothing Then r = CDbl(Len(s$) - (LenB(s$) Mod 2 = 1) / 2#) Else GoTo len1234 End If IsLen = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsLenDisp(bstack As basetask, a$, r As Variant) As Boolean Dim p As Variant, s$, usehandler As mHandler If IsExp(bstack, a$, p) Then If Typename(bstack.lastobj) = mHdlr Then ' check this please Set usehandler = bstack.lastobj If usehandler.t1 = 4 Then wronguseofenum a$: Exit Function With usehandler If .indirect < 0 Then If TypeOf .objref Is FastCollection Then r = .objref.Count Set bstack.lastobj = Nothing IsLenDisp = FastSymbol(a$, ")", True) Exit Function ElseIf TypeOf .objref Is MemBlock Then r = .objref.items Set bstack.lastobj = Nothing IsLenDisp = FastSymbol(a$, ")", True) Exit Function End If Else r = -1 IsLenDisp = FastSymbol(a$, ")", True) Exit Function ' length of object??? End If End With End If If VarType(p) = vbString Then s$ = p r = RealLen(s$) IsLenDisp = FastSymbol(a$, ")", True) Exit Function Else missParam a$ End If ElseIf IsStrExp(bstack, a$, s$) Then r = RealLen(s$) IsLenDisp = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsDocLen(bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, s$, w2 As Long, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then r = var(w1).SizeCRLF Else r = Len(var(w1)) End If IsDocLen = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If pppp.ItemType(w2) = doc Then r = pppp.item(w2).SizeCRLF Else r = Len(pppp.item(w2)) End If Else End If IsDocLen = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsDocWords(bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, s$, w2 As Long, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then r = var(w1).WordCount Else MissFuncParammeterdOCVar a$ End If IsDocWords = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If pppp.ItemType(w2) = doc Then r = pppp.item(w2).WordCount Else MissFuncParammeterdOCVar a$ End If Else End If IsDocWords = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsDocUniqueWords(bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, s$, w2 As Long, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then r = var(w1).UniqueWords Else MissFuncParammeterdOCVar a$ End If IsDocUniqueWords = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If pppp.ItemType(w2) = doc Then r = pppp.item(w2).UniqueWords Else MissFuncParammeterdOCVar a$ End If Else End If IsDocUniqueWords = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsCompMinMax(ByVal dn As Long, bstack As basetask, a$, r As Variant) As Boolean Dim s$, w1 As Long, ow1 As Long, w2 As Long, s1$, dd As Long, w3 As Long, pppp As iBoxArray, pppp1 As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) ow1 = w1 If w1 = 1 Or w1 = 4 Then dd = 1 'WE NEED NUMBERS If w1 = 5 Or w1 = 7 Then dd = 2 'WE NEED NUMBERS If w1 = 0 Then MissingnumVar:: Exit Function If dd = 1 Then If GetVar(bstack, s$, w1) Then If Not FastSymbol(a$, ",") Then MissingnumVar:: Exit Function w3 = Abs(IsLabel(bstack, a$, s1$)) If w3 = 1 Or w3 = 4 Then If GetVar(bstack, s1$, w2) Then If myVarType(var(w1), vbString) Then If Not myVarType(var(w2), vbString) Then NeedString IsCompMinMax = False Exit Function End If Select Case dn Case 1 If CompareStr3(var(w1), var(w2)) = -1 Then r = var(w1) Else r = var(w2) Case 2 If CompareStr3(var(w1), var(w2)) = 1 Then r = var(w1) Else r = var(w2) Case Else If w1 <> w2 Then r = CompareStr3(var(w1), var(w2)) End Select Else Select Case dn Case 1 If var(w1) < var(w2) Then r = var(w1) Else r = var(w2) End If Case 2 If var(w1) > var(w2) Then r = var(w1) Else r = var(w2) End If Case Else If var(w1) = 0 Then If var(w2) = 0 Then r = 0 Else r = Sgn(0 - MyRound(var(w2), 10)) End If Else If MyRound((var(w2) - var(w1)) / var(w1), 10) = 0 Then r = 0 ElseIf var(w1) > var(w2) Then r = 1 Else r = -1 End If End If End Select End If IsCompMinMax = FastSymbol(a$, ")", True) Exit Function Else Nosuchvariable s1$ Exit Function End If ElseIf w3 = 5 Or w3 = 7 Then If neoGetArray(bstack, s1$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s1$, w2, a$) Then Exit Function If myVarType(var(w1), vbString) Then r = CVar(pppp.item(w2)) If myVarType(r, vbString) Then If dn = 1 Then If CompareStr3(var(w1), r) = -1 Then r = var(w1) ElseIf dn = 2 Then If CompareStr3(var(w1), r) = 1 Then r = var(w1) Else r = CompareStr3(var(w1), r) End If Else r = 0 NeedString IsCompMinMax = False Exit Function End If Else Select Case dn Case 1 If var(w1) < pppp.itemnumeric(w2) Then r = var(w1) Else r = pppp.itemnumeric(w2) End If Case 2 If var(w1) > pppp.itemnumeric(w2) Then r = var(w1) Else r = pppp.itemnumeric(w2) End If Case Else If var(w1) = 0 Then If pppp.itemnumeric(w2) = 0 Then r = 0 Else r = Sgn(0 - MyRound(pppp.itemnumeric(w2), 10)) End If Else r = Sgn(MyRound(((var(w1) - pppp.itemnumeric(w2)) / var(w1)), 10)) End If End Select End If IsCompMinMax = FastSymbol(a$, ")", True) Else Nosuchvariable s1$ Exit Function End If ElseIf w3 = 3 And ow1 = 1 Then If myVarType(var(w1), vbString) Then GoTo s12 End If MissingStrVar ElseIf w3 = 6 And ow1 = 1 Then If myVarType(var(w1), vbString) Then GoTo s11 End If MissingStrVar Else MissingnumVar Exit Function End If Else Nosuchvariable s$ Exit Function End If ElseIf dd = 2 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w1, a$) Then Exit Function If Not FastSymbol(a$, ",") Then MissingnumVar: Exit Function w3 = Abs(IsLabel(bstack, a$, s1$)) If w3 = 1 Or w3 = 3 Or w3 = 4 Then If GetVar(bstack, s1$, w2) Then Select Case dn Case 1 If myVarType(var(w2), vbString) Then r = pppp.item(w1) If myVarType(r, vbString) Then If r > var(w2) Then r = var(w2) End If Else r = 0 NeedString IsCompMinMax = False Exit Function End If ElseIf pppp.itemnumeric(w1) < var(w2) Then r = pppp.itemnumeric(w1) Else r = var(w2) End If Case 2 If myVarType(var(w2), vbString) Then r = pppp.item(w1) If myVarType(r, vbString) Then If r < var(w2) Then r = var(w2) End If Else r = 0 NeedString IsCompMinMax = False Exit Function End If ElseIf pppp.itemnumeric(w1) > var(w2) Then r = pppp.itemnumeric(w1) Else r = var(w2) End If Case Else If myVarType(var(w2), vbString) Then r = pppp.item(w1) If myVarType(r, vbString) Then r = CompareStr3(r, var(w2)) Else r = 0 NeedString IsCompMinMax = False Exit Function End If ElseIf pppp.itemnumeric(w1) = 0 Then If var(w2) = 0 Then r = 0 Else r = Sgn(0 - MyRound(var(w2), 10)) End If Else r = Sgn(MyRound(((pppp.item(w1) - var(w2)) / pppp.item(w1)), 10)) End If End Select IsCompMinMax = FastSymbol(a$, ")", True) Else MissingnumVar Exit Function End If ElseIf w3 >= 5 And w3 < 8 Then If neoGetArray(bstack, s1$, pppp1) Then If Not NeoGetArrayItem(pppp1, bstack, s1$, w2, a$) Then Exit Function If pppp.ItemTypeNum(w1) = vbString And w3 = 6 Then GoTo st12321 Else Select Case dn Case 1 If pppp.itemnumeric(w1) < pppp1.itemnumeric(w2) Then r = pppp.itemnumeric(w1) Else r = pppp1.itemnumeric(w2) End If Case 2 If pppp.itemnumeric(w1) > pppp1.itemnumeric(w2) Then r = pppp.itemnumeric(w1) Else r = pppp1.itemnumeric(w2) End If Case Else If pppp.itemnumeric(w1) = 0 Then If pppp1.itemnumeric(w2) = 0 Then r = 0 Else r = Sgn(0 - MyRound(pppp1.itemnumeric(w2), 10)) End If Else r = Sgn(MyRound(((pppp.itemnumeric(w1) - pppp1.itemnumeric(w2)) / pppp.itemnumeric(w1)), 10)) End If End Select End If IsCompMinMax = FastSymbol(a$, ")", True) Else MissingnumVar Exit Function End If Else MissingnumVar Exit Function End If Else MissingnumVar Exit Function End If ElseIf w1 = 3 Then If GetVar(bstack, s$, w1) Then If Not FastSymbol(a$, ",") Then MissingnumVar: Exit Function w3 = Abs(IsLabel(bstack, a$, s1$)) If w3 = 6 Then s11: If Not neoGetArray(bstack, s1$, pppp) Then MissingStrVar:: Exit Function If Not NeoGetArrayItem(pppp, bstack, s1$, w2, a$) Then Exit Function r = pppp.item(w2) If dn = 1 Then If CompareStr3(var(w1), r) = -1 Then r = var(w1) ElseIf dn = 2 Then If CompareStr3(var(w1), r) = 1 Then r = var(w1) Else r = CompareStr3(var(w1), r) 'StrComp(var(w1), CStr(pppp.item(w2))) End If ElseIf w3 = 1 Then If Not GetVar(bstack, s1$, w2) Then MissingStrVar: Exit Function If Not myVarType(var(w2), vbString) Then MissingStrVar: Exit Function GoTo s13 ElseIf w3 = 3 Then s12: If Not GetVar(bstack, s1$, w2) Then MissingStrVar: Exit Function s13: If dn = 1 Then If var(w1) < var(w2) Then r = var(w1) Else r = var(w2) ElseIf dn = 2 Then If var(w1) > var(w2) Then r = var(w1) Else r = var(w2) Else If w1 <> w2 Then r = CompareStr3(var(w1), var(w2)) ' StrComp(var(w1), var(w2)) End If ElseIf w3 = 5 Then GoTo s11 Else MissFuncParameterStringVarMacro a$ Exit Function End If IsCompMinMax = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w1, a$) Then Exit Function If Not FastSymbol(a$, ",") Then MissingnumVar:: Exit Function w3 = Abs(IsLabel(bstack, a$, s1$)) If w3 = 6 Or w3 = 5 Then If Not neoGetArray(bstack, s1$, pppp1) Then MissingStrVar: Exit Function If Not NeoGetArrayItem(pppp1, bstack, s1$, w2, a$) Then Exit Function If pppp.ItemTypeNum(w1) = vbString And pppp1.ItemTypeNum(w2) = vbString Then st12321: If dn = 1 Then If CompareStr3(pppp.item(w1), pppp1.item(w2)) = -1 Then r = pppp.item(w1) Else r = pppp1.item(w2) End If ElseIf dn = 2 Then If CompareStr3(pppp.item(w1), pppp1.item(w2)) = 1 Then r = pppp.item(w1) Else r = pppp1.item(w2) End If Else r = CompareStr3(pppp.item(w1), pppp1.item(w2)) End If Else MissingStrVar Exit Function End If ElseIf w3 = 1 Then If Not GetVar(bstack, s1$, w3) Then MissingStrVar: Exit Function If Not myVarType(var(w3), vbString) Then MissingStrVar: Exit Function GoTo s14 ElseIf w3 = 3 Then If Not GetVar(bstack, s1$, w3) Then: Exit Function s14: r = pppp.item(w1) If Not myVarType(r, vbString) Then MissingStrVar: Exit Function If dn = 1 Then If r > var(w3) Then r = var(w3) ElseIf dn = 2 Then If r < var(w3) Then r = var(w3) Else r = CompareStr3(r, var(w3)) End If Else MissFuncParameterStringVarMacro a$ Exit Function End If IsCompMinMax = FastSymbol(a$, ")", True) Else missParam a$ End If Else missParam a$ End If End Function Private Function IsEval(v$, bstack As basetask, a$, r As Variant) As Boolean Dim p As Variant, anything As Object, w3 As Long, w2 As Long, w1 As Long, pp As Variant, rB As Byte, ri As Integer, dn As Long, s$, ss$ Dim db As Double, pppp As iBoxArray, IsGroupOnly As Group, ReadAsSingle As Boolean, ReadInt64 As Boolean, ds As Single Dim ThisGroup As Group, t$, usehandler As mHandler, usehandler1 As mHandler, ReadAsCurrency As Boolean w1 = 1 t$ = aheadstatus(a$, False, w1) s$ = Left$(a$, w1) ss$ = s$ If CheckGroupOrPointer(bstack, s$, IsGroupOnly, pppp, w2) Then If Not IsGroupOnly Is Nothing Then If Not pppp Is Nothing And w2 <> -2 Then reentry1: a$ = Mid$(a$, w1 + 1 - Len(s$)) If IsGroupOnly.HasParameters Then If Mid$(a$, 1, 1) <> "," Then IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, w2) = 1 r = bstack.LastValue If lookOne(a$, ",") And Typename(bstack.lastobj) = mHdlr Then GoTo handlehandlers Exit Function Else Mid$(a$, 1, 1) = "(" IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, w2) = 1 r = bstack.LastValue End If Else IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, w2) = 1 r = bstack.LastValue If Typename(bstack.lastobj) = mHdlr Then GoTo handlehandlers If lookOne(a$, ",") And Typename(bstack.lastobj) = mHdlr Then GoTo handlehandlers IsEval = FastSymbol(a$, ")", True) And IsEval End If Else If IsGroupOnly.HasParameters Then If Mid$(a$, w1 - Len(s$) + 1, Len(s$)) <> ")" Then a$ = Mid$(a$, w1 + 1 - Len(s$)) ri = False If Mid$(a$, 1, 1) = "," Then If IsGroupOnly.HasStrValue Then Mid$(a$, 1, 1) = Chr$(1) Else Mid$(a$, 1, 1) = Chr$(0) End If ri = True End If Set bstack.lastpointer = IsGroupOnly If IsGroupOnly.HasStrValue And Left$(t$, 1) <> "N" Then If IsStr1(bstack, a$, ss$) Then If ri Then IsEval = IsExp(bstack, ss$, r) ElseIf FastSymbol(a$, ")") Then IsEval = IsExp(bstack, ss$, r) End If Else Exit Function End If Else If ri Then IsEval = IsNumber(bstack, a$, r) ElseIf IsNumber(bstack, a$, r) Then IsEval = FastSymbol(a$, ")") End If Exit Function End If Else If IsGroupOnly.HasStrValue And Left$(t$, 1) <> "N" Then If IsStr1(bstack, a$, ss$) Then IsEval = IsExp(bstack, ss$, r) Else Exit Function End If Else IsEval = IsNumber(bstack, a$, r) End If If Typename(bstack.lastobj) = mHdlr Then GoTo handlehandlers IsEval = FastSymbol(a$, ")", True) And IsEval End If Else If IsGroupOnly.HasStrValue And Left$(t$, 1) <> "N" Then If IsStr1(bstack, a$, ss$) Then If FastSymbol(a$, ")") Then IsEval = IsExp(bstack, ss$, r) If Typename(bstack.lastobj) = mHdlr Then GoTo handlehandlers End If End If ElseIf IsGroupOnly.HasValue Then Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set pppp.item(0) = IsGroupOnly w2 = 0 GoTo reentry1 Else IsEval = IsNumber(bstack, a$, r) If Typename(bstack.lastobj) = mHdlr Then GoTo handlehandlers IsEval = FastSymbol(a$, ")", True) And IsEval End If End If End If ' If Not bstack.lastobj Is Nothing Then GoTo conthere Exit Function Else a$ = Mid$(a$, w1 + 1 - Len(s$)) GoTo getgroup End If ElseIf IsExp(bstack, ss$, p) Then If Len(ss$) > 0 Then Mid$(a$, w1 + 1 - Len(ss$), Len(ss$)) = ss$ Mid$(a$, 1, w1 + 1 - Len(ss$)) = space$(w1 - Len(ss$)) If bstack.lastobj Is Nothing Then If VarType(p) = vbString Then SwapString2Variant s$, p GoTo JUMPHERE Else SwapVariant p, r IsEval = FastSymbol(a$, ")", True) Exit Function End If End If handlehandlers: w1 = 0 s$ = vbNullString If Typename(bstack.lastobj) = mHdlr Then Set anything = bstack.lastobj Set usehandler = bstack.lastobj If usehandler.IamEnum Then r = usehandler.index_cursor If usehandler.t1 = 0 Then If IsObject(usehandler.objref) Then Set bstack.lastobj = usehandler.objref Else Set bstack.lastobj = Nothing End If Else Set bstack.lastobj = Nothing End If IsEval = FastSymbol(a$, ")", True) Exit Function ElseIf Not CheckLastHandlerOrIterator(anything, w3) Then InternalError IsEval = False Exit Function End If Set usehandler = anything With usehandler If .t1 = 1 Or .t1 = 5 Then If FastSymbol(a$, ",") Then If IsExp(bstack, a$, pp, flatobject:=True, nostring:=True) Then w3 = CLng(pp) If w3 < 0 Or w3 >= .objref.Count Then indexout a$ Exit Function End If w1 = True End If End If On Error GoTo there12 If w3 >= 0 Then .objref.index = w3 .objref.Done = True End If If .objref.Done Then If w1 Then r = .objref.KeyToNumber Set bstack.lastobj = Nothing ElseIf FastSymbol(a$, "!") Then r = .objref.index Set bstack.lastobj = Nothing Else If .objref.IsObj Then r = rValue(bstack, usehandler.objref.ValueObj) '' bstack.lastobj is .objref.ValueObj Else r = MyVal(.objref.Value) Set bstack.lastobj = Nothing End If End If IsEval = FastSymbol(a$, ")", True) End If there12: On Error GoTo 0 Set anything = Nothing Exit Function ElseIf .t1 = 2 Then ' p is offset for items not bytes If FastSymbol(a$, ",") Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then w1 = Abs(Asc(v$) < 128) If IsLabelSymbolNew(a$, "ΩΣ", "AS", w1) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w1) Then pp = 1 ElseIf IsLabelSymbolNew(a$, "ΑΚΕΡΑΙΟΣ", "INTEGER", w1) Then pp = 2 ElseIf IsLabelSymbolNew(a$, "ΜΑΚΡΥΣ", "LONG", w1) Then If IsLabelSymbolNew(a$, "ΜΑΚΡΥΣ", "LONG", w1) Then pp = 8 ReadInt64 = True Else pp = 4 End If ElseIf IsLabelSymbolNew(a$, "ΔΙΠΛΟΣ", "DOUBLE", w1) Then pp = 8 ElseIf IsLabelSymbolNew(a$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", w1) Then pp = 8 ReadAsCurrency = True ElseIf IsLabelSymbolNew(a$, "ΑΠΛΟΣ", "SINGLE", w1) Then pp = 4 ReadAsSingle = True Else SyntaxError Exit Function End If ' use another itemsize ' p is byte offset w2 = .objref.GetBytePtr(p) absolute: pp = Abs(pp) If .objref.ValidArea(w2, pp) Then Select Case pp Case 1 GetMem1 w2, rB r = CCur(rB) Case 2 GetMem2 w2, ri r = CCur(UINT(CLng(ri))) Case 4 If ReadAsSingle Then GetMemS w2, ds r = ds Else GetMem4 w2, dn r = CCur(uintnew1(dn)) End If Case 8 If ReadAsCurrency Then r = MemCur(w2) ElseIf ReadInt64 Then r = cInt64(0) CopyMemory ByVal VarPtr(r) + 8, ByVal w2, 8 r = CDec(r) If r < 0 Then r = r + maxlonglong Else GetMem8 w2, db r = db End If Case 16 ' ???? End Select Else GoTo errortext End If Else firstpram: Set anything = .objref With anything pp = .ItemSize ReadAsSingle = .WhatIsBasicItem = vbSingle ReadInt64 = .WhatIsBasicItem = 20 ReadAsCurrency = .WhatIsBasicItem = vbCurrency If FastSymbol(a$, "!") Then If FastPureLabel(a$, s$) Then If .structref Is Nothing Then MyEr "No structure exist for buffer", "Δεν υπάρχει δομή για την διάρθρωση" IsEval = False Exit Function End If If .structref.Find(myUcase(s$, True)) Then pp = Abs(.structref.sValue) If pp = 4 Then ReadAsSingle = .structref.KeyTypeValue = vbSingle ElseIf pp = 8 Then ReadInt64 = .structref.sValue < 0 ReadAsCurrency = .structref.KeyTypeValue = vbCurrency End If If FastSymbol(a$, "!") Then If Not IsExp(bstack, a$, r, , True) Then GoTo errortext1 ElseIf r >= 0 Then w2 = cUlng(uintnew(.GetPtr(p)) + .structref.StructOffset + Int(r) * pp) GoTo absolute Else NegativeIndex a$ GoTo errortext1 End If Else w2 = cUlng(uintnew(.GetPtr(p)) + .structref.StructOffset) GoTo absolute End If Else unknownoffset a$, s$ GoTo errortext1 End If End If Else If Not .structref Is Nothing Then If .structref.Count > 0 Then .structref.ToStart pp = .structref.sValue ReadAsCurrency = .structref.KeyTypeValue = vbCurrency End If End If End If Select Case Abs(pp) Case 1 If .ValidArea2(p, 1) Then GetMem1 .GetPtr(p), rB r = CCur(rB) Else GoTo errortext End If Case 2 If .ValidArea2(p, 2) Then GetMem2 .GetPtr(p), ri r = CCur(UINT(CLng(ri))) Else GoTo errortext End If Case 8 If .ValidArea2(p, 8) Then If ReadAsCurrency Then w2 = .GetPtr(p) r = MemCur(w2) ElseIf ReadInt64 Or pp < 0 Then w2 = .GetPtr(p) r = cInt64(0) CopyMemory ByVal VarPtr(r) + 8, ByVal w2, 8 r = CDec(r) If r < 0 Then r = r + maxlonglong Else GetMem8 .GetPtr(p), db r = db End If Else GoTo errortext End If Case 4 If .ValidArea2(p, 4) Then If ReadAsSingle Then GetMemS .GetPtr(p), ds r = ds Else GetMem4 .GetPtr(p), dn r = CCur(uintnew1(dn)) End If Else errortext: wrongsizeOrposition a$ errortext1: Set anything = Nothing Exit Function End If End Select End With End If IsEval = FastSymbol(a$, ")", True) Set anything = Nothing Exit Function End If Else p = 0 GoTo firstpram End If ElseIf .t1 = 3 Then If CheckDeepAny(anything) Then 'If TypeOf anything Is mStiva Then 'End If End If GoTo there1234459 ElseIf .t1 = 4 Then Set usehandler1 = New mHandler If w3 = -1 Then usehandler1.index_cursor = usehandler.index_cursor Set usehandler1.objref = usehandler.objref usehandler1.index_start = usehandler.index_start usehandler1.sign = usehandler.sign If myVarType(usehandler1.index_cursor, vbString) Then r = usehandler1.index_cursor Else r = usehandler1.index_cursor * usehandler1.sign End If Else usehandler1.index_cursor = usehandler.objref.Value Set usehandler1.objref = usehandler.objref usehandler1.index_start = usehandler.objref.index r = usehandler1.index_cursor End If usehandler1.t1 = 4 Set bstack.lastobj = usehandler1 IsEval = FastSymbol(a$, ")", True) Exit Function Else there1234459: ' eval for objects??? r = 0 IsEval = FastSymbol(a$, ")", True) Exit Function End If Set anything = Nothing End With Set usehandler = Nothing ElseIf Not bstack.lastpointer Is Nothing Then getgroup: If Not bstack.lastpointer.IamApointer Then Set bstack.lastpointer = bstack.lastobj If bstack.lastpointer.link Is Nothing Then If bstack.lastpointer.IamFloatGroup Then Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set pppp.item(0) = bstack.lastpointer Set bstack.lastpointer = Nothing If pppp.item(0).HasParameters Then FastSymbol a$, "," IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, 0) = 1 r = bstack.LastValue Exit Function Else FastSymbol a$, "," IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, 0) = 1 r = bstack.LastValue GoTo conthere End If End If SyntaxError IsEval = False Exit Function ElseIf bstack.lastpointer.link.IamFloatGroup Then getgroup2: Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set pppp.item(0) = bstack.lastpointer Set bstack.lastpointer = Nothing If pppp.item(0).link.HasParameters Then If pppp.item(0).link.HasStrValue Then ' Set pppp.item(0) = pppp.item(0).link Mid$(a$, 1, 1) = "(" 'FastSymbol A$, "," IsEval = SpeedGroup(bstack, pppp, "VAL$", "", a$, 0) = 1 Else FastSymbol a$, "," IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, 0) = 1 End If r = bstack.LastValue Exit Function Else FastSymbol a$, "," IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, 0) = 1 r = bstack.LastValue GoTo conthere End If Exit Function Else 'Set bstack.lastpointer = bstack.lastobj If Not bstack.lastpointer.HasValue Then If Not bstack.lastpointer.link Is Nothing Then Set bstack.lastpointer = bstack.lastpointer.link ' Set bstack.lastobj = Nothing End If End If If lookOne(a$, ",") Then If bstack.lastpointer.HasStrValue Then Mid$(a$, 1, 1) = Chr(1) If IsStr1(bstack, a$, s$) Then r = "" SwapString2Variant s$, r IsEval = True Exit Function End If Else Mid$(a$, 1, 1) = Chr(0) If IsNumber(bstack, a$, r) Then IsEval = True Exit Function End If End If Else If IsNumber(bstack, Chr$(0) + "'", r) Then GoTo conthere End If End If End If ElseIf Typename(bstack.lastobj) = mGroup Then Set ThisGroup = bstack.lastobj If ThisGroup.IamApointer Then Set bstack.lastobj = ThisGroup Set bstack.lastpointer = ThisGroup GoTo getgroup ElseIf ThisGroup.HasValue Then Set bstack.lastobj = Nothing Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set pppp.item(0) = ThisGroup If ThisGroup.HasParameters Then FastSymbol a$, "," IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, 0) = 1 r = bstack.LastValue Exit Function Else FastSymbol a$, "," IsEval = SpeedGroup(bstack, pppp, "VAL", "", a$, 0) = 1 r = bstack.LastValue GoTo conthere End If Else r = r - r IsEval = FastSymbol(a$, ")") Exit Function End If End If missParam a$ ElseIf IsStrExp(bstack, ss$, s$) Then If Len(ss$) > 0 Then Mid$(a$, w1 + 1 - Len(ss$), Len(ss$)) = ss$ Mid$(a$, 1, w1 + 1 - Len(ss$)) = space$(w1 - Len(ss$)) JUMPHERE: If FastSymbol(a$, ".") Then If lookOne(a$, ")") Then If Not IsExp(bstack, s$, r) Then wrongweakref a$ Else IsEval = FastSymbol(a$, ")", True) End If Else a$ = s$ + "." + a$ If Not IsExp(bstack, a$, r) Then wrongweakref a$ Else IsEval = FastSymbol(a$, ")", True) End If End If Else If Not IsExp(bstack, s$, r) Then wrongexprinstring a$ Else conthere: IsEval = FastSymbol(a$, ")", True) End If End If Else missParam a$ End If End Function Private Function IsVal(bstack As basetask, a$, r As Variant, Eng As Boolean) As Boolean Dim s$, ex$, dd As Long, pp As Variant, Lang As Long If Eng Then Lang = 1 If IsExp(bstack, a$, r) Then If MemInt(VarPtr(r)) = vbString Then SwapString2Variant s$, r Else GoTo isnum End If enterasstring: On Error Resume Next If FastSymbol(a$, "!", False) Then dd = ValidNumberOnly(s$, r, False) IsVal = FastSymbol(a$, ")", True) Err.Clear Exit Function ElseIf FastSymbol(a$, ",") Then If IsExp(bstack, a$, pp, flatobject:=True) Then If MemInt(VarPtr(pp)) = vbString Then SwapString2Variant ex$, pp If Len(ex$) <> 1 Then If Len(ex$) = 0 Then dd = 46 Else dd = AscW(NowDec$) Else dd = AscW(ex$) End If If InStr(s$, ".") > 0 And dd <> 46 Then s$ = Replace(s$, ".", "*", 1, 1) End If s$ = Replace(s$, ChrW(dd), ".", 1, 1) dd = 46 Else pp = Fix(pp) dd = AscW(GetlocaleString2(14, CLng(pp))) If InStr(s$, ".") > 0 And dd <> 46 Then s$ = Replace(s$, ".", "*", 1, 1) End If s$ = Replace(s$, ChrW(dd), ".", 1, 1) dd = 46 End If Else If lookOne(a$, ",") Then s$ = Replace(s$, ChrW(dd), ".", 1, 1) dd = 46 Else expecteddecimal a$ Err.Clear Exit Function End If End If Else dd = AscW(GetDeflocaleString(14)) End If If MaybeIsSymbol(s$, "ΑαΨψTtFf") Then If CDbl(pp) = 0 Then If Fast3NoSpace(s$, "ΑΛΗΘΕΣ", 6, "ΑΛΗΘΗΣ", 6, "TRUE", 4, 6) Then r = CBool(True) ElseIf Fast3NoSpace(s$, "ΨΕΥΔΕΣ", 6, "ΨΕΥΔΗΣ", 6, "FALSE", 5, 6) Then r = CBool(False) Else r = 0 End If Else If pp = 1032 Then If Fast3NoSpace(s$, "ΑΛΗΘΕΣ", 6, "ΑΛΗΘΗΣ", 6, vbNullString, 0, 6) Then r = CBool(True) ElseIf Fast3NoSpace(s$, "ΨΕΥΔΕΣ", 6, "ΨΕΥΔΗΣ", 6, vbNullString, 0, 6) Then r = CBool(False) Else r = 0 End If Else If Fast3NoSpace(s$, "TRUE", 4, vbNullString, 0, vbNullString, 0, 4) Then r = CBool(True) ElseIf Fast3NoSpace(s$, "FALSE", 5, vbNullString, 0, vbNullString, 0, 5) Then r = CBool(False) Else r = 0 End If End If End If ElseIf dd = 46 Then If Not VALFUNC((s$), r) Then r = val(s$) dd = ValidNumberOnlyClean(s$, r, False) ElseIf Abs(r) = 1 Then If InStr(UCase(s$), ".#INF") > 0 Then dd = ValidNumberOnlyClean(Replace(s$, ChrW(dd), "."), r, False) If dd = -1 Then Else If r < 0 Then r = -Infinity Else r = Infinity End If End If End If End If Else If Not VALFUNC(Replace(s$, ChrW(dd), "."), r) Then dd = ValidNumberOnlyClean(Replace(s$, ChrW(dd), "."), r, False) ElseIf Abs(r) = 1 Then If InStr(UCase(s$), ".#INF") > 0 Then dd = ValidNumberOnlyClean(Replace(s$, ChrW(dd), "."), r, False) If dd = -1 Then Else If r < 0 Then r = -Infinity Else r = Infinity End If End If End If End If End If If Err.Number > 0 Then Err.Clear WrongArgument a$ Exit Function End If On Error GoTo a100 If FastSymbol(a$, ",") Then Dim mm As mStiva Set mm = NewmStiva Dim oldm As mStiva Set oldm = bstack.soros Set bstack.Sorosref = mm dd = ValidNumberOnlyClean(s$, r, Len(ex$) > 1) If dd > 2 And Abs(r) = 1 Then If Mid$(s$, dd - 1, 2) = ".#" Then If UCase(Mid$(s$, dd + 1, 3)) = "INF" Then If r >= 0 Then r = Infinity() Else r = -Infinity() End If dd = dd + 4 End If End If End If mm.PushVal dd FastSymbol a$, "&" If Not MyRead(1, bstack, a$, Lang) Then IsVal = False Set bstack.Sorosref = oldm Exit Function End If Set bstack.Sorosref = oldm End If IsVal = FastSymbol(a$, ")", True) ElseIf False Then isnum: If FastSymbol(a$, "->", False, 2) Then Set bstack.lastobj = Nothing Set bstack.lastpointer = Nothing If FastSymbol(a$, "0@", , 2) Then On Error GoTo a500 r = CDec(r) IsVal = FastSymbol(a$, ")", True) ElseIf FastSymbol(a$, "0#", , 2) Then On Error GoTo a400 r = CCur(r) IsVal = FastSymbol(a$, ")", True) ElseIf FastSymbol(a$, "0&&", , 3) Then On Error GoTo a102 r = cInt64(r) IsVal = FastSymbol(a$, ")", True) ElseIf FastSymbol(a$, "0%", , 2) Then On Error GoTo a100 r = CLng(r) IsVal = FastSymbol(a$, ")", True) ElseIf FastSymbol(a$, "0&", , 2) Then On Error GoTo a101 r = CLng(r) IsVal = FastSymbol(a$, ")", True) ElseIf FastSymbol(a$, "0~", , 2) Then On Error GoTo a200 r = CSng(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "", "0UD", 1) Then On Error GoTo a450 r = CDate(CDbl(r)) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "", "0UB", 1) Then On Error GoTo a600 r = CByte(Abs(r) Mod 256) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "0U", "0U", Lang) Then On Error GoTo a600 Set bstack.lastobj = Module13.CreateBigInteger(format(Int(r), "0")) r = 0 IsVal = FastSymbol(a$, ")", True) Exit Function ElseIf FastSymbol(a$, "0") Then On Error GoTo a300 r = CDbl(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΑΡΙΘΜΟΣ", "DECIMAL", Lang) Then On Error GoTo a500 r = CDec(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then On Error GoTo a300 r = CDbl(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΑΠΛΟΣ", "SINGLE", Lang) Then r = CSng(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΛΟΓΙΚΟΣ", "BOOLEAN", Lang) Then r = CBool(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΜΑΚΡΥΣ ΜΑΚΡΥΣ", "LONG LONG", Lang) Then On Error GoTo a102 r = cInt64(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΜΑΚΡΥΣ", "LONG", Lang) Then On Error GoTo a101 r = CLng(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then On Error GoTo a100 r = CInt(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", Lang) Then On Error GoTo a600 r = CByte(Abs(r) Mod 256) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", Lang) Then On Error GoTo a450 r = CDate(CDbl(r)) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then On Error GoTo a400 r = CCur(r) IsVal = FastSymbol(a$, ")", True) ElseIf IsLabelSymbolNew(a$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang) Then On Error GoTo a600 Set bstack.lastobj = Module13.CreateBigInteger(format(Int(r), "0")) r = 0 IsVal = FastSymbol(a$, ")", True) Exit Function ElseIf Not bstack.lastobj Is Nothing Then IsVal = FastSymbol(a$, ")", True) Else CantFind "0@ 0# 0&& 0& 0~ 0% 0" Exit Function End If Set bstack.lastobj = Nothing End If Else missParam a$ End If Exit Function a100: IsVal = False If Err.Number = 6 Then OverflowValue vbInteger Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a101: IsVal = False If Err.Number = 6 Then OverflowValue vbLong Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a102: IsVal = False If Err.Number = 6 Then OverflowValue 20 Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a200: IsVal = False If Err.Number = 6 Then OverflowValue vbSingle Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a300: IsVal = False If Err.Number = 6 Then OverflowValue vbDouble Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a400: IsVal = False If Err.Number = 6 Then OverflowValue vbCurrency Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a450: IsVal = False If Err.Number = 6 Then OverflowValue vbDate Else MyEr Err.Description, Err.Description End If Err.Clear Exit Function a500: IsVal = False If Err.Number = 6 Then MyEr "Overflow Decimal", "υπερχείλιση Δεκαδικού" Else MyEr Err.Description, Err.Description End If a600: Err.Clear End Function Private Function IsRinstr(bstack As basetask, a$, r As Variant, sg As Variant, Lang As Long) As Boolean Dim s$, s1$, par As Boolean If IsStrExp(bstack, a$, s$) Then If FastSymbol(a$, ",") Then If IsStrExp(bstack, a$, s1$) Then If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, r, , True) Then missParam a$ Exit Function End If par = True End If If IsLabelSymbolNew(a$, "ΩΣ", "AS", Lang) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", Lang) Then If par Then If r < 0 Then r = LenB(s$) + r + 1 If r < 0 Then r = 1 r = LenB(s$) - r + 1 If r < 0 Then r = 1 If r > LenB(s$) Then r = LenB(s$) Else r = LenB(s$) End If r = rinstrb(s$, s1$, r) Else SyntaxError Exit Function End If Else If par Then If r < 0 Then r = Len(s$) + r + 1 If r < 0 Then r = 1 r = Len(s$) - r + 1 If r < 0 Then r = 1 If r > Len(s$) Then r = Len(s$) Else r = Len(s$) End If r = InStrRev(s$, s1$, r) End If IsRinstr = FastSymbol(a$, ")", True) Else missParam a$ End If Else missParam a$ End If Else missParam a$ End If End Function Private Function IsInstr(bstack As basetask, a$, r As Variant, sg As Variant, Lang As Long) As Boolean Dim s$, s1$ If IsStrExp(bstack, a$, s$, False) Then If FastSymbol(a$, ",") Then If IsStrExp(bstack, a$, s1$, False) Then If FastSymbol(a$, ",") Then If Not IsExp(bstack, a$, r, , True) Then missParam a$ Exit Function End If Else r = 1 End If If IsLabelSymbolNew(a$, "ΩΣ", "AS", Lang) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", Lang) Then r = InStrB(r, s$, s1$) Else SyntaxError Exit Function End If Else r = InStr(r, s$, s1$) End If IsInstr = FastSymbol(a$, ")", True) Else missParam a$ End If Else missParam a$ End If Else missParam a$ End If End Function Private Function IsGroupCount(bstack As basetask, a$, r As Variant) As Boolean Dim s$, w2 As Long, pppp As iBoxArray Select Case Abs(IsLabelBig(bstack, a$, s$)) Case 1 If getvar2(bstack, s$, w2) Then If VarTypeName(var(w2)) = mGroup Then If var(w2).IamApointer Then Else r = var(w2).PrepareSoros(var(), "").Total End If Else MissingGroup Exit Function End If IsGroupCount = FastSymbol(a$, ")", True) Exit Function Else Nosuchvariable s$ End If Case 5 If Not neoGetArray(bstack, s$, pppp) Then Exit Function If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If pppp.arr Then If pppp.ItemType(w2) = mGroup Then r = 0 If pppp.item(w2).IamApointer Then Else r = pppp.item(w2).PrepareSoros(var(), "").Total End If Else MissingGroup Exit Function End If End If IsGroupCount = FastSymbol(a$, ")") Case Else MissingGroup End Select End Function Private Function IsParIndex(bstack As basetask, a$, r As Variant) As Boolean Dim s$, w1 As Long, w2 As Long, dn As Long, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then If Not FastSymbol(a$, ",") Then: missParam a$: Exit Function w2 = Abs(IsLabel(bstack, a$, s$)) ' ONLY AN ARITHMETIC VAR. If w2 = 1 Or w2 = 4 Then If GetVar(bstack, s$, w2) Then dn = var(w2) r = var(w1).ParagraphOrder(dn) '' Else Nosuchvariable s$ IsParIndex = False Exit Function End If Else MissingnumVar IsParIndex = False Exit Function End If Else MissingDoc IsParIndex = False Exit Function End If IsParIndex = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If Not FastSymbol(a$, ",") Then: missParam a$: Exit Function w1 = Abs(IsLabel(bstack, a$, s$)) ' ONLY AN ARITHMETIC VAR.. If w1 = 1 Or w1 = 2 Then If GetVar(bstack, s$, w1) Then dn = var(w1) r = pppp.item(w2).ParagraphOrder(dn) Else Nosuchvariable s$ IsParIndex = False Exit Function End If Else Nosuchvariable s$ IsParIndex = False Exit Function End If Else MissingDoc IsParIndex = False Exit Function End If IsParIndex = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If End Function Private Function IsForwBack(ByVal dd As Long, bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, w2 As Long, s$, dn As Long, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then If Not FastSymbol(a$, ",") Then: missParam a$: Exit Function w2 = Abs(IsLabel(bstack, a$, s$)) ' ONLY AN ARITHMETIC VAR.. If w2 = 1 Or w2 = 4 Then If GetVar(bstack, s$, w2) Then dn = var(w2) If dd = 1 Then var(w1).BackStep dn var(w1).BackMove = True Else var(w1).BackMove = False var(w1).Advance dn End If r = Not var(w1).IsEmpty ' r = var(w1).ParagraphOrder(dn) '' var(w2) = dn Else Nosuchvariable s$ IsForwBack = False Exit Function End If Else MissingnumVar IsForwBack = False Exit Function End If Else MissingDoc IsForwBack = False Exit Function End If IsForwBack = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If Not FastSymbol(a$, ",") Then: missParam a$: Exit Function w1 = Abs(IsLabel(bstack, a$, s$)) ' ONLY AN ARITHMETIC VAR.. If w1 = 1 Or w1 = 2 Then If GetVar(bstack, s$, w1) Then dn = var(w1) If dd = 1 Then pppp.item(w2).BackStep dn pppp.item(w2).BackMove = True Else pppp.item(w2).BackMove = False pppp.item(w2).Advance dn End If r = Not pppp.item(w2).IsEmpty '' r = pppp.item(w2).ParagraphOrder(dn) var(w1) = dn Else Nosuchvariable s$ IsForwBack = False Exit Function End If Else Nosuchvariable s$ IsForwBack = False Exit Function End If Else MissingDoc IsForwBack = False Exit Function End If IsForwBack = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If End Function Private Function IsDocPar(bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, w2 As Long, s$, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 3 Then If GetVar(bstack, s$, w1) Then If VarTypeName(var(w1)) = doc Then r = var(w1).DocParagraphs Else r = 0 End If IsDocPar = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If ElseIf w1 = 6 Then If neoGetArray(bstack, s$, pppp) Then If Not NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then Exit Function If pppp.ItemType(w2) = doc Then r = pppp.item(w2).DocParagraphs Else r = 0 End If Else End If IsDocPar = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ End If End Function Private Function IsMaxData(bstack As basetask, a$, r As Variant) As Boolean Dim p As Variant, s$ If IsExp(bstack, a$, r, flatobject:=True) Then If myVarType(r, vbString) Then GoTo there Do While FastSymbol(a$, ",") If Not IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then MissNumExpr: Exit Function If p > r Then r = p Loop IsMaxData = FastSymbol(a$, ")", True) ElseIf IsStrExp(bstack, a$, s$, False) Then r = vbNullString SwapString2Variant s$, r there: Do While FastSymbol(a$, ",") If Not IsStrExp(bstack, a$, s$, False) Then MissStringExpr: Exit Function If s$ > r Then SwapString2Variant s$, r Loop IsMaxData = FastSymbol(a$, ")", True) Else SyntaxError End If End Function Private Function IsMinData(bstack As basetask, a$, r As Variant) As Boolean Dim p As Variant, s$ If IsExp(bstack, a$, r, flatobject:=True) Then If myVarType(r, vbString) Then GoTo there Do While FastSymbol(a$, ",") If Not IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then MissNumExpr: Exit Function If p < r Then r = p Loop IsMinData = FastSymbol(a$, ")", True) ElseIf IsStrExp(bstack, a$, s$, False) Then r = vbNullString SwapString2Variant s$, r there: Do While FastSymbol(a$, ",") If Not IsStrExp(bstack, a$, s$, False) Then MissStringExpr: Exit Function If s$ < r Then SwapString2Variant s$, r Loop IsMinData = FastSymbol(a$, ")", True) Else SyntaxError End If End Function Private Function IsProperty(bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, s$, w2 As Long, pppp As iBoxArray w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 1 Or w1 = 5 Then If w1 = 5 Then If Not FastSymbol(a$, ")", True) Then Exit Function If Not GetVar(bstack, s$, w2) Then GoTo jmp147811 If w1 = 5 Then If Not MyIsObject(var(w2)) Then GoTo jmp147811 If Not TypeOf var(w2) Is iBoxArray Then GoTo jmp147811 Set pppp = var(w2) If pppp.arr Then GoTo jmp147811 If Not pppp.ItemType(-1) = mProp Then GoTo jmp147811 Set bstack.lastobj = pppp.GroupRef Else If Not VarTypeName(var(w2)) = mProp Then GoTo jmp147811 Dim vvp As PropReference Set vvp = var(w2) Set bstack.lastobj = vvp.Copy End If r = 0 IsProperty = FastSymbol(a$, ")", True) Exit Function Else jmp147811: MyErMacro a$, "Expected a property name", "Περίμενα όνομα ιδιότητας" End If End Function Private Function IsGroupCom(bstack As basetask, a$, r As Variant) As Boolean Dim w1 As Long, s$, ohere$, w2 As Long, myGroup As Object, mygroup2 As Object, aGroup As Group Dim p w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 1 Or w1 = 3 Then If Not GetVar(bstack, s$, w1) Then GoTo jmp1478 If Not VarTypeName(var(w1)) = mGroup Then GoTo jmp1478 If var(w1).IamApointer Then If var(w1).link.IamFloatGroup Then Set bstack.lastpointer = Nothing If var(w1).link Is NullGroup Then Set aGroup = New Group aGroup.BeginFloat 0 aGroup.EndFloat Set myGroup = aGroup Else bstack.soros.CopyGroupObj var(w1).link, myGroup Set aGroup = myGroup End If aGroup.ToDelete = True Set bstack.lastobj = myGroup Else SwapStrings ohere$, here$ here$ = var(w1).lasthere If GetVar(bstack, var(w1).GroupName, w2, , , True) Then CopyGroup2 var(w2), bstack End If SwapStrings ohere$, here$ End If Else CopyGroup2 var(w1), bstack End If r = 0 IsGroupCom = FastSymbol(a$, ")", True) Exit Function ElseIf w1 > 4 Then If Not GetVar(bstack, s$, w1) Then GoTo jmp1478 If ProcessArray(bstack, a$, s$ + ")", var(w1), p) Then If VarTypeName(p) = mGroup Then Set aGroup = p If aGroup.IamApointer Then If aGroup.link.IamFloatGroup Then Set bstack.lastpointer = Nothing If aGroup.link Is NullGroup Then Set aGroup = New Group aGroup.BeginFloat 0 aGroup.EndFloat Set myGroup = aGroup Else Set myGroup = aGroup.link End If bstack.soros.CopyGroupObj myGroup, mygroup2 Set aGroup = mygroup2 aGroup.ToDelete = True Set bstack.lastobj = mygroup2 Else ' need to make a copy group using SwapStrings ohere$, here$ here$ = aGroup.lasthere If GetVar(bstack, aGroup.GroupName, w2, , , True) Then Set myGroup = aGroup.link CopyGroup2 myGroup, bstack End If SwapStrings ohere$, here$ End If Else Set myGroup = aGroup Set bstack.lastobj = CopyGroupObj(myGroup) End If IsGroupCom = FastSymbol(a$, ")", True) Exit Function End If End If Else jmp1478: MyErMacro a$, "Expected a group name", "Περίμενα όνομα ομάδας" End If Exit Function End Function Public Function GetPointer(bstack As basetask, a$) As Boolean Dim w1 As Long, s$, ppppl As iBoxArray, w2 As Long, p, nbstack As basetask, myobj As Object, i As Long Dim Glob As Boolean, rempar As Long, waspointer As Boolean, usehandler As mHandler, ppp$ If MaybeIsSymbol(a$, ")") Then p = 0 GoTo checkagain End If again: w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 1 Or w1 = 3 Then w2 = w1 cont11: If Not GetVar(bstack, s$, w1, , , , , , Glob) Then GoTo jmp1478 If Not VarTypeName(var(w1)) = mGroup Then GoTo jmp1478 If var(w1).IamApointer Then Set bstack.lastobj = var(w1) Set bstack.lastpointer = var(w1) Else If var(w1).IamSuperClass Then PushStage bstack, False i = globalvarGroup("_1", 0, , True) Set myobj = var(w1) UnFloatGroup bstack, "_1", i, myobj, True Set p = CopyGroupObj(var(i)) PopStage bstack MakeGroupPointer bstack, p ElseIf w2 = 1 Then MakeGroupPointer bstack, var(w1), s$, Glob ElseIf w2 = 3 Then MakeGroupPointer bstack, var(w1), Left$(s$, Len(s$) - 1), Glob End If End If GetPointer = True GoTo ExitHere ElseIf w1 > 4 And w1 < 8 Then If Not GetVar(bstack, s$, w1) Then If GetSub(s$ + ")", w2) Then Set nbstack = New basetask Set nbstack.Parent = bstack If bstack.IamThread Then Set nbstack.Process = bstack.Process Set nbstack.Owner = bstack.Owner nbstack.OriginalCode = w2 nbstack.UseGroupname = sbf(w2).sbgroup nbstack.tpointer = sbf(w2).tpointer nbstack.SetV If GoFunc(nbstack, s$ + ")", a$, p) Then If Not nbstack.StaticCollection Is Nothing Then bstack.SetVarobJ "%_" + nbstack.StaticInUse, nbstack.StaticCollection End If Set p = bstack.lastobj If Not p Is Nothing Then If VarTypeName(p) = mGroup Then If p.IamApointer Then Set bstack.lastpointer = p Else If p.IamSuperClass Then PushStage bstack, False i = globalvarGroup("_1", 0, , True) Set myobj = p UnFloatGroup bstack, "_1", i, myobj, True Set p = CopyGroupObj(var(i)) PopStage bstack End If MakeGroupPointer bstack, p End If GetPointer = True GoTo ExitHere End If End If End If ElseIf neoGetArray(bstack, s$, ppppl) Then If Not ppppl.arr Then If NeoGetArrayItem(ppppl, bstack, s$, w2, a$) Then GoTo conthere End If End If Else '"", "POINTER(" If IsLabelSymbolNew(s$, "POINTER(", "POINTER(", 1 - (Asc(s$) < 128)) Then rempar = rempar + 1 GoTo again Else bstack.tmpstr = s$ + Left$(a$, 1) ppp$ = Left$(a$, 1) If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If IsNumberNew(bstack, a$, p, False) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then Set p = bstack.lastobj If Not p.IamApointer Then MakeGroupPointer bstack, p Else Set bstack.lastpointer = p Set bstack.lastobj = p End If GetPointer = True End If End If Exit Function Else If Len(a$) > 0 Then Mid$(a$, 1, 1) = ppp$ End If End If End If Set nbstack = Nothing GoTo jmp1478 End If Set p = var(w1) again99: Set usehandler = Nothing If GetArrayReference(bstack, a$, s$ + ")", p, ppppl, w2) Then conthere: Set usehandler = Nothing If ppppl.ItemType(w2) = mGroup Then Set p = ppppl.item(w2) If p.IamApointer Then Set bstack.lastobj = p Set bstack.lastpointer = p Else If p.IamTeam Or Not p.link Is Nothing Then bstack.soros.CopyGroupObj ppppl.item(w2), myobj Set p = myobj End If MakeGroupPointer bstack, p Set ppppl.item(w2) = bstack.lastpointer ' this is my idea End If GetPointer = True GoTo ExitHere Else If MyIsObject(ppppl.item(w2)) Then Set p = ppppl.item(w2) If Left$(a$, 1) = "(" Then Mid$(a$, 1, 1) = " " Set usehandler = p With usehandler If Not .objref Is Nothing Then If TypeOf .objref Is iBoxArray Then Set ppppl = .objref: Set p = ppppl: GoTo again99 If FindItem(bstack, p, a$, VarTypeName(p), w2) Then Set ppppl = p GoTo conthere End If End If End With End If End If End If End If ElseIf w1 = 8 Then bstack.tmpstr = s$ + "[" + Left$(a$, 1) ppp$ = Left$(a$, 1) If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If IsNumberNew(bstack, a$, p, False) Then If bstack.lastobj Is Nothing Then er66876: MyErMacro a$, "Not group found at array " + s$, "δεν βρήκα ομάδα στο πίνακα " + s$ Exit Function ElseIf Not TypeOf bstack.lastobj Is Group Then Set bstack.lastobj = Nothing GoTo er66876 End If Set bstack.lastpointer = bstack.lastobj GetPointer = True GoTo ExitHere End If If Len(a$) > 0 Then Mid$(a$, 1, 1) = ppp$ GoTo er66876 ElseIf FastSymbol(a$, "(") Then If IsExp(bstack, a$, p) Then If Not bstack.lastpointer Is Nothing Then waspointer = bstack.lastobj.IamApointer ' reverse order if pointer is a reference Set bstack.lastobj = bstack.lastpointer Set bstack.lastpointer = Nothing End If rempar = rempar + 1 checkagain: If bstack.lastobj Is Nothing Then If p = 0 Then If NullPointer Is Nothing Then NullGroup.BeginFloat 2 NullGroup.GroupName = "NULL" NullGroup.PutIs = "NULL" NullGroup.PutIs = "ΜΗΔΕΝΙΚΟΣ" Set p = NullGroup MakeGroupPointer bstack, p Set NullPointer = bstack.lastobj End If Set bstack.lastobj = NullPointer Set bstack.lastpointer = NullPointer GetPointer = True GoTo ExitHere Else GoTo jmp1478 End If Else If TypeOf bstack.lastobj Is Group Then getgroup: Set p = bstack.lastobj If p.IamSuperClass Then PushStage bstack, False i = globalvarGroup("_1", 0, , True) Set myobj = p UnFloatGroup bstack, "_1", i, myobj, True Set p = CopyGroupObj(var(i)) PopStage bstack ElseIf p.IamApointer Then If Not p.link Is Nothing Then Set p = p.link Else Set bstack.lastpointer = p End If ElseIf p.IamFloatGroup Then ' Set bstack.lastpointer = p ' bstack.soros.CopyGroupObj bstack.lastpointer, myobj 'Set p = myobj ElseIf waspointer Then Set p = CopyGroupObj(p) End If MakeGroupPointer bstack, p GetPointer = True GoTo ExitHere End If End If End If jmp1478: If s$ = "THIS" Or s$ = "ΑΥΤΟ" Then If Len(bstack.UseGroupname) > 0 Then s$ = Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - 1) If GetVar(bstack, s$, w1) Then If IsBadCodePtr(var(w1).PointerPtr) = 0 Then ObjSetAddRef myobj, var(w1).PointerPtr Set p = myobj p.link.lasthere = var(w1).lasthere p.link.LastOpen = var(w1).LastOpen Set bstack.lastobj = myobj Set bstack.lastpointer = myobj GetPointer = True GoTo ExitHere End If s$ = vbNullString SwapStrings s$, here$ If (Len(bstack.UseGroupname) - Len(var(w1).GroupName) - 1) > 0 Then here$ = Left$(bstack.UseGroupname, Len(bstack.UseGroupname) - Len(var(w1).GroupName) - 1) Else here$ = vbNullString End If MakeGroupPointer bstack, var(w1) SwapStrings s$, here$ GetPointer = True GoTo ExitHere End If End If ElseIf s$ = "GROUP" Or s$ = "ΟΜΑΔΑ" Then If bstack.soros.Total = 0 Then EmptyStack a$ GetPointer = False: GoTo ExitHere ElseIf bstack.soros.StackItemTypeObjectType(1) = mGroup Then Set bstack.lastobj = bstack.soros.PopObj If bstack.lastobj.IamApointer Then GetPointer = True Set bstack.lastpointer = bstack.lastobj GoTo ExitHere Else GoTo getgroup End If Else StackTopNotGroup a$ GetPointer = False: GoTo ExitHere End If Else er1234: MyErMacro a$, "Expected a group name", "Περίμενα όνομα ομάδας" Exit Function End If ElseIf IsNumber(bstack, a$, p, False) Then GoTo checkagain End If ExitHere: Do While rempar > 0 If Not FastSymbol(a$, ")", True) Then Exit Do rempar = rempar - 1 Loop End Function Private Function CheckGroupOrPointer(bstack As basetask, a$, IsGroupOnly As Group, pppp As iBoxArray, w2 As Long) As Boolean Dim w1 As Long, s$, p w1 = Abs(IsLabel(bstack, a$, s$)) If w1 = 1 Or w1 = 3 Then If w1 = 1 And Len(s$) = 4 Then If s$ = "THIS" Then bstack.GetDotNew s$, 1 If bstack.tpointer > 0 Then w1 = bstack.tpointer GoTo contGe End If ElseIf s$ = "ΑΥΤΟ" Then bstack.GetDotNew s$, 1 If bstack.tpointer > 0 Then w1 = bstack.tpointer GoTo contGe End If End If End If If Not GetVar(bstack, s$, w1) Then Exit Function contGe: If Not VarTypeName(var(w1)) = mGroup Then Exit Function If var(w1).IamApointer Then Set bstack.lastobj = var(w1) Set bstack.lastpointer = var(w1) Else Set IsGroupOnly = var(w1) End If CheckGroupOrPointer = True Exit Function ElseIf w1 > 4 Then If Not GetVar(bstack, s$, w1) Then If neoGetArray(bstack, s$, pppp) Then If Not pppp.arr Then If NeoGetArrayItem(pppp, bstack, s$, w2, a$) Then GoTo conthere End If End If Exit Function End If If GetArrayReference(bstack, a$, s$ + ")", var(w1), pppp, w2) Then conthere: If pppp.ItemType(w2) = mGroup Then Set p = pppp.item(w2) If p.IamApointer Then Set bstack.lastobj = p Set bstack.lastpointer = p Else Set IsGroupOnly = p End If CheckGroupOrPointer = True Exit Function End If End If Else If IsExp(bstack, a$, p) Then If bstack.lastobj Is Nothing Then Exit Function Else If TypeOf bstack.lastobj Is Group Then If Not bstack.lastobj.IamApointer Then Set IsGroupOnly = bstack.lastobj Set bstack.lastobj = Nothing End If CheckGroupOrPointer = True End If End If End If End If End Function Private Function IsChrCode(bstack As basetask, a$, r As Variant) As Boolean Dim s$, W As Long If IsStrExp(bstack, a$, s$, False) Then If s$ = vbNullString Then r = CInt(-1) Else If LenB(s$) = 1 Then W = MemByte(StrPtr(s$)) Else W = AscW(s$) End If If W > -10241 And W < -9216 Then If Len(s$) > 1 Then r = CCur((&H10000 + (UINT(W) - &HD800&) * &H400 + UINT(AscW(Mid$(s$, 2, 1))) - &HDC00&)) Else r = CInt(W) On Error Resume Next End If Else r = CInt(W) On Error Resume Next End If End If IsChrCode = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsAsc(bstack As basetask, a$, r As Variant) As Boolean Dim s$ If IsStrExp(bstack, a$, s$, False) Then If s$ = vbNullString Then r = -1 Else 'cLid r = Asc(StrConv(StrConv(s$, vbFromUnicode, Clid), vbUnicode)) End If IsAsc = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsCons(bstack As basetask, a$, r As Variant) As Boolean Dim anything As Object, pppp As iBoxArray, s$ If IsExp(bstack, a$, r) Then If myVarType(r, vbString) Then r = 0 End If Set anything = bstack.lastobj If CheckAnyArray(anything) Then If TypeOf anything Is mArray Then Set pppp = New tuple pppp.processAppend anything 'Set anything = pppp Set pppp = Nothing End If a13410: Set pppp = anything If FastSymbol(a$, ",") Then againcons: Set bstack.lastobj = Nothing If IsExp(bstack, a$, r) Then If myVarType(r, vbString) Then r = 0 End If Set anything = bstack.lastobj If CheckAnyArray(anything) Then a13415: pppp.processAppend anything Set pppp = Nothing Set bstack.lastobj = anything r = 0 Else Set pppp = Nothing Set anything = Nothing NotArray Exit Function End If ElseIf IsStrExp(bstack, a$, s$, False) Then Set anything = bstack.lastobj If CheckAnyArray(anything) Then GoTo a13415 Else Set pppp = Nothing Set anything = Nothing Set bstack.lastobj = anything NotArray Exit Function End If Else If TypeOf anything Is mArray Then Dim pppp1 As New mArray Set pppp = anything pppp.CopyArray pppp1 Set bstack.lastobj = pppp1 Else Dim pppp2 As New tuple Set pppp = anything pppp.CopyArray pppp2 Set bstack.lastobj = pppp2 End If Set pppp = Nothing Set anything = Nothing IsCons = FastSymbol(a$, ")", True) Exit Function End If Else Set anything = Nothing Set bstack.lastobj = anything NotArray Exit Function End If If FastSymbol(a$, ",") Then Set pppp = anything: GoTo againcons Set anything = Nothing IsCons = FastSymbol(a$, ")", True) ElseIf IsStrExp(bstack, a$, s$, False) Then Set anything = bstack.lastobj If CheckAnyArray(anything) Then If TypeOf anything Is mArray Then Set pppp = New tuple pppp.processAppend anything Set anything = pppp Set pppp = Nothing End If GoTo a13410 End If Else missParam a$ End If End Function Private Function IsCar(bstack As basetask, a$, r As Variant) As Boolean Dim anything As Object, pppp As iBoxArray, s$, usehandler As mHandler Dim pppp0 As mArray, mTuple As tuple If IsExp(bstack, a$, r) Then car1023: If myVarType(r, vbString) Then r = 0 End If Set anything = bstack.lastobj If CheckAnyArray(anything) Then Set pppp = anything If TypeOf pppp Is mArray Then Set pppp0 = pppp pppp0.Car anything Else Set mTuple = pppp mTuple.Car anything End If On Error Resume Next Set pppp = anything Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = pppp Set anything = usehandler Set usehandler = Nothing Set bstack.lastobj = anything Set pppp = Nothing Set anything = Nothing Else NotArray Exit Function End If Set anything = Nothing IsCar = FastSymbol(a$, ")", True) ElseIf IsStrExp(bstack, a$, s$, False) Then GoTo car1023 Else missParam a$ End If End Function Private Function IsCdr(bstack As basetask, a$, r As Variant) As Boolean Dim anything As Object, pppp As iBoxArray, s$, usehandler As mHandler Dim pppp0 As mArray, mTuple As tuple If IsExp(bstack, a$, r) Then cdr1022: If myVarType(r, vbString) Then r = 0 End If Set anything = bstack.lastobj If CheckAnyArray(anything) Then Set pppp = anything If TypeOf pppp Is mArray Then Set pppp0 = pppp pppp0.Cdr anything Else Set mTuple = pppp mTuple.Cdr anything End If On Error Resume Next Set pppp = anything Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = pppp Set bstack.lastobj = usehandler Set pppp = Nothing Set anything = Nothing Set usehandler = Nothing ElseIf IsStrExp(bstack, a$, s$, False) Then GoTo cdr1022 Else NotArray Exit Function End If IsCdr = FastSymbol(a$, ")", True) Else missParam a$ End If End Function Private Function IsTest(bstack As basetask, a$, r As Variant) As Boolean Dim s$ If IsExp(bstack, a$, r, , True) Then If trace Then bypassST = r = 0 STbyST = Not bypassST STq = False IsTest = FastSymbol(a$, ")", True) Else r = 0 End If ElseIf IsStrExp(bstack, a$, s$, False) Then If trace Then If s$ = vbNullString Then s$ = Chr$(1) r = (Mid$(Form2.gList2.HeadLine, 10) Like s$) bypassST = r <> 0 Else r = 0 End If IsTest = FastSymbol(a$, ")", True) Else missParam a$ End If End Function ' if ExecuteVar=0 then continue ' if ExecuteVar=1 then Exit do (after exit) ' if ExecuteVar=2 then GoTo autogosub (after exit) ' if ExecuteVar=3 then goto loopagain (after exit) ' if ExecuteVar=4 then GoTo contVarNew (after exit) ' if ExecuteVar=5 then GoTo again3 (after exit) ' if ExecuteVar=6 then GoTo parsecommand (after exit) ' if ExecuteVar=7 then GoTo loopcontinue (after exit) 'if ExecuteVar=8 then goto exitfunc Sub CopyPointerRef(basestack As basetask, thisobj As Object) Dim ohere$, w2 As Long ohere$ = here$ here$ = thisobj.lasthere If GetVar(basestack, thisobj.GroupName, w2, , , True) Then CopyGroup2 var(w2), basestack End If here$ = ohere$ End Sub Sub CallClear(bstack As basetask, what$, z1 As Variant, Optional minusone As Long = 0) Dim myobject As Object, ok As Boolean, z As Group Set z = z1 If z.IamApointer Then ' compiled has minus one reference ?? 'MsgBox z.refcount1 - MinusOne If z.refcount1 - minusone > 1 Then Exit Sub If z.link Is Nothing Then ElseIf z.link.IamFloatGroup Then If minusone < 0 Then If z.LinkGroup.refcount1 - 1 = 0 Then Exit Sub Else If z.LinkGroup.refcount1 = 0 Then Exit Sub End If If z.LinkGroup.HasRemove Then Set bstack.lastobj = z.link z.link.ToDelete = True ProcessOper bstack, myobject, "_%", (0), 1, True End If GoTo conthere End If ElseIf z.IamFloatGroup Then Set bstack.lastobj = z z.ToDelete = True ProcessOper bstack, myobject, "_%", (0), 1 Set bstack.lastobj = Nothing Else Set myobject = bstack.soros Set bstack.Sorosref = NewmStiva NeoCall2 bstack, what$ + "." + ChrW(&H1FFF) + "_%()", ok Set bstack.Sorosref = myobject Set myobject = Nothing End If conthere: End Sub Sub SwapStrings(a$, b$) Dim i As Long, j As Long GetMem4 VarPtr(a$), i GetMem4 VarPtr(b$), j PutMem4 VarPtr(a$), j PutMem4 VarPtr(b$), i End Sub Function FastPureLabel(b$, a$, Optional Pos As Long = 1, Optional convert As Boolean, Optional retdot As Boolean, Optional countdot As Long, Optional trimit As Boolean = True, Optional gr As Boolean) As Long Dim i&, l As Long, one As Boolean, convat As Boolean, nospace As Boolean, pres As Long Dim P2 As Long, P1 As Integer, p4 As Long, counter As Long a$ = vbNullString countdot = 0 gr = False l = Len(b$): If l = 0 Then Exit Function If Pos > l Then Exit Function P2 = StrPtr(b$) + Pos * 2 - 2: l = l - 1 p4 = P2 + l * 2 For i = P2 To p4 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 7, 9 If nospace Then pres = 0: GoTo ExitHere If counter = 0 Then Pos = Pos + 1 Else Exit Function End If Case Else Select Case P1 Case 38 Pos = Pos + 1 If i < p4 Then i = i + 2 GetMem2 i, P1 If P1 = 72 Or P1 = 104 Then i = i + 2 If i <= p4 Then GetMem2 i, P1 If (P1 >= 48 And P1 <= 57) Then i = i - 4 Pos = Pos - 1 GoTo ExitHere ElseIf (P1 >= 97 And P1 <= 102) Then i = i - 4 Pos = Pos - 1 GoTo ExitHere ElseIf (P1 >= 48 And P1 <= 70) Then i = i - 4 Pos = Pos - 1 GoTo ExitHere End If End If i = i - 2 End If i = i - 2 End If FastPureLabel = 2 GoTo ExitHere Case 46 pres = 0 countdot = countdot + 1 If retdot Then counter = counter + 1 If Not retdot Then Pos = Pos + 1 nospace = True Case 64 FastPureLabel = 0 If retdot Then pres = Pos + 1 counter = counter + 1 Else If countdot > 0 Then pres = 1 Pos = Pos + 1 End If convat = True nospace = True Case 65 To 91, 93 To 122, Is > 191 counter = counter + 1 If convert Then If P1 > 901 And P1 < 975 Then gr = True End If GoTo aName Case 123 Pos = Pos + 1 FastPureLabel = 2 GoTo ExitHere Case Else GoTo TrimThis End Select End Select Next i Pos = Len(b$) + 1 Exit Function TrimThis: 'If pres = 0 Then If countdot > 0 And FastPureLabel = 1 Then a$ = String$(countdot, ".") ElseIf pres = 1 Then Pos = Pos - 1 End If GoTo ExitHere aName: If retdot Then If pres = 0 Then countdot = counter - 1 End If P2 = i + 2 FastPureLabel = 1 For i = P2 To p4 Step 2 GetMem2 i, P1 Select Case P1 Case 36 ' 3 or 6 If one Then Exit For FastPureLabel = 3 counter = counter + 1 one = True Case 37 ' 4 or 7 If one Then Exit For FastPureLabel = 4 counter = counter + 1 one = True Case 40 ' add 3 If i + 4 <= p4 Then GetMem2 i + 2, P1 If P1 = 41 Then GetMem2 i + 4, P1 If P1 = 64 Then convat = True If FastPureLabel = 1 Then counter = counter + 4 i = i + 6 GoTo conthere Else counter = counter + 3 l = i + 6 For l = l To p4 Step 2 GetMem2 l, P1 If P1 = 64 Then counter = counter + 1 Else Exit For Next l Exit For End If End If End If End If If FastPureLabel = 1 Then FastPureLabel = 5 Else FastPureLabel = FastPureLabel + 3 End If counter = counter + 1 Exit For conthere: Case 902 To 976 If one Then Exit For If Not gr And convert Then gr = True counter = counter + 1 Case 64 convat = True If FastPureLabel = 3 Then counter = counter + 1 GetMem2 i + 2, P1 Exit For End If If one Then Exit For counter = counter + 1 Case 46, 48 To 57, 65 To 91, 93 To 122, Is > 191, Is < 0 If one Then Exit For counter = counter + 1 Case Else Exit For End Select Next i If convat Then If convert Then If gr Then a$ = myUcase(Replace$(Mid$(b$, Pos, counter), "@", "."), gr) Else a$ = UCase(Replace$(Mid$(b$, Pos, counter), "@", ".")) End If Else a$ = Replace$(Mid$(b$, Pos, counter), "@", ".") End If ElseIf convert Then If gr Then a$ = myUcase(Mid$(b$, Pos, counter), gr) Else a$ = UCase(Mid$(b$, Pos, counter)) End If Else a$ = Mid$(b$, Pos, counter) End If If retdot Then If pres > 0 Then Mid$(a$, pres - Pos, 1) = "@" pres = 0 ExitHere: If trimit Then b$ = Mid$(b$, Pos + counter) If pres > 0 Then Mid$(b$, 1, 1) = "." Pos = 1 Else Pos = Pos + counter End If End Function Public Sub aheadstatusANY(a$, Pos As Long) Dim pos2 As Long If Len(a$) = 0 Then Exit Sub Dim V1 As Integer If Pos = 0 Then Pos = 1 Do While Pos <= Len(a$) V1 = AscW(Mid$(a$, Pos, 1)) If Not (V1 > 0 And V1 < 32) Then If V1 = 34 Then Pos = Pos + 1 Do While Pos <= Len(a$) V1 = AscW(Mid$(a$, Pos, 1)) If V1 = 34 Then Exit Do If V1 > 0 And V1 < 32 And Not V1 = 9 Then Exit Do Pos = Pos + 1 Loop ElseIf V1 = 40 Then again22: Pos = Pos + 1 If Not BlockParam2p(a$, Pos) Then Exit Do If Mid$(a$, Pos + 1, 1) = "#" Then Pos = Pos + 1 GoTo conthere ElseIf Mid$(a$, Pos + 1, 1) = "(" Then Pos = Pos + 1: GoTo again22 End If ElseIf V1 = 91 Then ' "[" Pos = Pos + 1 If Not BlockParam2s(a$, Pos) Then Exit Do ElseIf V1 = 123 Then If Pos <= Len(a$) Then Pos = blockLen2(a$, Pos + 1) If Pos = 0 Then Pos = Len(a$): Exit Do End If Else Select Case V1 Case Is < 0 Case 41, 125, Is < 32, 39, 92 Exit Do End Select End If Else If V1 <> 8 And V1 <> 9 Then Exit Do End If Pos = Pos + 1 conthere: Loop End Sub Function Funcweak(basestack As basetask, s$, Optional W As Long, Optional lastname As String) As String ' no validation of names ' check for "dot" Dim ww$, original$, s1$, ww1$, p As Variant, w1 As Long again: W = IsLabel(basestack, s$, lastname) ww$ = lastname$ ww1$ = ww$ If W = 8 Then s1$ = "&" + lastname$ w1 = IsLabel(basestack, s1$, ww$) If Len(s1$) = 0 Then Exit Function If ISSTRINGA(s1$, ww$) Then If IsExp(basestack, s$, p, flatobject:=True, nostring:=True) Then If CheckInt64(p) Then ww$ = ww$ + "[" + CStr(p) + "]" Else ww$ = ww$ + "[" + LTrim$(str(p)) + "]" End If End If If FastSymbol(s$, "][", , 2) Then If IsExp(basestack, s$, p, flatobject:=True, nostring:=True) Then If CheckInt64(p) Then ww$ = ww$ + "[" + CStr(p) + "]" Else ww$ = ww$ + "[" + LTrim$(str(p)) + "]" End If End If End If If FastSymbol(s$, "]") Then 'If here$ = vbNullString Then If FastSymbol(s$, "|") Then W = IsLabel(basestack, s$, lastname) If W = 1 Then Funcweak = ww$ + "|" + lastname ElseIf W = 5 Then ww$ = ww$ + "|" + lastname If IsExp(basestack, s$, p) Then If CheckInt64(p) Then ww$ = ww$ + CStr(p) ElseIf MemInt(VarPtr(p)) = vbBoolean Then If ShowBooleanAsString Then ww$ = format$(p, DefBooleanString) Else ww$ = CStr(p * 1) End If ElseIf VarType(p) = vbString Then ww$ = ww$ + LTrim$(p) Else p = Int(p) ww$ = ww$ + fixthis(p) End If End If If FastSymbol(s$, ")") Then Funcweak = ww$ + ")" End If End If Else Funcweak = ww$ End If 'Else 'Funcweak = here$ + "." + ww$ 'End If End If End If Exit Function ElseIf W >= 5 Then s1$ = "&" + ww$ + ")" w1 = IsLabel(basestack, s1$, ww$) If w1 = 2 Then ' IT IS A FUNCTION ww1$ = ww1$ + ")" GetSubFullName ww1$, ww$ If FastSymbol(s$, ")") Then If here$ = vbNullString Then Funcweak = ww1$ Else Funcweak = here$ + "." + ww1$ End If End If ElseIf w1 = 0 Then If ISSTRINGA(s1$, ww$) Then If FastSymbol(s$, ")") Then Funcweak = ww$ Else ' check parameters 'ww$ = ww$ + "(" again12: Do If IsExp(basestack, s$, p) Then If CheckInt64(p) Then ww$ = ww$ + CStr(p) ElseIf MemInt(VarPtr(p)) = vbBoolean Then If ShowBooleanAsString Then ww$ = format$(p, DefBooleanString) Else ww$ = CStr(p * 1) End If ElseIf VarType(p) = vbString Then ww$ = ww$ + LTrim$(p) Else p = Int(p) ww$ = ww$ + fixthis(p) End If ElseIf IsStrExp(basestack, s$, ww1$) Then ww$ = ww$ + Chr$(34) + ww1$ + Chr$(34) End If If Not FastSymbol(s$, ",") Then Exit Do ww$ = ww$ + "," Loop If FastSymbol(s$, ")") Then ww$ = ww$ + ")" If FastSymbol(s$, ".") Then ' ............ If AscW(s$) > 64 Then If FastPureLabel(s$, ww1$) > 3 Then ww$ = ww$ + "." + ww1$ GoTo again12 Else ww$ = ww$ + "." + ww1$ End If End If End If Funcweak = ww$ End If End If End If Else s1$ = "&" + ww$ If IsLabel(basestack, s1$, ww1$) = 0 Then If s1$ = vbNullString Then GetSubFullName ww$, ww1$ Funcweak = ww1$ Else If ISSTRINGA(s1$, ww1$) Then If FastSymbol(s$, ".") Then If Right$(ww1$, 1) = "$" Then If IsStrExp(basestack, ww1$, ww$) Then s$ = ww$ + "." + s$ GoTo again End If End If End If Funcweak = ww1$ End If End If End If End If End Function Function RevisionPrint(basestack As basetask, rest1$, xa As Long, Lang As Long) As Boolean Dim Scr As Object, oldcol As Long, oldFTEXT As Long, oldFTXT As String, oldpen As Long Dim par As Boolean, i As Long, f As Long, p As Variant, w4 As Boolean, pn&, s$, dlen As Long Dim o As Long, w3 As Long, x1 As Long, y1 As Long, X As Double, ColOffset As Long, anyBigInteger As BigInteger Dim work As Boolean, work2 As Long, skiplast As Boolean, ss$, ls As Long, myobject As Object, counter As Long, Counterend As Long, countDir As Long Dim bck$, clearline As Boolean, ihavecoma As Boolean, isboolean As Boolean, usehandler As mHandler Set Scr = basestack.Owner Dim rest$, where As Long, Final As Boolean w3 = -1 Dim basketcode As Long, prive As basket basketcode = GetCode(Scr) prive = players(basketcode) With prive If .MAXXGRAPH = 0 Then MyEr "No form to print", "δεν υπάρχει φόρμα για εκτύπωση": Exit Function End If PlaceBasketPrive Scr, prive Scr.FontTransparent = True On Error GoTo 0 Dim opn& where = 1 aheadstatusANY rest1$, where If where > 1 Then rest$ = Left$(rest1$, where - 1) Else .lastprint = False par = True GoTo JUMPHERE End If par = True If MaybeIsSymbol3(rest$, "#", f) Then If Mid$(rest$, f + 1, 6) Like "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]" Then Else Mid$(rest$, 1, f) = space$(f) If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then If p < 0 Then If p < -1 Then .lastprint = False par = False End If f = p If Not FastSymbol(rest$, ",") Then s$ = vbNullString pn& = 2 GoTo isAstring End If Else f = CLng(p) If Fkind(f) = FnoUse Or Fkind(f) = Finput Or Fkind(f) = Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": RevisionPrint = False: GoTo exit2 Dim clearprive As basket prive = clearprive .lastprint = False par = False If Not FastSymbol(rest$, ",") Then s$ = vbNullString pn& = 2 GoTo isAstring End If End If Else MyEr "expected file number", "περίμενα αριθμό αρχείου" End If End If Else ss$ = Left$(rest$, MyTrimL(rest$) + 5) ls = Len(ss$) If Not IsLabelSYMB3(ss$, s$) Then f = 0 Else Select Case Lang Case 1 If Len(s$) > 3 Then If InStr("BOUP", UCase(Left$(s$, 1))) > 0 Then Select Case UCase(s$) Case "BACK" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 4 Case "OVER" f = 1 Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) Case "UNDER" f = 2 Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) Case "PART" f = 3 Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) Case Else ''rest$ = s$ + rest$ f = 0 End Select Else f = 0 End If Else f = 0 End If Case 0, 2 If Len(s$) > 2 Then If InStr("ΦΠΥΜ", myUcase(Left$(s$, 1))) > 0 Then Select Case myUcase(s$, True) Case "ΦΟΝΤΟ" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 4 Case "ΠΑΝΩ" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 1 Case "ΥΠΟ" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 2 Case "ΜΕΡΟΣ" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 3 Case Else f = 0 End Select Else f = 0 End If Else f = 0 End If Case -1 '' this is for ? If Len(s$) > 2 Then If InStr("BOUPΦΠΥΜ", myUcase(Left$(s$, 1))) > 0 Then Select Case myUcase(s$) Case "ΦΟΝΤΟ", "BACK" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 4 Case "ΠΑΝΩ", "OVER" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 1 Case "ΥΠΟ", "UNDER" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 2 Case "ΜΕΡΟΣ", "PART" Mid$(rest$, 1, ls - Len(ss$)) = space$(ls - Len(ss$)) f = 3 Case Else f = 0 End Select Else f = 0 End If Else f = 0 End If Lang = 0 End Select If f > 0 And .lastprint Then .lastprint = False If basestack.toprinter Then GetXYb2 Scr, prive, .curPos, .currow Else GetXYb Scr, prive, x1&, y1& End If If f <> 2 Then If x1& > 0 Or y1& >= .mX Then crNew basestack, prive End If If f = 1 Then '' work = True oldcol = .Column If TypeOf Scr Is MetaDc Then Scr.Line2 0&, .currow * .Yt, .mX * .Xt, (.currow) * .Yt + .Yt - 2 * DYP, .Paper, True ElseIf Scr.ScaleMode = 0 Then Scr.Line (0&, Scr.ScaleY(.currow * .Yt, 1, 0))-(Scr.ScaleX((.mX - 1) * .Xt + .Xt * 2, 1, 0), Scr.ScaleY((.currow) * .Yt + .Yt - 2 * DYP, 1, 0)), .Paper, BF Else Scr.Line (0&, .currow * .Yt)-((.mX - 1) * .Xt + .Xt * 2, (.currow) * .Yt + .Yt - 2 * DYP), .Paper, BF End If LCTbasket Scr, prive, .currow, 0& .Column = .mX - 1 w4 = True oldFTEXT = .FTEXT oldFTXT = .FTXT oldpen = .mypen pn& = 2 .FTEXT = 4 ElseIf f = 2 Then work = True oldcol = .Column If TypeOf Scr Is MetaDc Then Scr.Line2 0&, .currow * .Yt + .Yt - DYP, .mX * .Xt, (.currow) * .Yt + .Yt - DYP, .mypen, True ElseIf Scr.ScaleMode = 0 Then Scr.Line (0&, Scr.ScaleY(.currow * .Yt + .Yt - DYP, 1, 0))-(Scr.ScaleX((.mX - 1) * .Xt + .Xt * 2, 1, 0), Scr.ScaleY(.currow * .Yt + .Yt - DYP, 1, 0)), .mypen, BF Else Scr.Line (0&, .currow * .Yt + .Yt - DYP)-((.mX - 1) * .Xt + .Xt * 2, (.currow) * .Yt + .Yt - DYP), .mypen, BF End If crNew basestack, prive LCTbasketCur Scr, prive w4 = True oldFTEXT = .FTEXT oldFTXT = .FTXT oldpen = .mypen .FTEXT = 4 pn& = 2 ElseIf f = 3 Then ' we print in a line with lost chars, so controling the start of printing ' we can render text, like from a view port Some columns are hidden because they went out of screen; work = True oldcol = .Column LCTbasket Scr, prive, .currow, 0& w4 = True oldFTEXT = .FTEXT oldFTXT = .FTXT .FTEXT = 4 oldpen = .mypen ElseIf f = 4 Then work = True clearline = True ' LCTbasketCur scr, prive If .curPos > 0 Then crNew basestack, prive LCTbasketCur Scr, prive End If If TypeOf Scr Is MetaDc Then Scr.Line2 0&, .currow * .Yt, (.mX - 1) * .Xt + .Xt * 2, (.currow) * .Yt + .Yt - 1 * DYP, .Paper, True ElseIf Scr.ScaleMode = 0 Then Scr.Line (0&, Scr.ScaleY(.currow * .Yt, 0, 1))-(Scr.ScaleY((.mX - 1) * .Xt + .Xt * 2, 0, 1), Scr.ScaleY((.currow) * .Yt + .Yt - 1 * DYP, 0, 1)), .Paper, BF Else Scr.Line (0&, .currow * .Yt)-((.mX - 1) * .Xt + .Xt * 2, (.currow) * .Yt + .Yt - 1 * DYP), .Paper, BF End If LCTbasketCur Scr, prive pn& = 2 End If f = 0 End If End If If w4 Then pn& = 2 Else pn& = 0 s$ = vbNullString If par Then If .FTEXT > 3 And .curPos >= .mX And Not w4 Then crNew basestack, prive w3 = 0 End If End If If par Then If FastSymbol(rest$, ";") Then If .lastprint Then .lastprint = False LCTbasketCur Scr, prive crNew basestack, prive End If ElseIf .lastprint Then If .FTEXT > 3 Then pn& = 7: GoTo newntrance End If End If Do again22: If Final Then If myobject Is Nothing Then GoTo there1 If FastSymbol(rest$, "~(", , 2) Then ' means combine ' get the color and then look for @( parameters) w3 = -1 If par Then ' par is false when we print in files, we can't use color; If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then .mypen = CLng(mycolor(p)) TextColor Scr, .mypen If FastSymbol(rest$, ",") Then If w4 Or Not work Then If prive.lastprint Then prive.lastprint = False GetXYb Scr, prive, .curPos, .currow If work Then .curPos = .curPos - ColOffset If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If w4 Then LCTbasketCur Scr, prive End If End If LCTbasketCur Scr, prive Else If work Then .curPos = .curPos - ColOffset If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If w4 Then LCTbasketCur Scr, prive End If End If x1 = .Column + .curPos + 1 y1 = .currow + 1 pn& = 99 GoTo pthere ' background and border and or images End If If Not FastSymbol(rest$, ")") Then RevisionPrint = False: Set Scr = Nothing: GoTo exit2 pn& = 99 End If ElseIf FastSymbol(rest$, "@(", , 2) Then clearline = False w3 = -1 If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then If par Then .curPos = CLng(Fix(p)) End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then If CLng(Fix(p)) >= .mY Then If par Then .currow = .mY - 1 Else If par Then .currow = CLng(Fix(p)) End If End If End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then x1 = CLng(Fix(p)) Else x1 = 1 End If If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then y1 = CLng(Fix(p)) Else y1 = 1 End If If FastSymbol(rest$, ",") Then pthere: If par Then LCTbasketCur Scr, prive If IsStrExp(basestack, rest$, s$) Then jmpstr1222: p = 0 If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then s$ = p: GoTo jmpstr1222 If p <> 0 Then p = True Else p = True End If End If x1 = Abs(x1 - .curPos) y1 = Abs(y1 - .currow) If par Then BoxImage Scr, prive, x1, y1, s$, 0, (p) ElseIf IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then If par Then BoxColorNew Scr, prive, x1 - 1, y1 - 1, (p) If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, X, , True) Then If par Then BoxBigNew Scr, prive, x1 - 1, y1 - 1, (X) Else RevisionPrint = False Set Scr = Nothing GoTo exit2 End If End If Else RevisionPrint = False Set Scr = Nothing GoTo exit2 End If End If If par Then LCTbasket Scr, prive, .currow, .curPos If Not FastSymbol(rest$, ")") Then RevisionPrint = False Set Scr = Nothing GoTo exit2 End If work = False pn& = 99 ElseIf LastErNum <> 0 Then RevisionPrint = LastErNum = -2 Set Scr = Nothing GoTo exit2 ElseIf FastSymbol(rest$, "$(", , 2) Then conthere: Set anyBigInteger = Nothing w3 = -1 If IsExp(basestack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then .FTXT = p: GoTo str123456 If Not par Then p = 0 .FTEXT = Abs(p) Mod 10 ' 0 STANDARD LEFT chars before typed beyond the line are directed to the next line ' 1 RIGHT ' 2 CENTER ' 3 LEFT ' 4 LEFT PROP....expand to next .Column...... ' 5 RIGHT PROP ' 6 CENTER PROP ' 7 LEFT PROP ' 8 left and right justify ' 9 New in version 8 Left justify(like 7) without word wrap (cut excess) ElseIf IsStrExp(basestack, rest$, s$) Then .FTXT = s$ End If str123456: If FastSymbol(rest$, ",") Then If IsExp(basestack, rest$, p, flatobject:=True, nostring:=True) Then If par Then p = p - 1 If Abs(Int(p Mod (.mX + 1))) < 2 Then MyEr ".Column minimum width is 4 chars", "Μικρότερο μέγεθος στήλης είναι οι τέσσερις χαρακτήρες" Else If w4 Or Not work Then LCTbasketCur Scr, prive Else GetXYb Scr, prive, .curPos, .currow End If If w4 Then ColOffset = .curPos ' now we have columns from offset ColOffset .Column = Abs(Int(p Mod (.mX + 1))) End If End If Else RevisionPrint = False Set Scr = Nothing GoTo exit2 End If End If If Not FastSymbol(rest$, ")") Then RevisionPrint = False Set Scr = Nothing GoTo exit2 End If If par Then pn& = 99 ElseIf FastSymbol(rest$, ",") Then GoTo again22 End If ElseIf LastErNum <> 0 Then RevisionPrint = LastErNum <> -2 Set Scr = Nothing GoTo exit2 ElseIf Not myobject Is Nothing Then takeone: '' for arrays only (this is a last check for checking in IDE only) ' If Not CheckIsmArrayOrStackOrCollection(myobject) Then ' Set myobject = Nothing ' p = 0 ' GoTo isanumber ' End If If countDir >= 0 Then If counter = myobject.Count Or (counter > Counterend And Counterend > -1) Or countDir = 0 Then Set myobject = Nothing SwapStrings rest$, bck$ GoTo taketwo End If Else If counter < 0 Or (counter < Counterend And Counterend > -1) Then Set myobject = Nothing SwapStrings rest$, bck$ GoTo taketwo End If End If myobject.index = counter If myobject.IsEmpty Then s$ = " " counter = counter + countDir GoTo isAstring Else If Not IsNumericPrint(myobject.Value) Then If TypeOf myobject Is Enumeration Then s$ = myobject.Value counter = counter + countDir GoTo isAstring ElseIf myobject.IsObj Then If myobject.IsEnum(p) Then counter = counter + countDir GoTo isanumber ElseIf myobject.IsObjAt(counter, p) Then If TypeOf p Is BigInteger Then Set anyBigInteger = p p = anyBigInteger.ToString counter = counter + countDir GoTo isanumber Else s$ = " " End If Else s$ = " " End If Else s$ = myobject.Value End If counter = counter + countDir GoTo isAstring Else If TypeOf myobject Is Enumeration Then p = myobject.Value Else On Error Resume Next If Not myobject.IsEnum(p) Then p = myobject.Value isboolean = VarType(p) = vbBoolean End If If Err.Number > 0 Then p = myobject.Value End If counter = counter + countDir GoTo isanumber End If End If ElseIf IsExp(basestack, rest$, p) Then If Not basestack.lastobj Is Nothing Then If TypeOf basestack.lastobj Is mArray Or TypeOf basestack.lastobj Is tuple Then Set myobject = basestack.lastobj Set basestack.lastobj = Nothing Counterend = -1 counter = 0 countDir = 1 bck$ = vbNullString SwapStrings rest$, bck$ 'bck$ = rest$ 'rest$ = vbNullString GoTo takeone ElseIf IsObjmHandler(basestack.lastobj) Then Set myobject = basestack.lastobj Set usehandler = myobject Set basestack.lastobj = Nothing With myobject If usehandler.UseIterator Then If TypeOf usehandler.objref Is Enumeration Then p = usehandler.objref.Value Set usehandler = Nothing Set myobject = Nothing GoTo isanumber Else Counterend = usehandler.index_End If Counterend = -1 Then Set usehandler = Nothing Set myobject = Nothing GoTo isAstring Else counter = usehandler.index_start If counter <= Counterend Then countDir = 1 Else countDir = -1 End If End If Else Counterend = -1 counter = 0 countDir = 1 If usehandler.t1 = 4 Then Set usehandler = Nothing Set myobject = Nothing If MemInt(VarPtr(p)) = vbString Then s$ = p GoTo isAstring Else GoTo isanumber End If ElseIf usehandler.t1 = 2 Then p = 0 s$ = "Buffer" Set usehandler = Nothing Set myobject = Nothing GoTo isAstring ElseIf Not CheckIsmArrayOrStackOrCollection(myobject) Then Set myobject = Nothing Set usehandler = Nothing Else SwapStrings rest$, bck$ GoTo takeone End If End If End With If Not CheckLastHandler(myobject) Then NoProperObject rest$ = bck$: RevisionPrint = False: GoTo exit2 End If Set usehandler = myobject If usehandler.t1 = 1 Or usehandler.t1 = 5 Then Set myobject = usehandler.objref SwapStrings rest$, bck$ GoTo takeone ElseIf Typename(usehandler.objref) = "mStiva" Then Set myobject = usehandler.objref SwapStrings rest$, bck$ GoTo takeone ElseIf Typename(usehandler.objref) = myArray Then If usehandler.objref.arr Then Set myobject = usehandler.objref SwapStrings rest$, bck$ GoTo takeone End If ElseIf Typename(usehandler.objref) = "Enumeration" Then Set myobject = usehandler.objref SwapStrings rest$, bck$ GoTo takeone End If ElseIf TypeOf basestack.lastobj Is VarItem Then p = basestack.lastobj.ItemVariant ElseIf TypeOf basestack.lastobj Is BigInteger Then Set anyBigInteger = basestack.lastobj p = "" SwapString2Variant anyBigInteger.ToString, p End If Set basestack.lastobj = Nothing ElseIf VarType(p) = vbBoolean Then If opn& = 5 Then If ShowBooleanAsString Then s$ = format$(p, DefBooleanString) GoTo isAstring Else s$ = CStr(p * 1) End If Else isboolean = True End If ElseIf myVarType(p, vbString) Then s$ = p GoTo isAstring End If isanumber: If par Then If .lastprint Then opn& = 5 pn& = 1 If .Column = 1 Then pn& = 6 Else .lastprint = False pn& = 1 End If ElseIf LastErNum <> 0 Then .lastprint = False RevisionPrint = LastErNum = -2 Set Scr = Nothing GoTo exit2 ElseIf IsStrExp(basestack, rest$, s$, False) Then ' was Len(basestack.tmpstr) = 0 If Not basestack.lastobj Is Nothing Then If IsobjArray(basestack.lastobj) Then Set myobject = basestack.lastobj Set basestack.lastobj = Nothing Counterend = -1 counter = 0 countDir = 1 SwapStrings rest$, bck$ GoTo takeone End If End If isAstring: If par Then If .lastprint Then opn& = 5 pn& = 2 If .Column = 1 Then pn& = 7 Else .lastprint = False pn& = 2 End If ElseIf LastErNum <> 0 Then RevisionPrint = LastErNum = -2 Set Scr = Nothing GoTo exit2 Else there1: If pn& <> 0 And pn& < 5 And Not .lastprint Then If par Then If Not w4 Then If Not (.curPos = 0) Then If basestack.toprinter Then GetXYb2 Scr, prive, .curPos, .currow Else GetXYb Scr, prive, .curPos, .currow End If If pn& = 1 Then crNew basestack, prive: skiplast = True ElseIf pn& = 2 Then If Abs(w3) = 1 And .curPos = 0 And Not (.FTEXT = 9 Or .FTEXT = 5 Or .FTEXT = 6) Then If .FTEXT = 7 Then crNew basestack, prive: skiplast = True End If Else crNew basestack, prive: skiplast = True End If End If End If End If Else If f < 0 Then crNew basestack, prive ElseIf uni(f) Then putUniString f, vbCrLf Else putANSIString f, vbCrLf End If End If End If Exit Do End If conthere2: If .lastprint And opn& > 4 Then .lastprint = False If FastSymbol(rest$, ";") Then If par Then If opn& = 0 And (Not work) And (Not .lastprint) Then LCTbasket Scr, prive, .currow, .curPos End If opn& = 5 End If newntrance: work = True .lastprint = True Do While FastSymbol(rest$, ";") Loop ElseIf Not FastSymbol(rest$, ",") Then pn& = pn& + opn& opn& = 0 rest$ = NLtrim$(rest$) Final = myobject Is Nothing ElseIf par Then ihavecoma = True ' 'rest$ = "," & rest$ End If pn& = pn& + opn& Select Case pn& Case 0 Exit Do Case 1 If .FTXT = vbNullString Then If xa Then s$ = PACKLNG2$(p) Else If isboolean Then If ShowBooleanAsString Then s$ = format$(p, DefBooleanString) isboolean = False GoTo contboolean2 Else s$ = CStr(p * 1) isboolean = False GoTo contboolean2 End If Else On Error Resume Next Select Case MemByte(VarPtr(p)) Case 20 s$ = CStr(p) Case vbString s$ = LTrim$(p) Case 9 s$ = "*" + Typename$(p) Case 13 s$ = "*Unknown" Case Else s$ = fixthis(p) End Select If Err.Number > 0 Then If VarTypeName(p) = "Null" Then s$ = "NULL" Err.Clear Else s$ = VarTypeName(p) Err.Clear End If End If On Error GoTo 0 End If contboolean2: If .FTEXT < 4 Then If InStr(s$, ".") > 0 Then If InStr(s$, ".") <= .Column Then If RealLen(s$) > .Column + 1 Then If .FTEXT > 0 Then s$ = Left$(s$, .Column + 1) End If End If ElseIf .FTEXT > 0 Then If RealLen(s$) > .Column + 1 Then s$ = String$(.Column, "?") End If End If End If Else If TypeOf p Is Complex Then If p.i = 0 Then s$ = format$(p.r, .FTXT) ElseIf p.r = 0 Then s$ = "(" & format$(p.i, .FTXT) & "i)" Else If p.i < 0 Then s$ = "" Else s$ = "+" s$ = "(" & format$(p.r, .FTXT) & s$ & format$(p.i, .FTXT) & "i)" End If ElseIf Not anyBigInteger Is Nothing Then Set anyBigInteger = Nothing SwapString2Variant s$, p GoTo resumehere Else s$ = format$(p, .FTXT) End If If Not NoUseDec Then If mNoUseDec Then s$ = Replace$(s$, GetDeflocaleString(LOCALE_SDECIMAL), Chr(2)) If InStr(s$, "#IN") > 0 Then s$ = Replace$(s$, GetDeflocaleString(LOCALE_STHOUSAND) + "#", Chr(2) + "#") s$ = Replace$(s$, GetDeflocaleString(LOCALE_STHOUSAND), Chr(3)) s$ = Replace$(s$, Chr(2), NowDec$) s$ = Replace$(s$, Chr(3), NowThou$) ElseIf GetDeflocaleString(LOCALE_SDECIMAL) = "," Then s$ = Replace$(s$, ",", Chr(2)) s$ = Replace$(s$, ".", ",") s$ = Replace$(s$, Chr(2), ".") End If Else If InStr(s$, "#IN") > 0 Then s$ = Replace$(s$, ".#", NowDec$ + "#") End If resumehere: End If If par Then If .Column > 2 Then If opn& < 5 Then skiplast = False If Not TypeOf Scr Is MetaDc Then If .currow >= .mY And Not TypeOf Scr Is MetaDc Then If Not w4 Then crNew basestack, prive: skiplast = True End If End If If work Then .curPos = .curPos - ColOffset If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If w4 Then LCTbasketCur Scr, prive End If work = True End If If Not .curPos >= .mX Then If clearline And .curPos = 0 Then If Not TypeOf Scr Is MetaDc Then If Scr.ScaleMode = 0 Then Scr.Line (0&, Scr.ScaleY(.currow * .Yt, 0, 1))-(Scr.ScaleX((.mX - 1) * .Xt + .Xt * 2, 0, 1), Scr.ScaleY(.currow * .Yt + .Yt - 1 * DYP, 0, 1)), .Paper, BF Else Scr.Line (0&, .currow * .Yt)-((.mX - 1) * .Xt + .Xt * 2, (.currow) * .Yt + .Yt - 1 * DYP), .Paper, BF End If End If End If Select Case .FTEXT Case 0 PlainBaSket Scr, prive, space$(.Column - (RealLen(s$) - 1) Mod (.Column + 1)) + s$, w4, w4, , clearline Case 3 PlainBaSket Scr, prive, Right$(space$(.Column - (RealLen(s$) - 1) Mod (.Column + 1)) + Left$(s$, .Column + 1), .Column + 1), w4, w4, , clearline Case 2 If RealLen(s$) > .Column + 1 Then s$ = "????" PlainBaSket Scr, prive, Left$(space$((.Column + 1 - RealLen(s$)) \ 2) + Left$(s$, .Column + 1) + space$(.Column), .Column + 1), w4, w4, , clearline Case 1 PlainBaSket Scr, prive, Left$(s$ + space$(.Column), .Column + 1), w4, w4, , clearline Case 5 x1 = .curPos y1 = .currow If Not (.mX - 1 <= .curPos And w4 <> 0) Then LCTbasketCur Scr, prive Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 wwPlain basestack, prive, s$, .Column * .Xt + .Xt - (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2, 0, , True, 0, , CBool(w4), True, , True .currow = y1 .curPos = x1 + .Column + 1 End If If .curPos >= .mX And Not w4 Then .currow = .currow + 1 .curPos = 0 End If If .lastprint Then If Not TypeOf Scr Is MetaDc Then If .curPos = 0 Then If .currow >= .mY And Not TypeOf Scr Is MetaDc Then crNew basestack, prive Else LCTbasketCur Scr, prive End If End If End If Scr.currentX = .curPos * .X Scr.currentY = .currow * .Yt + .uMineLineSpace End If Case 4, 7, 8 wwPlain basestack, prive, s$ + vbCrLf, .Column * .Xt + .Xt - (.Xt - TextWidth(Scr, Right$(s$, 1))) \ 2, 0, , , 1, , , pn& < 5, , True .curPos = .curPos + .Column + 1 If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If If .lastprint Then If .curPos = 0 Then If .currow >= .mY And Not TypeOf Scr Is MetaDc Then crNew basestack, prive Else LCTbasketCur Scr, prive End If End If If .curPos > 0 Then Scr.currentX = .curPos * .Xt - (.Xt - TextWidth(Scr, Right$(s$, 1))) \ 2 Else Scr.currentX = .curPos * .Xt Scr.currentY = .currow * .Yt + .uMineLineSpace End If Case 6 wwPlain basestack, prive, s$, .Column * .Xt + .Xt, 0, , False, 2, , , pn& < 5, , True .curPos = .curPos + .Column + 1 If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If If .lastprint Then If .curPos = 0 Then If .currow >= .mY And Not TypeOf Scr Is MetaDc Then crNew basestack, prive Else LCTbasketCur Scr, prive End If End If Scr.currentX = .curPos * .Xt Scr.currentY = .currow * .Yt + .uMineLineSpace End If Case 9 LCTbasketCur Scr, prive wPlain Scr, prive, s$, 1000, 0, True GetXYb2 Scr, prive, .curPos, .currow .curPos = .curPos + 1 If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If If .lastprint Then If .curPos = 0 Then If .currow >= .mY And Not TypeOf Scr Is MetaDc Then crNew basestack, prive Else LCTbasketCur Scr, prive End If End If If .curPos > 0 Then Scr.currentX = .curPos * .Xt - (.Xt - TextWidth(Scr, Right$(s$, 1))) \ 2 Else Scr.currentX = .curPos * .Xt Scr.currentY = .currow * .Yt + .uMineLineSpace End If End Select End If Else PlainBaSket Scr, prive, s$ End If Else If f < 0 Then PlainBaSket Scr, prive, s$ ElseIf uni(f) Then putUniString f, s$ Else putANSIString f, s$ End If End If Case 2 '' for string If .FTXT <> "" Then s$ = format$(s$, .FTXT) End If If par Then If .Column > 0 Then x1 = .curPos: y1 = .currow skiplast = False If .currow >= .mY And Not w4 And Not TypeOf Scr Is MetaDc Then crNew basestack, prive skiplast = True End If If work Then .curPos = .curPos - ColOffset If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If w4 Then LCTbasketCur Scr, prive End If work = True If s$ = vbNullString Then s$ = " " If .curPos >= .mX Then y1 = 1 Else If clearline And .curPos = 0 Then If Not TypeOf Scr Is MetaDc Then If Scr.ScaleMode = 0 Then Scr.Line (0&, Scr.ScaleY(.currow * .Yt, 0, 1))-(Scr.ScaleX((.mX - 1) * .Xt + .Xt * 2, 0, 1), Scr.ScaleY(.currow * .Yt + .Yt - 1 * DYP, 0, 1)), .Paper, BF Else Scr.Line (0&, .currow * .Yt)-((.mX - 1) * .Xt + .Xt * 2, .currow * .Yt + .Yt - 1 * DYP), .Paper, BF End If End If End If Select Case .FTEXT Case 1 dlen = RealLen(s$) PlainBaSket Scr, prive, Left$(s$ + space$(Len(s$) - dlen + .Column - (dlen - 1) Mod (.Column + 1)), .Column + 1 + Len(s$) - dlen), w4, w4, , clearline Case 2 dlen = RealLen(s$) If dlen > (.Column + 1 + Len(s$) - dlen) Then s$ = Left$(s$, .Column + 1 + Len(s$) - dlen): dlen = RealLen(s$) PlainBaSket Scr, prive, Left$(space$((.Column + 1 + Len(s$) - dlen - dlen) \ 2) + s$ + space$(.Column), .Column + 1 + Len(s$) - dlen), w4, w4, , clearline Case 3 dlen = RealLen(s$) PlainBaSket Scr, prive, Right$(space$(.Column + Len(s$) - dlen - (dlen - 1) Mod (.Column + 1)) + s$, .Column + 1 + Len(s$) - dlen), w4, w4, , clearline Case 0 PlainBaSket Scr, prive, s$ + space$(.Column - (RealLen(s$) - 1) Mod (.Column + 1)), w4, w4, , clearline Case 4 LCTbasketCur Scr, prive Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 w3 = 0 wwPlain basestack, prive, s$, Scr.Width, 0, , True, 0, , w3, True w3 = w3 \ .Xt + 1 .curPos = (.Column + 1) * ((w3 + .Column + 1) \ (.Column + 1)) If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If Case 5 LCTbasketCur Scr, prive Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 wwPlain basestack, prive, s$, .Column * .Xt + .Xt - (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2, 0, , True, 3, , , True .curPos = .curPos + .Column + 1 If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If Case 6 wwPlain basestack, prive, s$, .Column * .Xt + .Xt, 0, , False, 2, , , True .curPos = .curPos + .Column + 1 If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If Case 7 LCTbasketCur Scr, prive work2 = Scr.currentY wwPlain basestack, prive, s$ + vbCrLf, .Column * .Xt + .Xt - (.Xt - TextWidth(Scr, Right$(s$, 1))) \ 2, 0, , True, 1, , , True, , True Scr.currentY = work2 .curPos = .curPos + .Column + 1 If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If Case 8 LCTbasketCur Scr, prive Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 If Not (.mX - 1 <= x1 And w4 <> 0) Then wwPlain basestack, prive, s$, .Column * .Xt + .Xt - (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2, 0, , True, 0, , , True End If .curPos = .curPos + .Column + 1 If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If Case 9 LCTbasketCur Scr, prive wPlain Scr, prive, s$, .Column + 1, 0, True GetXYb2 Scr, prive, .curPos, .currow .curPos = .curPos + 1 If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If .curPos >= .mX And Not w4 Then .curPos = 0 .currow = .currow + 1 End If End Select End If Else PlainBaSket Scr, prive, s$ End If Else If f < 0 Then PlainBaSket Scr, prive, s$, , , , , True ElseIf uni(f) Then putUniString f, s$ Else putANSIString f, s$ End If End If Case 6 If par Then If .FTEXT > 3 Then w3 = 0 x1 = .curPos y1 = .currow If .FTXT <> "" Then If TypeOf p Is Complex Then If p.i = 0 Then s$ = format$(p.r, .FTXT) ElseIf p.r = 0 Then s$ = "(" & format$(p.i, .FTXT) & "i)" Else If p.i < 0 Then s$ = "" Else s$ = "+" s$ = "(" & format$(p.r, .FTXT) & s$ & format$(p.i, .FTXT) & "i)" End If Else s$ = format$(p, .FTXT) End If If Not NoUseDec Then If mNoUseDec Then s$ = Replace$(s$, GetDeflocaleString(LOCALE_SDECIMAL), Chr(2)) If InStr(s$, "#IN") > 0 Then s$ = Replace$(s$, GetDeflocaleString(LOCALE_STHOUSAND) + "#", Chr(2) + "#") s$ = Replace$(s$, GetDeflocaleString(LOCALE_STHOUSAND), Chr(3)) s$ = Replace$(s$, Chr(2), NowDec$) s$ = Replace$(s$, Chr(3), NowThou$) ElseIf GetDeflocaleString(LOCALE_SDECIMAL) = "," Then s$ = Replace$(s$, ",", Chr(2)) s$ = Replace$(s$, ".", ",") s$ = Replace$(s$, Chr(2), ".") End If Else If InStr(s$, "#IN") > 0 Then s$ = Replace$(s$, ".#", NowDec$ + "#") End If If .FTEXT > 4 And Not work Then Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 If Scr.currentX < .mX * .Xt Then wwPlain basestack, prive, s$, Scr.Width, 0, , True, 0, , w3 End If Else If xa Then s$ = PACKLNG2$(p) Else If CheckInt64(p) Then s$ = CStr(p) ElseIf VarType(p) = vbString Then s$ = LTrim$(p) Else s$ = fixthis(p) End If End If If .FTEXT > 4 And Not work Then Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 wwPlain basestack, prive, s$, Scr.Width, 0, , True, 0, , w3 work = True Scr.currentX = w3 End If Else If .FTXT = vbNullString Then If xa Then PlainBaSket Scr, prive, PACKLNG2$(p) Else If CheckInt64(p) Then s$ = CStr(p) ElseIf VarType(p) = vbString Then s$ = LTrim$(p) Else s$ = fixthis(p) End If PlainBaSket Scr, prive, s$ End If Else If TypeOf p Is Complex Then If p.i = 0 Then s$ = format$(p.r, .FTXT) ElseIf p.r = 0 Then s$ = "(" & format$(p.i, .FTXT) & "i)" Else If p.i < 0 Then s$ = "" Else s$ = "+" s$ = "(" & format$(p.r, .FTXT) & s$ & format$(p.i, .FTXT) & "i)" End If Else If Left$(.FTXT, 1) = "#" Then s$ = space$(Len(.FTXT)) RSet s$ = format$(p, .FTXT) Else s$ = format$(p, .FTXT) End If End If If Not NoUseDec Then If mNoUseDec Then s$ = Replace$(s$, GetDeflocaleString(LOCALE_SDECIMAL), Chr(2)) If InStr(s$, "#IN") > 0 Then s$ = Replace$(s$, GetDeflocaleString(LOCALE_STHOUSAND) + "#", Chr(2) + "#") s$ = Replace$(s$, GetDeflocaleString(LOCALE_STHOUSAND), Chr(3)) s$ = Replace$(s$, Chr(2), NowDec$) s$ = Replace$(s$, Chr(3), NowThou$) ElseIf GetDeflocaleString(LOCALE_SDECIMAL) = "," Then s$ = Replace$(s$, ",", Chr(2)) s$ = Replace$(s$, ".", ",") s$ = Replace$(s$, Chr(2), ".") End If Else If InStr(s$, "#IN") > 0 Then s$ = Replace$(s$, ".#", NowDec$ + "#") End If PlainBaSket Scr, prive, s$ End If End If Else If f < 0 Then PlainBaSket Scr, prive, s$ ElseIf uni(f) Then putUniString f, s$ Else putANSIString f, s$ End If End If Case 7 If par Then If s$ <> "" Then If .FTEXT > 3 Then w3 = 0 x1 = .curPos y1 = .currow If Not work Then LCTbasketCur Scr, prive If .FTXT <> "" Then s$ = format$(s$, .FTXT) If .FTEXT > 4 And Not work Then Scr.currentX = Scr.currentX + (.Xt - TextWidth(Scr, Left$(s$, 1))) \ 2 wwPlain basestack, prive, s$, Scr.Width, 0, , True, 0, , w3 work = True Scr.currentX = w3 Else If .FTXT <> "" Then PlainBaSket Scr, prive, format$(s$, .FTXT), , , , clearline, , True Else PlainBaSket Scr, prive, s$, , , , clearline, , True End If End If End If Else If f < 0 Then PlainBaSket Scr, prive, s$ ElseIf uni(f) Then putUniString f, s$ Else putANSIString f, s$ End If End If End Select taketwo: If ihavecoma Then ihavecoma = False GoTo cont12344 ElseIf FastSymbol(rest$, ",") Then cont12344: w3 = 1 pn& = 0 If opn& > 4 Then Scr.currentX = Scr.currentX + .Xt - dv15 If basestack.toprinter Then GetXYb2 Scr, prive, .curPos, .currow Else GetXYb Scr, prive, .curPos, .currow End If If work Then .curPos = .curPos - ColOffset If (.curPos Mod (.Column + 1)) <> 0 Then .curPos = .curPos + (.Column + 1) - (.curPos Mod (.Column + 1)) + ColOffset Else .curPos = .curPos + ColOffset End If If w4 Then LCTbasketCur Scr, prive End If work = True Else work = False End If opn& = 0 Do While FastSymbol(rest$, ",") If par Then If .Column > .mX And .FTEXT < 4 Then Else If Not w4 Then If Not skiplast Then crNew basestack, prive End If End If Else If f < 0 Then crNew basestack, prive ElseIf uni(f) Then putUniString f, vbCrLf Else putANSIString f, vbCrLf End If End If Loop End If If par Or f < 0 Then players(basketcode) = prive Loop there: If w4 <> 0 And par Then .FTEXT = oldFTEXT .FTXT = oldFTXT .Column = oldcol If .mypen <> oldpen Then .mypen = oldpen: TextColor Scr, oldpen ElseIf par Then If pn& > 4 And opn& = 0 Then If pn& < 99 Then If work Then .lastprint = False End If If Not skiplast Then crNew basestack, prive End If ElseIf (.currow >= .mY And Not TypeOf Scr Is MetaDc) Or (w3 < 0 And pn& = 0) Then JUMPHERE: crNew basestack, prive LCTbasketCur Scr, prive 'ElseIf pn& > 4 Then End If End If EXITNOW: If basestack.IamThread Then ElseIf par Or f < 0 Then If Not extreme Then PrintRefresh basestack, Scr End If End If RevisionPrint = True If par Or f < 0 Then players(basketcode) = prive If basketcode > 32 Then If .ShowCaret Then LCTCnew Scr, prive, .currow, .curPos ShowCaret Scr.hWnd players(basketcode) = prive End If End If End If End With exit2: If Len(rest$) > 0 Then If Len(rest$) < where Then If where - Len(rest$) = 1 Then Mid$(rest1$, 1, Len(rest$)) = rest$ ElseIf where - Len(rest$) <= Len(rest1$) Then Mid$(rest1$, where - Len(rest$), Len(rest$)) = rest$ rest1$ = Mid$(rest1$, where - Len(rest$)) End If Else rest1$ = rest$ + rest1$ End If Else rest1$ = Mid$(rest1$, where) End If If Len(rest1$) > 0 Then ' unhandled symbols ?? ' accepted If Not MaybeIsSymbol3lot(rest1$, b12345, i) Then If i > Len(rest1$) Then rest1$ = vbNullString Else SyntaxError RevisionPrint = False End If End If End If End Function Public Function CheckStackObj(bstack As basetask, anything As Object, Optional counter As Long) As Boolean Dim usehandler As mHandler If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj If usehandler.t1 <> 3 Then Exit Function counter = usehandler.index_cursor + 1 Set anything = bstack.lastobj Set bstack.lastobj = Nothing If CheckDeepAny(anything) Then CheckStackObj = True End If End Function Function IsEnumLabelOnly(bstack As basetask, b$) As Boolean Dim usehandler0 As mHandler, usehandler As mHandler, ss$, i As Long, that, once As Boolean If lookOne(b$, ".") Then If IsNumber(bstack, b$, that) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler0 = bstack.lastobj Set bstack.lastobj = Nothing GoTo conthere1012 End If End If End If ElseIf FastPureLabel(b$, ss$) = 1 Then If GetVar(bstack, myUcase(ss$), i) Then If TypeOf var(i) Is mHandler Then Set usehandler0 = var(i) conthere1012: If usehandler0.t1 = 4 Then Set usehandler = New mHandler usehandler.t1 = 4 Set usehandler.objref = usehandler0.objref usehandler.index_start = usehandler0.index_start usehandler.index_cursor = usehandler0.index_cursor usehandler.sign = 1 Set bstack.lastobj = usehandler IsEnumLabelOnly = True Exit Function End If End If End If End If End Function Function IsEnumAs(bstack As basetask, b$, p, Optional initval As Boolean, Optional part$) As Boolean initval = False Dim usehandler0 As mHandler, usehandler As mHandler, ss$, i As Long, that, once As Boolean If lookOne(b$, ".") Then If IsNumber(bstack, b$, that) Then If bstack.lastobj Is Nothing Then GoTo aa2 If TypeOf bstack.lastobj Is mHandler Then Set usehandler0 = bstack.lastobj Set bstack.lastobj = Nothing GoTo conthere1001 End If End If GoTo aa2 ElseIf FastPureLabel(b$, ss$) = 1 Then backhere: If GetVar(bstack, myUcase(ss$), i) Then If MyIsObject(var(i)) Then If TypeOf var(i) Is mHandler Then Set usehandler0 = var(i) conthere1001: If usehandler0.t1 = 4 And usehandler0.IamEnum = False Then Set usehandler = New mHandler usehandler.t1 = 4 Set usehandler.objref = usehandler0.objref usehandler.index_start = 0 usehandler.index_cursor = usehandler0.objref.ZeroValue If p < 0 Then usehandler.sign = -1 Else usehandler.sign = 1 End If Set p = usehandler If Len(part$) = 0 Then If FastSymbol(b$, "=") Then If lookOne(b$, ".") Then If IsNumber(bstack, b$, that) Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler0 = bstack.lastobj Set bstack.lastobj = Nothing GoTo conthere1012 End If End If End If ElseIf FastPureLabel(b$, ss$) = 1 Then If GetVar(bstack, myUcase(ss$), i) Then If TypeOf var(i) Is mHandler Then Set usehandler0 = var(i) conthere1012: If usehandler0.t1 = 4 Then If usehandler0.objref.EnumName = usehandler.objref.EnumName Then initval = True usehandler.index_start = usehandler0.index_start usehandler.index_cursor = usehandler0.index_cursor usehandler.sign = 1 IsEnumAs = True Exit Function Else usehandler0.CopyTo usehandler0 If usehandler.objref.ExistFromOther2(usehandler0) Then Set usehandler0.objref = usehandler.objref initval = True Set usehandler = usehandler0 usehandler.sign = 1 Set p = usehandler IsEnumAs = True Exit Function End If End If End If End If End If End If Else IsEnumAs = True Exit Function End If ElseIf FastSymbol(part$, "=") Then If lookOne(part$, ".") Then If IsNumber(bstack, part$, that) Then checknow: If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set usehandler0 = bstack.lastobj Set bstack.lastobj = Nothing GoTo conthere1002 End If End If End If ElseIf FastPureLabel(part$, ss$) = 1 Then If GetVar(bstack, myUcase(ss$), i) Then If TypeOf var(i) Is mHandler Then Set usehandler0 = var(i) conthere1002: If usehandler0.t1 = 4 Then If usehandler0.objref.EnumName = usehandler.objref.EnumName Then initval = True usehandler.index_start = usehandler0.index_start usehandler.index_cursor = usehandler0.index_cursor usehandler.sign = 1 initval = True IsEnumAs = True Exit Function Else usehandler0.CopyTo usehandler0 If usehandler.objref.ExistFromOther2(usehandler0) Then Set usehandler0.objref = usehandler.objref initval = True Set usehandler = usehandler0 usehandler.sign = 1 Set p = usehandler IsEnumAs = True Exit Function End If End If End If End If Else If Len(bstack.UseGroupname) > 0 Then If IsNumber(bstack, "." + ss$, that) Then GoTo checknow End If End If End If End If Else IsEnumAs = True Exit Function End If ElseIf usehandler0.t1 = 5 Then Dim aa As MemBlock Set aa = New MemBlock If MemInt(VarPtr(p)) = vbString Then SwapString2Variant ss$, p p = LenB(ss$) \ usehandler0.objref.structLen If p < 0 Then p = 1 aa.Construct usehandler0.objref.structLen, CLng(p), 8&, False, 1 aa.UseStruct = True p = (-OneLongLong And aa.GetPtr(0&)) i = MemLong(VarPtr(p) + 8) If aa.ValidArea(i, CVar(LenB(ss$))) Then CopyMemory ByVal i, ByVal StrPtr(ss$), LenB(ss$) End If Else If FastSymbol(b$, "*") Then If Not IsExp(bstack, b$, p, True, True, , , True) Then MissNumExpr Exit Function End If Else p = 1 End If aa.Construct usehandler0.objref.structLen, CLng(p), 8&, False, 1 aa.UseStruct = True End If Set aa.structref = usehandler0.objref Set usehandler0 = New mHandler Set usehandler0.objref = aa usehandler0.t1 = 2 Set p = usehandler0 initval = True IsEnumAs = True Exit Function End If End If End If ElseIf once Then ElseIf Len(bstack.UseGroupname) > 0 Then ss$ = bstack.UseGroupname + ss$ once = True GoTo backhere End If Else aa2: ExpectedEnumType End If End Function Public Function exeSelect(ExecuteLong, once As Boolean, bstack As basetask, b$, v As Long, Lang As Long) As Boolean Dim ok As Boolean, x1 As Long, y1 As Long, sp As Variant, st As Variant, sw$, slct As Long, ss$ Dim x2 As Long, y2 As Long, p As Variant, W$, dum As Boolean, i As Long, nd&, usehandler As mHandler Dim checkenum As Boolean, enumindex As Long, EnumName As String, that As BigInteger, ifcount As Long Dim Pos As Long, sPos As Long, comments As Long exeSelect = True x1 = 0 ' mode numbers using p, sp and st If IsLabelSymbolNew(b$, "ΜΕ", "CASE", Lang) Then If IsExpBig(bstack, b$, sp, , Not checkenum) Then If myVarType(sp, vbString) Then sw$ = sp x1 = 2 Else If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then Set that = bstack.lastobj End If End If Set bstack.lastobj = Nothing x1 = 1 End If ElseIf IsStrExp(bstack, b$, sw$) Then x1 = 2 End If secondentry: MarkSel bstack, Lang If x1 > 0 Then ' SELECT CASE NUMBER or STRING SetNextLine b$ While MaybeIsSymbol(b$, RemChar) SetNextLine b$ Wend slct = 1 If NocharsInLine(b$) Then ExpectedCaseorElseorEnd ExecuteLong = 0 Exit Function End If Do If NocharsInLine(b$) Then Exit Do If slct = 0 And ok Then GoTo againcont2 End If IsNumberLabel b$, vbNullString If IsLabelSymbolNew(b$, "ΜΕ", "CASE", Lang) Then ' WE HAVE CASE Pos = 0 If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo jumphere02 Else GoTo jumphere01 End If findit: Pos = 0 If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo jumphere2 jumphere1: If ifcount = 0 Then If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then GoTo case1else End If End If jumphere01: If ok Then ExpectedEndSelect ExecuteLong = 0 Exit Function End If If slct > 0 Then ' WE ARE IN SEARCH Do x2 = 0 If x1 = 1 Then If IsExpBig(bstack, b$, p, , Not checkenum) Then If Not that Is Nothing Then If bstack.lastobj Is Nothing Then Set bstack.lastobj = Module13.CreateBigInteger(format$(Int(p), "0")) ElseIf Not TypeOf bstack.lastobj Is BigInteger Then Set bstack.lastobj = Nothing GoTo err001101 End If If IsLabelSymbolNew(b$, "ΕΩΣ", "TO", Lang) Then Dim that1 As BigInteger Set that1 = bstack.lastobj If IsExpBig(bstack, b$, p, , Not checkenum) Then If bstack.lastobj Is Nothing Then Set bstack.lastobj = Module13.CreateBigInteger(format$(Int(p), "0")) ElseIf Not TypeOf bstack.lastobj Is BigInteger Then Set bstack.lastobj = Nothing GoTo err001101 End If If (that.compare(that1) > -1 And that.compare(bstack.lastobj) < 1) Or slct = -1 Then Set that1 = Nothing Set bstack.lastobj = Nothing If slct = 1 Then slct = 0: GoTo selslct0 GoTo contLoop End If Set that1 = Nothing Set bstack.lastobj = Nothing GoTo contLoop Else Set bstack.lastobj = Nothing GoTo err001101 End If ElseIf that.compare(bstack.lastobj) = 0 Or slct = -1 Then Set bstack.lastobj = Nothing If slct = 1 Then slct = 0: GoTo selslct0 GoTo contLoop End If Set bstack.lastobj = Nothing GoTo contLoop ElseIf checkenum Then If bstack.lastobj Is Nothing Then GoTo cont00123 If Not TypeOf bstack.lastobj Is mHandler Then GoTo err001101 Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing If usehandler.t1 <> 4 Then GoTo err001101 usehandler.objref.index = usehandler.index_start If EnumName = usehandler.objref.KeyToString() Or slct = -1 Then Set usehandler = Nothing If slct = 1 Then slct = 0: GoTo selslct0 GoTo contLoop End If ElseIf Not bstack.lastobj Is Nothing Then If Not TypeOf bstack.lastobj Is BigInteger Then GoTo err001101 End If Set that = bstack.lastobj If that.compare(Module13.CreateBigInteger(format$(Int(sp), "0"))) = 0 Or slct = -1 Then Set bstack.lastobj = Nothing Set that = Nothing If slct = 1 Then slct = 0: GoTo selslct0 GoTo contLoop End If Set bstack.lastobj = Nothing Set that = Nothing Else cont00123: If MemInt(VarPtr(p)) = vbString Then SwapString2Variant W$, p: x2 = 2 Else x2 = 1 End If ElseIf IsStrExp(bstack, b$, W$) Then x2 = 2 End If Else If IsExp(bstack, b$, p, , Not checkenum) Then If MemInt(VarPtr(p)) = vbString Then W$ = p: x2 = 2 Else y1 = UINT(p) If y1 >= &H10000 And y1 <= &H10FFFF Then y1 = y1 - &H10000 W$ = ChrW(UINT(y1 \ &H400& + &HD800&)) + ChrW(UINT((y1 And &H3FF&) + &HDC00&)) Else W$ = ChrW$(y1) End If y1 = 0 x2 = 2 End If ElseIf IsStrExp(bstack, b$, W$, False) Then x2 = 2 End If End If If x2 > 0 Then 'WE HAVE NUMBER OR STRING If checkenum Then ' do nothing GoTo CONT1234 ElseIf IsLabelSymbolNew(b$, "ΕΩΣ", "TO", Lang) Then ' range ? y1 = 0 If x1 = 1 Then If IsExp(bstack, b$, st, , True) Then If MemInt(VarPtr(st)) = vbString Then st = 0 End If y1 = 1 Else End If Else If IsStrExp(bstack, b$, ss$) Then y1 = 2 ElseIf IsExp(bstack, b$, st, , True) Then If MemInt(VarPtr(st)) = vbString Then SwapString2Variant ss$, st y1 = 2 Else y1 = UINT(st) If y1 >= &H10000 And y1 <= &H10FFFF Then y1 = y1 - &H10000 ss$ = ChrW(UINT(y1 \ &H400& + &HD800&)) + ChrW(UINT((y1 And &H3FF&) + &HDC00&)) Else ss$ = ChrW$(y1) End If y1 = 2 End If End If End If If y1 > 0 Then y2 = 0 If x1 = 1 Then If (sp >= p And sp <= st) Then y2 = 1 Else If sw$ >= W$ And sw$ <= ss$ Then y2 = 2 End If If y2 > 0 Or slct = -1 Then 'slct=-1 from break If slct = 1 Then slct = 0 ' slct=0 we found ' start ExecuteLong command or block End If Else MyEr "Wrong expression type in To clause in Case", "Λάθος τύπος έκφρασης στην Έως στην Με" ExecuteLong = 0 Exit Function End If Else CONT1234: ' NO WE HAVE ONE VALUE...X1 MASTER, X2 ONE VALUE Y2 FOR LAST CHECK y2 = 0 If x1 = 1 Then If sp = p And x2 = 1 Then y2 = 1 Else If W$ = sw$ Then y2 = 2 End If If y2 > 0 Or slct = -1 Then ' ONE VALUE If slct = 1 Then slct = 0 End If End If ElseIf Not checkenum Then If Not that Is Nothing Then Set p = that Else If x1 = 2 Then p = sw$ Else p = sp End If End If If IsHalfLogic(bstack, b$, p) Then If p <> 0 Or slct = -1 Then If slct = 1 Then slct = 0 ' start ExecuteLong command or block End If Else MyEr "Expected logic half expression in Case", "Περίμενα λογική μισή έκφραση στην Με" ExecuteLong = 0 Exit Function End If End If If slct = 0 Then selslct0: SetNextLine b$ comments = 0 Do While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString comments = comments + 1 Loop ' GoTo againcont If comments = 0 Then While IsLabelSymbolNew(b$, "ΜΕ", "CASE", Lang) If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then dum = False Pos = 0 GoTo jumphere2 End If SetNextLine b$ Wend While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString Wend End If If FastSymbol(b$, "{") Then GoTo haveblock Else GoTo Process End If conthere: If FastSymbol(b$, "{") Then ' block haveblock: ss$ = block(b$) dum = False i = 1 ' #3 call a block TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(i, bstack, ss$, False, dum, , True) TraceRestore bstack, nd& If i = 1 Then FastSymbol b$, "}" If Not MaybeIsSymbol(b$, RemChar) Then If Not Left$(b$, 2) = vbCrLf Then ExpectedCommentsOnly ExecuteLong = 0: Exit Function End If End If Pos = -100 Else If i = 0 Then b$ = ss$ + b$ ExecuteLong = 0: Exit Function ElseIf i = 2 Then If Len(ss$) > 0 Then b$ = ss$ If dum = True And b$ <> "" Then slct = -1 Else GoTo ContGoto End If ElseIf i = 3 Then If Len(ss$) > 0 Then b$ = ss$ If dum = True And b$ <> "" Then slct = 0 End If End If Else ' or line dum = True i = 1 IsNumberLabel b$, vbNullString While IsLabelSymbolNew(b$, "ΜΕ", "CASE", Lang) While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString Wend Wend ' #4 call one command checknext: If lookOne(b$, "{") Then GoTo conthere End If i = 1 While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString Wend Process: once = False 'Len(b$) = 0 i = 50 Call Module10.executeblock(i, bstack, b$, once, dum, , True) If i = 0 Then ExecuteLong = 0: Exit Function ElseIf i = 50 Then ' we have TO EXIT ExecuteLong = 1 exeSelect = True ' once = False Exit Function ElseIf i = 51 Then DropMarkSel bstack ExecuteLong = 1 'once = True exeSelect = False Exit Function ElseIf i = 100 Then ' we have a case If NOEXECUTION Then ExecuteLong = 1 exeSelect = True Exit Function Else dum = False slct = 0 Pos = 0 ' A CASE TO SKIP If once Then If ok Then ExpectedEndSelect ExecuteLong = 0 Exit Function Else ok = True End If End If End If ElseIf i = 1 And b$ = vbNullString And once Then 'this is an exit ΟΚ3 exeSelect = False ExecuteLong = 1 Exit Function ElseIf i = 2 Then If dum = True And Len(b$) > 0 Then ' 1 slct = -1 ElseIf Len(b$) > 0 Then DropMarkSel bstack ExecuteLong = 2 once = False Exit Function Else ExecuteLong = i DropMarkSel bstack exeSelect = dum Exit Function End If ElseIf i = 3 Then If dum = True And Len(b$) > 0 Then slct = 0 Else i = 2 b$ = vbNullString exeSelect = True End If ElseIf i = 5 Then ExecuteLong = 2 exeSelect = False Else dum = True End If End If Exit Do End If contLoop: Loop While FastSymbol(b$, ",") End If againcont: SetNextLine b$ againcont2: comments = 0 While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString comments = comments + 1 Wend IsNumberLabel b$, vbNullString If comments = 0 Then If Not ok Then If IsLabelSymbolNew(b$, "ΜΕ", "CASE", Lang) Then dum = False Pos = 0 GoTo jumphere1 End If If ifcount = 0 Then If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then dum = False Pos = 0 GoTo jumphere2 End If End If End If If IsLabelSymbolNew(b$, "ΤΕΛΟΣ", "END", Lang) Then dum = False GoTo jumphere3 End If End If If FastSymbol(b$, "{") Then If Pos = -100 Or (dum And Not slct = 0) Then er100: MyEr "to many blocks for Select Case", "πολλά μπλοκ στην Επίλεξε Με" exeSelect = False Exit Function End If If slct >= 0 Then ss$ = block(b$) + "}" b$ = NLtrim$(Mid$(b$, 2)) Else ss$ = block(b$) dum = False i = 1 ' #7 call block inside Case (Break) ok TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(i, bstack, ss$, False, dum, , True) TraceRestore bstack, nd& If i = 1 Then FastSymbol b$, "}" If Not MaybeIsSymbol(b$, RemChar) Then If Not Left$(b$, 2) = vbCrLf Then ExpectedCommentsOnly ExecuteLong = 0: Exit Function End If End If Else If i = 0 Then b$ = ss$ + b$ ExecuteLong = 0: Exit Function ElseIf i = 2 Then If Len(ss$) > 0 Then b$ = ss$ If dum = True And b$ <> "" Then slct = -1 Else GoTo ContGoto End If ElseIf i = 3 Then If Len(ss$) > 0 Then b$ = ss$ If dum And b$ <> "" Then slct = 0 Pos = 1 GoTo againcont End If End If End If End If Pos = -100 SetNextLine b$ ElseIf slct < 0 Then dum = True i = 1 ' #8 call one command inside Case (Break) ok once = False Call Module10.executeblock(i, bstack, b$, once, dum, , True) ', True, True) If i = 0 Then ExecuteLong = 0: Exit Function ElseIf i = 100 Then ' we have a case If NOEXECUTION Then ExecuteLong = 1 exeSelect = True Exit Function Else dum = False Pos = 0 If once Then If ok Then ExpectedEndSelect ExecuteLong = 0 Exit Function Else slct = 0 ok = True End If Else GoTo jumphere1 End If End If ElseIf i = 1 And b$ = vbNullString And once Then 'this is an exit ΟΚ3 b$ = vbNullString ExecuteLong = 1 Exit Function ElseIf i = 2 Then ' 2 If dum = True And Len(b$) > 0 Then slct = -1 ElseIf Len(b$) > 0 Then DropMarkSel bstack ExecuteLong = 2 once = False Exit Function Else ExecuteLong = i DropMarkSel bstack exeSelect = dum Exit Function End If ElseIf i = 3 Then If dum = True And b$ <> "" Then slct = 0 Else i = 2 b$ = vbNullString exeSelect = True End If ElseIf i = 5 Then ExecuteLong = 2 exeSelect = False Else If i = 1 Then GoTo againcont End If SetNextLine b$ Else jump123: If dum Then IsNumberLabel b$, vbNullString: GoTo checknext ''??? Else IsNumberLabel b$, "" Pos = 1 Pos = MyTrimLi(b$, Pos) If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then Select Case ss$ Case "CASE" If Lang = 1 Then b$ = Mid$(b$, Pos): GoTo findit GoTo faultlang Case "ΜΕ" If Lang <> 1 Then b$ = Mid$(b$, Pos): GoTo findit faultlang: MyEr "Wrong language for Select", "Κακή γλώσσα για την Επίλεξε" Exit Function Case "IF" sPos = Pos ss$ = vbNullString aheadstatusIFthen b$, sPos, 1, ss$ If Len(ss$) <> 0 Then ifcount = ifcount + 1 b$ = Mid$(b$, sPos) Pos = 1 GoTo againcont Case "AN" sPos = Pos ss$ = vbNullString aheadstatusIFthen b$, sPos, 0, ss$ If Len(ss$) <> 0 Then ifcount = ifcount + 1 b$ = Mid$(b$, sPos) Pos = 1 GoTo againcont Case "ΕΠΙΛΕΞΕ" sPos = Module1.DropSelect2(b$, 0, Pos - 7) If sPos = 0 Then exeSelect = False Exit Function Else b$ = Mid$(b$, sPos) End If Pos = 1 Case "SELECT" sPos = Module1.DropSelect2(b$, 1, Pos - 6) If sPos = 0 Then exeSelect = False Exit Function Else b$ = Mid$(b$, sPos) End If Pos = 1 Case Else Pos = Pos - 1 Do Pos = Pos + 1 aheadstatusSkipParam b$, Pos Loop While Mid$(b$, Pos) = ":" If Pos > 1 Then b$ = Mid$(b$, Pos) Pos = 1 SetNextLine b$ End Select Else Pos = 0 Do Pos = Pos + 1 aheadstatusSkipParam b$, Pos Loop While Mid$(b$, Pos) = ":" If Pos > 1 Then b$ = Mid$(b$, Pos) SetNextLine b$ Pos = 1 End If End If End If Else If ifcount = 0 Then If IsLabelSymbolNew(b$, "ΑΛΛΙΩΣ", "ELSE", Lang) Then jumphere2: IsLabelSymbolNew b$, "ΜΕ", "CASE", Lang case1else: If ok Then ExpectedEndSelect ExecuteLong = 0 Exit Function Else ok = True End If jumphere02: case2: SetNextLine b$ While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString Wend If IsLabelSymbolNew(b$, "ΤΕΛΟΣ", "END", Lang) Then 'slct = 0 If IsLabelSymbolNew(b$, "ΕΠΙΛΟΓΗΣ", "SELECT", Lang) Then slct = 0 DropMarkSel bstack Exit Do End If ' b$ = "" ' Exit Do End If If FastSymbol(b$, "{") Then ss$ = block(b$) If slct > 0 Then dum = False i = 1 ' #9 call block inside Else TraceStore bstack, nd&, b$, 0 Call Module10.executeblock(i, bstack, ss$, False, dum, , True) TraceRestore bstack, nd& If i = 1 Then FastSymbol b$, "}" If Not MaybeIsSymbol(b$, RemChar) Then If Not Left$(b$, 2) = vbCrLf Then ExpectedCommentsOnly ExecuteLong = 0: Exit Function End If End If Else If i = 0 Then b$ = ss$ + b$ ExecuteLong = 0: Exit Function ElseIf i = 2 Then If Len(ss$) > 0 Then b$ = ss$ If dum = True And b$ <> "" Then slct = -1 ElseIf b$ <> "" Then GoTo ContGoto Else once = True Exit Function End If ElseIf i = 3 Then If Len(ss$) > 0 Then b$ = ss$ If dum = True And b$ <> "" Then slct = 0: b$ = Mid$(b$, 2): GetNextLine (ss$) End If End If Else b$ = NLtrim$(Mid$(b$, 2)) End If Else If slct > 0 Then dum = True again1123: If NocharsInLine(b$) Then Exit Do i = 1 ' #10 call one command inside ELSE once = False Call Module10.executeblock(i, bstack, b$, once, dum, , True) 'TraceRestore bstack, nd& If i = 0 Then ExecuteLong = 0: Exit Function ElseIf i = 51 Then DropMarkSel bstack ExecuteLong = 1 exeSelect = False Exit Function ElseIf i = 50 Then ExecuteLong = 1 exeSelect = dum Exit Function ElseIf i = 1 And b$ = vbNullString And once Then 'this is an exit b$ = vbNullString ExecuteLong = 1 Exit Function ElseIf i = 2 Then ' 3 If dum = True And Len(b$) > 0 Then slct = -1 ElseIf Len(b$) > 0 Then DropMarkSel bstack ExecuteLong = 2 once = False Exit Function Else ExecuteLong = i DropMarkSel bstack exeSelect = dum Exit Function End If ElseIf i = 3 Then If dum = True And b$ <> "" Then slct = 0 Else i = 2 b$ = vbNullString exeSelect = True End If ElseIf i = 5 Then ExecuteLong = 2 exeSelect = False Else If NOEXECUTION Then ExecuteLong = 1 exeSelect = False Exit Function End If SetNextLine b$ If IsLabelSymbolNew(b$, "ΤΕΛΟΣ", "END", Lang) Then slct = 0 GoTo jumphere3 Else GoTo again1123 End If End If End If End If SetNextLine b$ While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString Wend slct = 0 GoTo CONT0001 End If End If If IsLabelSymbolNew(b$, "ΤΕΛΟΣ", "END", Lang) Then If ifcount > 0 Then If IsLabelSymbolNew(b$, "ΑΝ", "IF", Lang) Then ifcount = ifcount - 1 GoTo againcont End If End If jumphere3: If IsLabelSymbolNew(b$, "ΕΠΙΛΟΓΗΣ", "SELECT", Lang) Then DropMarkSel bstack exeSelect = False ' need false to continue to other commands in execute Exit Function ' slct = 0 ' Exit Do ' ElseIf slct <> 1 Then ' b$ = "" ' slct = 0 ' Exit Do End If Else While DropCommentOrLine(b$, False) IsNumberLabel b$, vbNullString Wend If lookOne(b$, "{") Then If Pos = -100 Then GoTo er100 Else Pos = -100 End If Else GoTo jump123 End If End If End If CONT0001: Loop If slct > 0 Then ExecuteLong = 0: Exit Function End If Else ExecuteLong = 0 Exit Function End If ElseIf IsLabelSymbolNew(b$, "ΑΠΑΡ", "ENUM", Lang) Then here12002: If IsExp(bstack, b$, sp) Then If bstack.lastobj Is Nothing Then GoTo err001101 If Not TypeOf bstack.lastobj Is mHandler Then GoTo err001101 Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing If usehandler.t1 <> 4 Then GoTo err001101 sp = usehandler.index_cursor If myVarType(sp, vbString) Then sw$ = sp x1 = 2 Else x1 = 1 End If enumindex = usehandler.index_start usehandler.objref.index = enumindex EnumName = usehandler.objref.KeyToString() checkenum = True Set usehandler = Nothing GoTo secondentry End If GoTo err001101 ElseIf IsLabelSymbolNew(b$, "ΑΠΑΡΙΘΜΗΣΗ", "ENUMERATION", Lang) Then GoTo here12002 Else err001101: ExecuteLong = 0 Exit Function End If exeSelect = False Exit Function ContGoto: If MyTrim$(b$) = vbNullString Or FastSymbol(b$, ":") Then ExecuteLong = 0 MissingLabel Exit Function Else ' GET OUT FOR NEXT i = FastPureLabel(b$, W$) If i = 1 Then once = False b$ = W$ ExecuteLong = 2 Exit Function ElseIf i = 0 Then If IsNumberLabel(b$, W$) Then once = False b$ = W$ ExecuteLong = 2 Exit Function Else b$ = W$ + b$ End If Else b$ = W$ + b$ End If End If End Function Function GetArrayReference(bstack As basetask, a$, v$, curpp, result As iBoxArray, index As Long) As Boolean Dim dn As Long, dd As Long, p, w3, w2 As Long, ppppl As iBoxArray, pppp As mArray, usehandler As mHandler Dim pp As Variant Set pp = curpp If pp Is Nothing Then Exit Function If Not TypeOf pp Is iBoxArray Then If TypeOf pp Is mHandler Then Set usehandler = pp With usehandler If .t1 = 3 Then If Not .objref Is Nothing Then If TypeOf .objref Is iBoxArray Then Set pp = .objref: GoTo cont End With End If Exit Function End If cont: Set usehandler = Nothing Set ppppl = pp If ppppl.arr Then dn = 0 ppppl.SerialItem (0), dd, 5 dd = dd - 1 If dd < 0 Then If Typename(ppppl.GroupRef) = mProp Then Exit Function p = 0 GetArrayReference = True w2 = 0 If TypeOf ppppl Is mArray Then Set pppp = ppppl Do While dn <= dd pppp.SerialItem w3, dn, 6 If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If dn < dd Then If Not FastSymbol(a$, ",") Then: MyErMacro a$, "need index for " + v$ + ")", "χρειάζομαι δείκτη για το πίνακα " + v$ + ")": GetArrayReference = False: Exit Function Else If FastSymbol(a$, ",") Then GetArrayReference = False MyErMacro a$, "too many indexes for array " + v$ + ")", "πολλοί δείκτες για το πίνακα " + v$ + ")" Exit Function End If If Not FastSymbol(a$, ")") Then: MissSymbol ")": GetArrayReference = False: Exit Function End If On Error Resume Next If p < -pppp.myarrbase Then toolow: GetArrayReference = False MyErMacro a$, "index too low for array " + v$ + ")", "χαμηλός δείκτης στο πίνακα " + v$ + ")" Exit Function End If If Not pppp.PushOffset(w2, dn, CLng(Fix(p))) Then toohigh: MyErMacro a$, "index too high for array " + v$ + ")", "δείκτης υψηλός για το πίνακα " + v$ + ")" GetArrayReference = False Exit Function End If On Error GoTo 0 Else GetArrayReference = False If LastErNum = -2 Then Else MyErMacro a$, "missing index for array " + v$ + ")", "χάθηκε δείκτης για το πίνακα " + v$ + ")" End If Exit Function End If dn = dn + 1 Loop ElseIf TypeOf ppppl Is tuple Then If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If Not FastSymbol(a$, ")") Then: MissSymbol ")": GetArrayReference = False: Exit Function If p >= ppppl.Count Then GoTo toohigh ElseIf p < 0 Then GoTo toolow Else w2 = p GetArrayReference = True End If End If Else GetArrayReference = False SyntaxError Exit Function End If Set result = ppppl index = w2 End If End Function Function ProcessArray(bstack As basetask, a$, v$, pp, result) As Boolean Dim dn As Long, dd As Long, p, w3, w2 As Long, pppp As mArray If Not Typename$(pp) = myArray Then Exit Function Set pppp = pp If pppp.arr Then dn = 0 pppp.SerialItem (0), dd, 5 dd = dd - 1 If dd < 0 Then If Typename(pppp.GroupRef) = mProp Then Exit Function p = 0 ProcessArray = True w2 = 0 Do While dn <= dd pppp.SerialItem w3, dn, 6 If IsExp(bstack, a$, p, flatobject:=True, nostring:=True) Then If dn < dd Then If Not FastSymbol(a$, ",") Then: MyErMacro a$, "need index for " + v$ + ")", "χρειάζομαι δείκτη για το πίνακα " + v$ + ")": ProcessArray = False: Exit Function Else If FastSymbol(a$, ",") Then ProcessArray = False MyErMacro a$, "too many indexes for array " + v$ + ")", "πολλοί δείκτες για το πίνακα " + v$ + ")" Exit Function End If If Not FastSymbol(a$, ")") Then: MissSymbol ")": ProcessArray = False: Exit Function End If On Error Resume Next If p < -pppp.myarrbase Then ProcessArray = False MyErMacro a$, "index too low for array " + v$ + ")", "χαμηλός δείκτης στο πίνακα " + v$ + ")" Exit Function End If If Not pppp.PushOffset(w2, dn, CLng(Fix(p))) Then ProcessArray = False MyErMacro a$, "index too high for array " + v$ + ")", "δείκτης υψηλός για το πίνακα " + v$ + ")" ProcessArray = False Exit Function End If On Error GoTo 0 Else ProcessArray = False If LastErNum = -2 Then Else MyErMacro a$, "missing index for array " + v$ + ")", "χάθηκε δείκτης για το πίνακα " + v$ + ")" End If Exit Function End If dn = dn + 1 Loop If MyIsObject(pppp.item(w2)) Then Set result = pppp.item(w2) Else result = pppp.item(w2) End If End If End Function Function ReplaceCRLFSPACE(a$) As Boolean Dim i As Long For i = 1 To Len(a$) Select Case AscW(Mid$(a$, i, 1)) Case 13 ReplaceCRLFSPACE = True Case 32, 10, 160, 9 Case Else Exit For End Select Next i If i = 1 Then Exit Function If i > Len(a$) Then a$ = vbNullString: Exit Function Mid$(a$, 1, i - 1) = String$(i - 1, Chr(7)) End Function Sub NeoLet(basestackLP As Long, rest$, Lang As Long, resp As Boolean) resp = MyLet(ObjFromPtr(basestackLP), rest$, Lang) End Sub Sub Resettimestamp() timestamp = -1 End Sub Function check2(s$, a$, b$) As Boolean If s$ = a$ Then check2 = True: Exit Function If s$ = b$ Then check2 = True End Function Function FastSymbolNoTrimAfter(a$, c$) As Boolean Dim i As Long, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then Exit Function ' this is not good If j - i < 0 Then Exit Function If c$ = Mid$(a$, i, 1) Then a$ = Mid$(a$, i + 1) FastSymbolNoTrimAfter = True End If End Function Function FastSymbolAt(i As Long, a$, c$, Optional cl As Long = 1) As Boolean Dim j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimLi(a$, i) If i > j Then Exit Function If j - i < cl - 1 Then Exit Function If c$ = myUcase(Mid$(a$, i, cl)) Then i = i + cl: FastSymbolAt = True End Function Function FastSymbolAtNoSpace(i As Long, a$, c$, Optional cl As Long = 1) As Boolean Dim j As Long j = Len(a$) If j = 0 Then Exit Function If i > j Then Exit Function If j - i < cl - 1 Then Exit Function If c$ = myUcase(Mid$(a$, i, cl)) Then i = i + cl: FastSymbolAtNoSpace = True End Function Function NocharsInLine(a$) As Boolean Dim i As Long, j As Long j = Len(a$) If j = 0 Then NocharsInLine = True: Exit Function i = MyTrimL(a$) If i > j Then NocharsInLine = True: Exit Function End Function Function DropCommentOrLine(a$, Optional keepfirstcrlf As Boolean = False) As Boolean Dim i As Long, j As Long, prev As Long i = 1 j = Len(a$) If j = 0 Then a$ = vbNullString: Exit Function again: i = MyTrimLi2(a$, i): If i > j Then a$ = vbNullString: Exit Function Select Case AscW(Mid$(a$, i, 1)) Case 47 If Mid$(a$, i + 1, 1) = "/" Then i = i + 1: GoTo a1111 Case 39, 92 a1111: ' drop line i = InStr(i, a$, vbLf) If i = 0 Then i = j + 1 Else prev = i - 1 i = i + 1 GoTo again End If Case 13 prev = i i = i + 2 GoTo again End Select 'If i > 1 Then Mid$(a$, 1, i - 1) = space$(i - 1) If i > 1 Then DropCommentOrLine = CBool(prev) If keepfirstcrlf And prev > 0 Then i = MyTrimLi2(a$, prev) If i > 1 Then a$ = Mid$(a$, i) End If End Function Function MaybeIsTwoSymbol(a$, c$, Optional l As Long = 2) As Boolean Dim i As Long If a$ = vbNullString Then Exit Function i = MyTrimL(a$) If i > Len(a$) Then Exit Function MaybeIsTwoSymbol = c$ = Mid$(a$, i, 2) End Function Sub MakeArray(basestack As basetask, frm$, o As Long, rest$, pppp As mArray, Optional lcl As Boolean = False, Optional globalonly As Boolean = False) 'global Dim p As Variant, X As Variant, i As Long, f As Long, s$, ss$ i = MyTrimL(rest$) If Mid$(rest$, i, 1) = ")" Then Mid$(rest$, i, 1) = ChrW(8) i = 0 Select Case o Case 5, 6, 7 If lcl Then GlobalArr basestack, here$ + "." + basestack.GroupName + frm$, rest$, i, f, True Else GlobalArr basestack, basestack.GroupName + frm$, rest$, i, f, True, , globalonly End If p = i If i < 0 Then o = 0 Case Else o = 0 End Select Select Case o Case 5 X = 0 If FastSymbol(rest$, "=") Then If IsExp(basestack, rest$, X) Then If neoGetArray(basestack, frm$, pppp, , globalonly, Not lcl) Then '' basestack.GroupName & f If Not basestack.lastobj Is Nothing Then If IsObjGroup(basestack.lastobj) Then If basestack.lastobj.IamSuperClass Then Set pppp.GroupRef = basestack.lastobj.SuperClassList Else Set pppp.GroupRef = basestack.lastobj End If pppp.IhaveClass = True Set basestack.lastobj = Nothing pppp.SerialItem 0, 0, 3 End If Else pppp.SerialItem X, 0, 3 End If End If ElseIf IsStrExp(basestack, rest$, s$) Then If neoGetArray(basestack, frm$, pppp, , globalonly, Not lcl) Then '' basestack.GroupName & f X = s$ pppp.SerialItem X, 0, 3 End If Else o = 0 End If ElseIf FastSymbol(rest$, "<<", , 2) Then f = 1 s$ = aheadstatus(rest$, True, f) If f > 0 Then s$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) If neoGetArray(basestack, frm$, pppp) Then For i = 0 To pppp.UpperMonoLimit If IsExp(basestack, (s$), X) Then If Not basestack.lastobj Is Nothing Then If IsObjGroup(basestack.lastobj) Then Set pppp.GroupRef = Nothing pppp.IhaveClass = False If basestack.lastobj.IamSuperClass Then Dim myobj As Object pppp.CopyGroupObj basestack.lastobj.SuperClassList, myobj Set myobj.SuperClassList = basestack.lastobj.SuperClassList Set pppp.item(i) = myobj Set myobj = Nothing Else Set pppp.item(i) = basestack.lastobj End If ElseIf IsObjmHandler(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsObjmStiva(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsobjArray(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj Else Set basestack.lastobj = Nothing badsupport GoTo ex1 Exit For End If Else pppp.item(i) = X End If Else Set basestack.lastobj = Nothing MissNumExpr GoTo ex1 Exit For End If Next i Set basestack.lastobj = Nothing Else ' it = 0 End If End If End If Case 7 X = 0 If FastSymbol(rest$, "=") Then If IsExp(basestack, rest$, X) Then If neoGetArray(basestack, frm$, pppp, , Not lcl) Then '' basestack.GroupName & pppp.SerialItem Int(X), 0, 3 End If Else o = 0 End If ElseIf FastSymbol(rest$, "<<", , 2) Then f = 1 s$ = aheadstatus(rest$, True, f) If f > 0 Then s$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) If neoGetArray(basestack, frm$, pppp) Then For i = 0 To pppp.UpperMonoLimit If IsExp(basestack, (s$), X) Then If IsObjLambda(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf basestack.lastobj Is Nothing Then pppp.item(i) = Int(X) Else Set basestack.lastobj = Nothing MyEr "Only Lambda objects here", "Μόνο λάμδα αντικείμενα εδώ" GoTo ex1 Exit For End If Else Set basestack.lastobj = Nothing MissNumExpr GoTo ex1 End If Next i Set basestack.lastobj = Nothing Else MissNumExpr GoTo ex1 End If End If End If Case 6 s$ = vbNullString If FastSymbol(rest$, "=") Then If IsStrExp(basestack, rest$, s$) Then If neoGetArray(basestack, frm$, pppp, , Not lcl) Then ''basestack.GroupName & pppp.SerialItem s$, 0, 3 End If End If ElseIf FastSymbol(rest$, "<<", , 2) Then f = 1 s$ = aheadstatus(rest$, True, f) If f > 0 Then s$ = Left$(rest$, f - 1) rest$ = Mid$(rest$, f) If neoGetArray(basestack, frm$, pppp) Then For i = 0 To pppp.UpperMonoLimit If IsStrExp(basestack, (s$), ss$) Then If IsObjGroup(basestack.lastobj) Then Set pppp.GroupRef = Nothing pppp.IhaveClass = False Set pppp.item(i) = basestack.lastobj ElseIf IsObjLambda(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsObjmHandler(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsObjmStiva(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf IsobjArray(basestack.lastobj) Then Set pppp.item(i) = basestack.lastobj ElseIf basestack.lastobj Is Nothing Then pppp.item(i) = ss$ Else Set basestack.lastobj = Nothing badsupport GoTo ex1 Exit For End If Else Set basestack.lastobj = Nothing MissStringExpr GoTo ex1 Exit For End If Next i Set basestack.lastobj = Nothing Else MissStringExpr GoTo ex1 End If End If End If End Select If o = 0 Then BadDim rest$ = basestack.GroupName + frm$ + rest$ End If ex1: Set basestack.lastpointer = Nothing End Sub Sub MarkIf(bstack As basetask, a As Long, b As Boolean) Dim s As mStiva2 Set s = bstack.RetStack s.PushVal b s.PushVal a s.PushVal -3 ' mark for IF End Sub Sub MarkSel(bstack As basetask, Lang As Long) Dim s As mStiva2 Set s = bstack.RetStack s.PushLong Lang s.PushVal -5 ' mark for select End Sub Function lookOne(s, c$) As Boolean Dim i&, l As Long, cc As Integer Dim P2 As Long, P1 As Integer l = Len(s): If l = 0 Then Exit Function P2 = StrPtr(s): l = l - 1: GetMem2 StrPtr(c$), cc For i = P2 To P2 + l * 2 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 7, 9 Case cc lookOne = True Case Else Exit Function End Select Next i End Function Function lookTwoSame(s, c$) As Boolean Dim i&, l As Long, cc As Integer, cc2 As Integer Dim P2 As Long, P1 As Integer, n As Integer If Len(c$) <> 1 Then Exit Function l = Len(s): If l = 0 Then Exit Function P2 = StrPtr(s): l = l - 1: GetMem2 StrPtr(c$), cc For i = P2 To P2 + l * 2 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 7, 9 If n <> 0 Then Exit Function Case cc If n = 1 Then lookTwoSame = True: Exit Function If n = 0 Then n = 1 Case Else Exit Function End Select Next i End Function Function MaybeIsSymbol(a$, c$) As Boolean Dim i As Long If a$ = vbNullString Then Exit Function i = MyTrimL(a$) If i > Len(a$) Then Exit Function MaybeIsSymbol = InStr(c$, Mid$(a$, i, 1)) > 0 End Function Function MaybeIsSymbol2(a$, c$, i As Long) As Boolean '' for isnumber If a$ = vbNullString Then Exit Function i = MyTrimL(a$) If i > Len(a$) Then Exit Function MaybeIsSymbol2 = InStr(c$, Mid$(a$, i, 1)) > 0 End Function Function MaybeIsSymbol3lot(a$, c$, i As Long) As Boolean If a$ = vbNullString Then Exit Function i = MyTrimLi(a$, IIf(i, i, 1)) If i > Len(a$) Then Exit Function MaybeIsSymbol3lot = InStr(c$, Mid$(a$, i, 1)) > 0 End Function Function MaybeIsSymbol3(a$, c$, i As Long) As Boolean If a$ = vbNullString Then Exit Function i = MyTrimLi(a$, IIf(i, i, 1)) If i > Len(a$) Then Exit Function MaybeIsSymbol3 = c$ = Mid$(a$, i, 1) End Function Function MaybeIsSymbolNoSpace(a$, c$) As Boolean MaybeIsSymbolNoSpace = Left$(a$, 1) Like c$ End Function Function IsLabelSymbolLatin(a$, c$, Optional i As Long) As Boolean Dim M As Long M = Len(c$) If i = 0 Then i = MyTrimLi(a$, 1) If UCase(Mid$(a$, i, M)) = c$ Then If Len(a$) >= i + M Then Select Case AscW(Mid$(a$, i + M, 1)) Case Is < 36, 47, 58, 92, 160 Case Else Exit Function End Select End If a$ = Mid$(a$, i + M) IsLabelSymbolLatin = True End If End Function Function IsLabelSymbol(a$, c$, Optional i As Long) As Boolean Dim M As Long M = Len(c$) If i = 0 Then i = MyTrimLi(a$, 1) If myUcase(Mid$(a$, i, M), True) = c$ Then If Len(a$) >= i + M Then Select Case AscW(Mid$(a$, i + M, 1)) Case Is < 36, 47, 58, 92, 160 Case Else Exit Function End Select End If a$ = Mid$(a$, i + M) IsLabelSymbol = True End If End Function Function IsLabelSymbolNewExp(a$, gre$, Eng$, Code As Long, usethis$, Optional i As Long) As Boolean ' code 2 gre or eng, set new value to code 1 or 0 ' 0 for gre ' 1 for eng ' return true if we have label Dim M As Long M = Len(usethis$) If i = 0 Then i = MyTrimLi(a$, 1) If M = 0 Then If Code = 1 Then M = Len(Eng$) If Not UCase(Mid$(a$, i, M)) = Eng$ Then If IsLabelSYMB33(a$, usethis, M) Then usethis = myUcase(usethis, True) Exit Function End If Else M = Len(gre$) If Not myUcase(Mid$(a$, i, M), True) = gre$ Then If IsLabelSYMB33(a$, usethis, M) Then usethis = myUcase(usethis, True) Exit Function End If End If If Len(a$) >= i + M Then Select Case AscW(Mid$(a$, i + M, 1)) 'Case Is < 36, 47, 58, 92, 123, 160 Case Is < 36, 39, 41 To 45, 47, 58, 61, 92, 123, 125, 160 'Case 36, 37, 46, 48 To 58, 94, 95 ' _ . 0123456789 Case Else '36, 37, 40, 46, 48 To 58, 64, 91, 93 To 95 If IsLabelSYMB33(a$, usethis, M) Then usethis = myUcase(usethis, True) usethis = Mid$(a$, i, M) Exit Function End Select End If a$ = Mid$(a$, i + M) IsLabelSymbolNewExp = True usethis$ = vbNullString Else Select Case Code Case 0, 2 If Len(gre$) = Len(usethis) Then IsLabelSymbolNewExp = gre$ = usethis$ Case 1 If Len(Eng$) = Len(usethis) Then IsLabelSymbolNewExp = Eng$ = usethis$ End Select If IsLabelSymbolNewExp Then a$ = Mid$(a$, i + M): usethis$ = vbNullString End If End Function Function IsLabelSymbolNew(a$, gre$, Eng$, Code As Long, Optional i As Long = 0, Optional skipterminal As Boolean) As Boolean ' code 2 gre or eng, set new value to code 1 or 0 ' 0 for gre ' 1 for eng ' return true if we have label Const b = vbCr + ",'\/:}" Dim M As Long If i = 0 Then i = MyTrimLi(a$, 1) If Code = 1 Then M = Len(Eng$) If Not UCase(Mid$(a$, i, M)) = Eng$ Then Exit Function End If Else M = Len(gre$) If Not myUcase(Mid$(a$, i, M), True) = gre$ Then Exit Function End If End If M = M + i If Len(a$) >= M Then If skipterminal Then i = MyTrimLi(a$, M) If Len(a$) >= i Then If InStr(b, Mid$(a$, i, 1)) > 0 Then Exit Function If i > M Then a$ = Mid$(a$, i) IsLabelSymbolNew = True Exit Function End If End If Select Case AscW(Mid$(a$, M, 1)) Case Is < 36, 39, 41 To 45, 47, 58 To 61, 92, 93, 123, 125, 160 Case Else ' 36, 37, 40, 46, 48 To 58, 64, 91, <<93 old>> To 95 ' _ . 0123456789 Exit Function End Select ElseIf skipterminal Then Exit Function End If a$ = Mid$(a$, M) IsLabelSymbolNew = True End Function Private Function FastSymbol(a$, c$, Optional mis As Boolean = False, Optional cl As Long = 1) As Boolean Dim i As Long, j As Long j = Len(a$) If j = 0 Then Exit Function i = MyTrimL(a$) If i > j Then Exit Function ' this is not good If j - i < cl - 1 Then If mis Then MissSymbol c$ Exit Function End If If c$ = Mid$(a$, i, cl) Then a$ = Mid$(a$, MyTrimLi(a$, i + cl)) FastSymbol = True ElseIf mis Then MissSymbol c$ End If End Function Private Function MyTrimL(s$) As Long Dim i&, l As Long Dim P2 As Long, P1 As Integer, p4 As Long l = Len(s): If l = 0 Then MyTrimL = 1: Exit Function P2 = StrPtr(s): l = l - 1 p4 = P2 + l * 2 For i = P2 To p4 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 7, 9 Case Else MyTrimL = (i - P2) \ 2 + 1 Exit Function End Select Next i MyTrimL = l + 2 End Function Public Function RealLen(s$, Optional checkone As Boolean = False) As Long Dim i&, LL As Long, n As Long LL = Len(s): If LL = 0 Then Exit Function If checkone Then LL = 1 Dim a1() As Integer, A2() As Integer ReDim a1(LL + 6) ReDim A2(LL + 6) Dim skip As Boolean skip = GetStringTypeExW(&HB, 4, StrPtr(s$), LL, a1(0)) = 0 skip = GetStringTypeExW(&HB, 2, StrPtr(s$), LL, A2(0)) = 0 Or skip If skip Then RealLen = LL Else i& = LL - 1 LL = LL * 2 For n = 0 To i& If a1(n) = 2048 And A2(n) = 1 Then LL = LL - 1 ElseIf a1(n) = 4096 And A2(n) = 0 Then LL = LL - 1 ElseIf a1(n) = 4096 And A2(n) = 1 Then LL = LL - 1 ElseIf a1(n) = 1096 And A2(n) = 11 Then ElseIf a1(n) = 3 And A2(n) = 11 Then LL = LL - 2 ElseIf a1(n) = 0 And A2(n) = 0 Then LL = LL - 2 ElseIf a1(n) = 1 Then LL = LL - 2 End If Next n RealLen = LL \ 2 End If End Function Public Function CheckIsmArray(obj As Object) As Boolean Dim oldobj As Object, usehandler As mHandler If obj Is Nothing Then Exit Function Set oldobj = obj Dim kk As Long again: If kk > 20 Then Set obj = oldobj: Exit Function If TypeOf obj Is mHandler Then Set usehandler = obj If usehandler.t1 = 3 Then If usehandler.indirect >= 0 And usehandler.indirect <= var2used Then Set obj = var(usehandler.indirect) kk = kk + 1 GoTo again Else Set obj = usehandler.objref End If End If End If If Not obj Is Nothing Then If TypeOf obj Is mArray Then If obj.arr Then CheckIsmArray = True: Set oldobj = Nothing: Exit Function If TypeOf obj Is tuple Then If obj.arr Then CheckIsmArray = True: Set oldobj = Nothing: Exit Function End If Set obj = oldobj End Function Public Function CheckIsmStiva(obj As Object) As Boolean Dim oldobj As Object, usehandler As mHandler If obj Is Nothing Then Exit Function Set oldobj = obj Dim kk As Long again: If kk > 20 Then Set obj = oldobj: Exit Function If TypeOf obj Is mHandler Then Set usehandler = obj If usehandler.t1 = 3 Then If usehandler.indirect >= 0 And usehandler.indirect <= var2used Then Set obj = var(usehandler.indirect) kk = kk + 1 GoTo again Else Set obj = usehandler.objref End If End If End If If Not obj Is Nothing Then If TypeOf obj Is mStiva Then CheckIsmStiva = True: Set oldobj = Nothing: Exit Function End If Set obj = oldobj End Function Public Function CheckIsmArrayOrStackOrCollection(obj As Object) As Boolean Dim oldobj As Object, usehandler As mHandler If obj Is Nothing Then Exit Function Set oldobj = obj Dim kk As Long again: If kk > 20 Then Set obj = oldobj: Exit Function If TypeOf obj Is mHandler Then Set usehandler = obj If usehandler.t1 <> 2 Then If usehandler.indirect >= 0 And usehandler.indirect <= var2used Then Set obj = var(usehandler.indirect) kk = kk + 1 GoTo again Else Set obj = usehandler.objref End If End If End If If Not obj Is Nothing Then If TypeOf obj Is iBoxArray Then If TypeOf obj Is mArray Then Dim thisA As mArray Set thisA = obj Set obj = thisA CheckIsmArrayOrStackOrCollection = True Set oldobj = Nothing: Exit Function ElseIf TypeOf obj Is tuple Then Dim thisB As tuple Set thisB = obj ' we get the interface Set obj = thisB ' now obj point to specific interface CheckIsmArrayOrStackOrCollection = True Set oldobj = Nothing: Exit Function End If End If 'If TypeOf obj Is tuple Then If obj.Arr Then CheckIsmArrayOrStackOrCollection = True: Set oldobj = Nothing: Exit Function 'If TypeOf obj Is mArray Then If obj.Arr Then CheckIsmArrayOrStackOrCollection = True: Set oldobj = Nothing: Exit Function If TypeOf obj Is mStiva Then CheckIsmArrayOrStackOrCollection = True: Set oldobj = Nothing: Exit Function If TypeOf obj Is FastCollection Then CheckIsmArrayOrStackOrCollection = True: Set oldobj = Nothing: Exit Function If TypeOf obj Is StructCollection Then CheckIsmArrayOrStackOrCollection = True: Set oldobj = Nothing: Exit Function End If Set obj = oldobj End Function Public Function CheckAnyArray(obj As Object) As Boolean Dim oldobj As Object, usehandler As mHandler If obj Is Nothing Then Exit Function Set oldobj = obj Dim kk As Long again: If kk > 20 Then Set obj = oldobj: Exit Function If TypeOf obj Is mHandler Then Set usehandler = obj If usehandler.t1 = 3 Then If usehandler.indirect >= 0 And usehandler.indirect <= var2used Then Set obj = var(usehandler.indirect) kk = kk + 1 GoTo again Else Set obj = usehandler.objref End If End If End If If Not obj Is Nothing Then If TypeOf obj Is iBoxArray Then If TypeOf obj Is mArray Then Dim pp As mArray Set pp = obj Set obj = pp Set oldobj = Nothing: CheckAnyArray = True: Exit Function ElseIf TypeOf obj Is tuple Then Dim pp1 As tuple Set pp1 = obj Set obj = pp1 Set oldobj = Nothing: CheckAnyArray = True: Exit Function End If End If End If Set obj = oldobj End Function Public Function CheckDeepAny(obj As Object) As Boolean Dim oldobj As Object, usehandler As mHandler If obj Is Nothing Then Exit Function Set oldobj = obj Dim kk As Long again: If kk > 20 Then Set obj = oldobj: Exit Function If TypeOf obj Is mHandler Then Set usehandler = obj If usehandler.t1 = 3 Then If usehandler.indirect >= 0 And usehandler.indirect <= var2used Then Set obj = var(usehandler.indirect) kk = kk + 1 GoTo again Else Set obj = usehandler.objref End If End If End If If Not obj Is Nothing Then If TypeOf obj Is iBoxArray Then If TypeOf obj Is mArray Then Dim pp As mArray Set pp = obj Set obj = pp ElseIf TypeOf obj Is tuple Then Dim pp1 As tuple Set pp1 = obj Set obj = pp1 End If End If Set oldobj = Nothing: CheckDeepAny = True: Exit Function End If Set obj = oldobj End Function Function getindexes(bstack As basetask, obj1 As Object, a$) As Boolean Dim s$, p, idx As New mIndexes, dn As Long, aProp As PropReference Set aProp = obj1 Do If IsExp(bstack, a$, p) Then idx(dn) = p aProp.index = p ElseIf IsStrExp(bstack, a$, s$) Then idx(dn) = s$ aProp.index = s$ ElseIf FastSymbol(a$, "?") Then idx.IndexOpt dn aProp.IndexOpt Else If dn = 0 Then If MaybeIsSymbol(a$, ")") Then getindexes = True End If End If idx.IndexOpt dn aProp.IndexOpt End If dn = dn + 1 Loop Until Not FastSymbol(a$, ",") aProp.PushIndexes idx End Function Public Sub MyDoEventsNoRefresh() If TaskMaster Is Nothing Then GoTo cont1 ElseIf Not TaskMaster.Processing And TaskMaster.QueueCount = 0 Then cont1: If MusicMaster.PlayMusic Then MusicMaster.StopProcess MusicMaster.TimerTick DoEvents MusicMaster.StartProcess Else DoEvents End If Exit Sub Else If MusicMaster.PlayMusic Then MusicMaster.StopProcess TaskMaster.StopProcess TaskMaster.TimerTick DoEvents TaskMaster.StartProcess MusicMaster.StartProcess Else TaskMaster.StopProcess TaskMaster.TimerTick DoEvents TaskMaster.StartProcess End If End If Exit Sub there: If Not TaskMaster Is Nothing Then TaskMaster.RestEnd1 MusicMaster.RestEnd1 End Sub Private Function lookB123(s As String, Optional ByVal Pos As Long = 1) As Boolean Dim i&, l As Long Dim P2 As Long, P1 As Integer, p4 As Long l = Len(s): If l = 0 Then Exit Function If Pos > l Then Exit Function P2 = StrPtr(s) + (Pos - 1) * 2: l = l - 1 For i = P2 To P2 + l * 2 Step 2 GetMem2 i, P1 Select Case P1 Case 32, 160, 7, 9 Case 13, 47, 39, 92 lookB123 = True Case Else Exit Function End Select Next i End Function Sub StaticWork(basestack As basetask, mystack As basetask, ByVal where$) Dim vvv where$ = "%_" + where$ If basestack.StaticCollection.ExistKey(where$) Then basestack.ReadStaticCol2 where$, vvv If MyIsObject(vvv) Then Set mystack.StaticCollection = vvv End If End Sub Private Function Addr(ByVal p As Long) As Long 'If m_bInIDE Then ' addr = CLNG(add32(uintnew1(p), 12@)) 'Else Addr = p 'End If End Function Public Function VarTypeName(v) As String namesVT MemInt(VarPtr(v)), v, VarTypeName End Function Public Sub namesVT(n As Integer, v, ret As String) Select Case n And &H7FF Case 0 ret = "Empty" Case 1 ret = "Null" Case 2 ret = "Integer" Case 3 ret = "Long" Case 4 ret = "Single" Case 5 ret = "Double" Case 6 ret = "Currency" Case 7 ret = "Date" Case 8 ret = "String" Case 10 ret = "Error" Case 9 ret = Typename(v) If ret = "FastCollection" Then If v.IsQueue Then ret = "Queue" Else ret = "List" End If Case 11 ret = "Boolean" Case 12 ret = "Variant" Case 12 ret = "Unknown" Case 14 ret = "Decimal" Case 17 ret = "Byte" Case 20 ret = "Long Long" Case 36 ret = Typename(v) Case 200 ret = "Complex" Case 201 ret = "BigInteger" 'Case Is > 8192 ' ret = ArrayDescBare(v) Case Else ret = "type" & VarType(v) End Select End Sub Public Function ArrayDesc(vArray As Variant) As String Dim lPtr As Long Const VT_BYREF As Long = &H4000 If IsArray(vArray) Then lPtr = MemLong(UnsignedAdd(VarPtr(vArray), 8)) If (MemLong(VarPtr(vArray)) And VT_BYREF) <> 0 Then lPtr = MemLong(lPtr) End If If lPtr <> 0 Then Dim i As Long, p As String, aType As String Select Case MemInt(VarPtr(vArray)) And &HFFF Case 2 aType = "Integer" Case 3 aType = "Long" Case 4 aType = "Single" Case 5 aType = "Double" Case 6 aType = "Currency" Case 7 aType = "Date" Case 8 aType = "String" Case 9 ' VT_DISPATCH = 9, VT_UNKNOWN = 13 aType = "Object" Case 11 aType = "Boolean" Case 12, 1 aType = "Variant" Case 13 aType = "Unknown" Case 14 aType = "Decimal" Case 17 ' VT_UI1 = 17 aType = "Byte" Case 20 aType = "Long Long" Case 27 ' VT_SAFEARRAY = 27 aType = "Array" Case 29 ' VT_USERDEFINED = 29 aType = "UDT" Case 36 aType = Typename(vArray) End Select p = "" & MemLong(UnsignedAdd(lPtr, 16)) For i = 2 To MemInt(lPtr) p = p & ", " & MemLong(UnsignedAdd(lPtr, 8 + i * 8)) Next i ArrayDesc = aType & "(" & p & ")" Exit Function End If ArrayDesc = "EmptyArray" Exit Function End If ArrayDesc = "type" & VarType(vArray) End Function Public Function ArrayDescBare(vArray As Variant) As String Dim lPtr As Long Const VT_BYREF As Long = &H4000 If IsArray(vArray) Then lPtr = MemLong(UnsignedAdd(VarPtr(vArray), 8)) If (MemLong(VarPtr(vArray)) And VT_BYREF) <> 0 Then lPtr = MemLong(lPtr) End If If lPtr <> 0 Then Dim aType As String Select Case MemInt(VarPtr(vArray)) And &HFFF Case 2 aType = "Integer" Case 3 aType = "Long" Case 4 aType = "Single" Case 5 aType = "Double" Case 6 aType = "Currency" Case 7 aType = "Date" Case 8 aType = "String" Case 9 ' VT_DISPATCH = 9, VT_UNKNOWN = 13 aType = "Object" Case 11 aType = "Boolean" Case 12, 1 aType = "Variant" Case 13 aType = "Unknown" Case 14 aType = "Decimal" Case 17 ' VT_UI1 = 17 aType = "Byte" Case 20 aType = "Long Long" Case 27 ' VT_SAFEARRAY = 27 aType = "Array" Case 29 ' VT_USERDEFINED = 29 aType = "UDT" Case 36 aType = Typename(vArray) End Select ArrayDescBare = aType & "()" Exit Function End If ArrayDescBare = "EmptyArray" Exit Function End If ArrayDescBare = "type" & VarType(vArray) End Function Function CheckFree(a$) As Boolean If Len(a$) = 0 Then CheckFree = True: Exit Function Select Case AscW(a$) Case Is < 36, 39 To 45, 47, 58 To 62, 64, 92, 94, 123 To 126, 160 CheckFree = True Case Else ' 36, 37, 40, 46, 48 To 58, 64, 91, 93 To 95 ' _ . 0123456789 End Select End Function Function CheckFreeExecute(a$) As Boolean If Len(a$) = 0 Then CheckFreeExecute = True: Exit Function Select Case AscW(a$) Case Is < 33, 39, 47, 58, 92, 94, 125, 160 CheckFreeExecute = True Case Else End Select End Function Public Function myVarType(z, j As Integer) As Boolean myVarType = MemInt(VarPtr(z)) = j End Function Public Function IntExp(n, X, ByVal r) On Error GoTo 100 While X > 0: If X Mod 2 = 1 Then X = X - 1: r = r * n X = X \ 2: If X > 0 Then n = n * n Wend IntExp = r Exit Function 100: Err.Clear r = 0.5 End Function Function strLiterals(w1 As Long, bstackstr As basetask, a$, r$) As Boolean Dim p On w1 GoTo lit1, lit2, lit3, lit4, lit5, lit6, lit7, lit8, lit9, lit10, lit11, lit12, lit13, lit14, lit15, lit16, lit17, lit18, lit19, lit20, lit21, lit22, lit23, lit24, lit25, lit26, lit27, lit28, lit29, lit30, lit31, lit32, lit33, lit34, lit35, lit36, lit37 ' "ABOUT$", "ΠΕΡΙ$" lit1: r$ = feedback$ feedback$ = vbNullString strLiterals = True Exit Function lit2: ' Case "CONTROL$" Str1nControls r$ strLiterals = True Exit Function lit32: ' Case "ΦΟΡΜΑ$" Str1nControlsGR r$ strLiterals = True Exit Function lit3: ' Case "THREADS$" r$ = bstackstr.Parent.ThreadsStr(1) strLiterals = True Exit Function lit33: ' Case "ΝΗΜΑΤΑ$" r$ = bstackstr.Parent.ThreadsStr strLiterals = True Exit Function lit38: ' Case "INTERNET$", "ΔΙΑΔΙΚΤΥΟ$" r$ = GetExternalIP strLiterals = True Exit Function lit37: ' Case "INTERNET$", "ΔΙΑΔΙΚΤΥΟ$" r$ = GetExternalIP strLiterals = True Exit Function lit4: ' Case "LAN$", "ΔΙΚΤΥΟ$" r$ = getIP strLiterals = True Exit Function lit5: ' Case "GRABFRAME$", "ΠΑΡΕΚΑΡΕ$" r$ = grabfrm$() strLiterals = True Exit Function lit6: ' Case "ΕΝΑΟΝΟΜΑ$", "TEMPNAME$" r$ = GetTempFileName strLiterals = True Exit Function lit7: ' "TEMPORARY$", "ΠΡΟΣΩΡΙΝΟ$" ' ΒΡΈΘΗΚΕ ΔΥΟ ΦΟΡΕΣ ΤΟ ΠΡΟΣΩΡΙΝΟ$ r$ = strTemp 'ΑΥΤΟΣ ΕΙΝΑΙ Ο ΦΑΚΕΛΟΣ strLiterals = True Exit Function lit8: ' Case "USER.NAME$", "ΟΝΟΜΑ.ΧΡΗΣΤΗ$" r$ = Originalusername strLiterals = True Exit Function lit9: ' Case "COMPUTER$", "ΥΠΟΛΟΓΙΣΤΗΣ$" r$ = strMachineName strLiterals = True Exit Function lit10: ' Case "CLIPBOARD$", "ΠΡΟΧΕΙΡΟ$" Sleep 10 r$ = GetTextData(CF_UNICODETEXT) If r$ = vbNullString Then r$ = Clipboard.GetText strLiterals = True Exit Function lit11: ' Case "CLIPBOARD.IMAGE$", "ΠΡΟΧΕΙΡΟ.ΕΙΚΟΝΑ$" Sleep 10 r$ = GetImage() strLiterals = True Exit Function lit12: ' Case "ΠΑΡΑΜΕΤΡΟΙ$", "PARAMETERS$" r$ = para$ strLiterals = True Exit Function lit13: ' Case "OS$", "ΛΣ$" r$ = os strLiterals = True Exit Function lit14: ' Case "ΕΝΤΟΛΗ$", "COMMAND$" r$ = LASTPROG$ strLiterals = True Exit Function lit15: ' Case "ΛΑΘΟΣ$" If Left$(LastErNameGR, 1) = Chr(0) Then LastErNameGR = Mid$(LastErNameGR, 2) r$ = LastErNameGR LastErNum1 = 0 LastErNameGR = vbNullString LastErName = vbNullString strLiterals = True Exit Function lit34: ' Case "ERROR$" If Left$(LastErName, 1) = Chr(0) Then LastErName = Mid$(LastErName, 2) r$ = LastErName LastErNum1 = 0 LastErNameGR = vbNullString LastErName = vbNullString strLiterals = True Exit Function lit36: ' case "MODULE.NAME$", "ΟΝΟΜΑ.ΤΜΗΜΑΤΟΣ$" If SecureNames Then strLiterals = GetThisModuleName(r$) Else r$ = here$ strLiterals = True End If Exit Function lit16: ' Case "MODULE$", "ΤΜΗΜΑ$" r$ = here$ strLiterals = True Exit Function lit17: ' Case "PRINTERNAME$", "ΕΚΤΥΠΩΤΗΣ$" ' δεν παίζει ρόλο πια η πόρτα r$ = pname & " (" & Port & ")" strLiterals = True Exit Function lit18: ' Case "PROPERTIES$", "ΙΔΙΟΤΗΤΕΣ$" If ThereIsAPrinter Then If UBound(MyDM) = 1 Then PrinterDim pw, ph, psw, psh, pwox, phoy End If r$ = ARRAYtoStr(MyDM()) Else r$ = vbNullString End If strLiterals = True Exit Function lit19: ' Case "MOVIE.STATUS$", "ΚΑΤΑΣΤΑΣΗ.ΤΑΙΝΙΑΣ$" r$ = MediaPlayer1.getStatus strLiterals = True Exit Function lit20: ' Case "MOVIE.DEVICE$", "ΣΥΣΚΕΥΗ.ΠΡΟΒΟΛΗΣ$" r$ = MediaPlayer1.getDeviceName strLiterals = True Exit Function lit21: ' Case "MOVIE.ERROR$", "ΛΑΘΟΣ.ΤΑΙΝΙΑΣ$" r$ = MediaPlayer1.checkError strLiterals = True Exit Function lit22: ' Case "PLATFORM$", "ΠΛΑΤΦΟΡΜΑ$" r$ = Platform strLiterals = True Exit Function lit23: ' Case "FONTNAME$", "ΓΡΑΜΜΑΤΟΣΕΙΡΑ$" With bstackstr If .tolayer > 0 And .tolayer < 32 Then r$ = Form1.dSprite(.tolayer).Font.Name ElseIf .tolayer >= 32 Then r$ = players(.tolayer).FontName ElseIf .toback Then r$ = Form1.Font.Name ElseIf .toprinter Then r$ = Form1.PrinterDocument1.Font.Name ElseIf .Owner.Name = "Emf" Then r$ = .Owner.FontName Else r$ = Form1.DIS.Font.Name End If End With strLiterals = True Exit Function lit24: ' Case "BROWSER$", "ΑΝΑΛΟΓΙΟ$" r$ = Form1.view1.LocationURL strLiterals = True Exit Function lit25: ' Case "SPRITE$", "ΔΙΑΦΑΝΕΙΑ$" r$ = BACKSPRITE BACKSPRITE = vbNullString strLiterals = True Exit Function lit26: ' Case "APPDIR$", "ΕΦΑΡΜΟΓΗ.ΚΑΤ$" r$ = GetLongName(App.path) If Right(r$, 1) <> "\" Then r$ = r$ + "\" strLiterals = True Exit Function lit27: ' Case "DIR$", "ΚΑΤ$" r$ = UserPath strLiterals = True Exit Function lit28: ' Case "KEY$", "ΚΟΜ$" If GetCode(bstackstr.Owner) > 32 Then r$ = INKEY$ Else If Not Form1.Visible Then newshow Basestack1: MyDoEvents r$ = UINKEY$ ' look if we have some keys here If r$ = vbNullString Or r$ = Chr(0) + Chr(0) Then Do ProcTask2 bstackstr If Not Form1.KeyPreview Then Form1.KeyPreview = True MyRefresh bstackstr r$ = INKEY$ ' (inkey$ has autorepeat...) Loop Until r$ <> "" Or LastErNum <> 0 If LastErNum <> 0 And LenB(r$) = 0 Then r$ = Chr$(0) End If End If strLiterals = True Exit Function lit29: ' Case "INKEY$", "ΕΝΚΟΜ$" If GetCode(bstackstr.Owner) > 32 Then r$ = INKEY$ Else If Not releasemouse Then If Not Form1.Visible Then newshow Basestack1 MyDoEvents2 bstackstr.Owner Else MyRefresh bstackstr If Not bstackstr.IamThread Then MyDoEvents End If r$ = UINKEY$ If r$ = vbNullString Then r$ = INKEY$ End If End If strLiterals = True Exit Function lit30: ' Case "LETTER$", "ΓΡΑΜΜΑ$" If bstackstr.soros.Total = 0 Then strLiterals = False ElseIf bstackstr.soros.PopType = "S" Then r$ = bstackstr.soros.PopStr strLiterals = True End If Exit Function lit35: ' Case "ΛΑΜΔΑ$" Set bstackstr.lastobj = ProcLambda(bstackstr, a$, 0) r$ = vbNullString If FastSymbol(a$, "(") Then If Not CallLambdaASAP(bstackstr, a$, p, True) Then strLiterals = False: Exit Function r$ = CStr(p) strLiterals = True Else strLiterals = Not bstackstr.lastobj Is Nothing End If Exit Function lit31: ' "LAMBDA$" Set bstackstr.lastobj = ProcLambda(bstackstr, a$, 1) r$ = vbNullString If FastSymbol(a$, "(") Then p = vbNullString If Not CallLambdaASAP(bstackstr, a$, p, True) Then strLiterals = False: Exit Function r$ = CStr(p) strLiterals = True Else strLiterals = Not bstackstr.lastobj Is Nothing End If End Function Function StrToArray(bstackstr As basetask, a$, r$) As Boolean ' OK Dim p, q$, usehandler As mHandler, pppp As iBoxArray, anything As Object If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If IsFlatStringExpr(bstackstr, a$, r$) Then okIsSpace: If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Abs(Fix(p)) Set usehandler = GETarrayFROMstr(q$, r$) Set pppp = usehandler.objref Set usehandler = Nothing r$ = pppp.item(CLng(p - 1)) Set pppp = Nothing Else MissNumExpr Set anything = Nothing Exit Function End If Else Set usehandler = GETarrayFROMstr(q$, r$) If FastSymbol(a$, ")(", , 2) Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Abs(Fix(p)) Set pppp = usehandler.objref r$ = pppp.item(CLng(p)) Set pppp = Nothing Else Set bstackstr.lastobj = usehandler Set usehandler = Nothing End If Else Set bstackstr.lastobj = usehandler Set usehandler = Nothing r$ = vbNullString End If ' RETURN ARRAY End If Else MissStringExpr Exit Function End If Else r$ = " " GoTo okIsSpace End If Else MissStringExpr Exit Function End If StrToArray = FastSymbol(a$, ")", True) End Function Function enthesi(bstack As basetask, rest$) As String 'first is the string "label {0} other {1} Dim counter As Long, pat$, Final$, pat1$, pl1 As Long, pl2 As Long, pl3 As Long Dim q$, p As Variant, P1 As Integer, pd$, insertdot As Boolean, threeparam As Boolean Dim hasnumeric As Boolean If IsExp(bstack, rest$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant Final$, p: p = Empty: GoTo cont1 MissStringExpr Exit Function End If If IsFlatStringExpr(bstack, rest$, Final$) Then cont1: If FastSymbol(rest$, ",") Then insertdot = False threeparam = False Do hasnumeric = False pl2 = 1 pat$ = "{" & (counter) pat1$ = pat$ + ":" pat$ = pat$ + "}" If IsExp(bstack, rest$, p) Then If myVarType(p, vbString) Then Set bstack.lastobj = Nothing SwapString2Variant q$, p GoTo fromboolean End If q$ = "" If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is BigInteger Then p = bstack.lastobj.ToString insertdot = bstack.lastobj.OutputBase = 10 End If Set bstack.lastobj = Nothing End If If myVarType(p, vbString) Then SwapString2Variant q$, p ElseIf MemInt(VarPtr(p)) = vbBoolean Then If ShowBooleanAsString Then q$ = format$(p, DefBooleanString) Else q$ = CStr(p * 1) End If ElseIf MemInt(VarPtr(p)) = vbDate Then q$ = fixthis(p) p = "" Else hasnumeric = True End If again1: pl2 = InStr(pl2, Final$, pat1$) If pl2 = 0 Then If Len(q$) > 0 And MemInt(VarPtr(p)) = vbString Then SwapString2Variant q$, p End If End If again11: If pl2 > 0 Then pl1 = InStr(pl2, Final$, "}") If Mid$(Final$, pl2 + Len(pat1$), 1) = ":" Then P1 = 0 pl3 = val(Mid$(Final$, pl2 + Len(pat1$) + 1) + "}") Else If Mid$(Final$, pl2 + Len(pat1$), 1) = "-" Then P1 = val("-0" + Mid$(Final$, pl2 + Len(pat1$) + 1)) Else P1 = val("0" + Mid$(Final$, pl2 + Len(pat1$))) End If pl3 = pl2 + Len(pat1$) + Len(LTrim(str$(P1))) If Mid$(Final$, pl3, 1) = ":" Then pl3 = val(Mid$(Final$, pl2 + Len(pat1$) + 1 + Len(LTrim(str$(P1)))) + "}") threeparam = True Else pl3 = 0 End If If P1 < 0 Then If pl3 = 0 Then pl3 = P1 P1 = 0 ElseIf pl3 = 0 And Not insertdot Then If pl3 = 0 Then If Not hasnumeric Then pl3 = P1 Else p = Round(p, P1) End If P1 = 0 End If End If If q$ = "" Then Select Case MemInt(VarPtr(p)) Case vbLong, vbInteger, vbByte, 20 If P1 > 0 Then pd$ = format$(p, String$(P1, "0")) Else pd$ = CStr(p) Case vbString pd$ = LTrim$(p) Case 36 If TypeOf p Is Complex Then If threeparam Then pd$ = fixthis(nMath2.cxNew(MyRound(p.r, P1), MyRound(p.i, P1))) Else pd$ = fixthis(p) End If Else pd$ = "----" End If Case vbDouble, vbSingle pd$ = LTrim$(str(p)) If InStr(pd$, "E") > 0 Then GoTo cont2234 ElseIf InStr(pd$, "e") > 0 Then '' we can change e to greek ε cont2234: If threeparam Then pd$ = format$(p, "0." + String$(P1, "0") + "E+####") Else pd$ = format$(p, "0." + String$(Abs(pl3) \ 4, "0") + "E+####") End If If Not NoUseDec Then If Not OverideDec Then pd$ = Replace$(pd$, GetDeflocaleString(LOCALE_SDECIMAL), NowDec$) ElseIf GetDeflocaleString(LOCALE_SDECIMAL) <> NowDec$ Then pd$ = Replace$(pd$, GetDeflocaleString(LOCALE_SDECIMAL), NowDec$) End If End If Else GoTo cont5534 End If Case Else cont5534: If threeparam Then If P1 < 0 Then P1 = -P1 If P1 > 28 Then P1 = 28 p = MyRound(p, P1) If P1 = 0 Then pd$ = format$(p, "0") Else pd$ = format$(p, "0." + String$(P1, "0")) End If If Not NoUseDec Then If Not OverideDec Then pd$ = Replace$(pd$, GetDeflocaleString(LOCALE_SDECIMAL), NowDec$) ElseIf GetDeflocaleString(LOCALE_SDECIMAL) <> NowDec$ Then pd$ = Replace$(pd$, GetDeflocaleString(LOCALE_SDECIMAL), NowDec$) End If End If If InStr(pd$, ".") > 0 Then If NoUseDec Then pd$ = Replace$(pd$, ".", NowDec$) End If End If Else pd$ = fixthis(p) End If End Select Else pd$ = "" If P1 > 0 And insertdot Then If Len(q$) < P1 + 1 Then q$ = "0" + String$(P1 - Len(q$), "0") + q$ End If pd$ = Left$(q$, Len(q$) - P1) + NowDec + Right$(q$, P1) Else SwapStrings q$, pd$ End If End If If pl3 <> 0 Then If pl3 > 0 Then pd$ = Left$(pd$ + space$(pl3), pl3) Else pd$ = Right$(space$(Abs(pl3)) + pd$, Abs(pl3)) End If End If Final$ = Replace$(Final$, Mid$(Final$, pl2, pl1 - pl2 + 1), pd$) pl2 = InStr(pl2, Final$, pat1$) If pl2 > 0 Then GoTo again11 If InStr(Final$, pat$) > 0 Then GoTo cont7747 Else cont7747: Select Case MemInt(VarPtr(p)) Case vbLong, vbInteger, vbByte, 20 pd$ = CStr(p) Case vbString pd$ = LTrim$(p) Case vbBoolean If ShowBooleanAsString Then pd$ = format$(p, DefBooleanString) Else pd$ = CStr(p * 1) End If Case vbDate pd$ = p Case Else pd$ = fixthis(p) End Select Final$ = Replace$(Final$, pat$, pd$) If pl2 = 0 Then pl2 = InStr(Final$, pat1$) Else pl2 = InStr(pl2, Final$, pat1$) End If If pl2 > 0 Then GoTo again11 End If If Not FastSymbol(rest$, ",") Then Exit Do ElseIf LastErNum1 Then Exit Function ElseIf IsStrExp(bstack, rest$, q$, True) Then fromboolean: Final$ = Replace$(Final$, pat$, q$) again0: pl2 = InStr(pl2, Final$, pat1$) If pl2 > 0 Then pl1 = InStr(pl2, Final$, "}") pl3 = InStr(pl2 + Len(pat1$), Final$, ":") If pl3 > 0 And pl3 < pl1 Then pl3 = val(Mid$(Final$, pl3 + 1) + "}") Else pl3 = val(Mid$(Final$, pl2 + Len(pat1$)) + "}") End If If pl3 <> 0 Then If pl3 > 0 Then pd$ = Left$(q$ + space$(pl3), pl3) Else pd$ = Right$(space$(Abs(pl3)) + q$, Abs(pl3)) End If End If Final$ = Replace$(Final$, Mid$(Final$, pl2, pl1 - pl2 + 1), pd$) GoTo again0 End If If Not FastSymbol(rest$, ",") Then Exit Do Else missParam rest$ enthesi = "" Exit Function End If counter = counter + 1 Loop Else enthesi = EscapeStrToString(Final$) Exit Function End If End If enthesi = Final$ End Function Function pipename(bstackstr As basetask, a$, r$) As Boolean Dim p If IsExp(bstackstr, a$, p, , True) Then If VarType(p) = vbString Then r$ = p: r$ = validpipename(r$) Else If CheckInt64(p) Then r$ = validpipename("M" & CStr(p)) Else r$ = validpipename("M" & LTrim$(str$(p))) End If ElseIf IsStrExp(bstackstr, a$, r$, False) Then r$ = validpipename(r$) End If pipename = FastSymbol(a$, ")") End Function Function strFunctions(w2 As Long, q$, bstackstr As basetask, a$, r$) As Boolean Dim p As Variant, pp As Variant, ms As mStiva2, usehandler As mHandler Dim s$, par As Boolean, ms1 As mStiva, ppppl As iBoxArray Dim q1$, q2$, w1 As Long, w3 As Long, dd As Long Dim anything As Object On w2 GoTo fstr1, fstr2, fstr3, fstr4, fstr5, fstr6, fstr7, fstr8, fstr9, fstr10, fstr11, fstr12, fstr13, fstr14, fstr15, fstr16, fstr17, fstr18, fstr19, fstr20, fstr21, fstr22, fstr23, fstr24, fstr25, fstr26, fstr27, fstr28, fstr29, fstr30, fstr31, fstr32, fstr33, fstr34, fstr35, fstr36, fstr37, fstr38, fstr39, fstr40, fstr41, fstr42, fstr43, fstr44, fstr45, fstr46, fstr47, fstr48, fstr49, fstr50, fstr51, fstr52, fstr53, fstr54, fstr55, fstr56, fstr57, fstr58, fstr59, fstr60, fstr61, fstr62, fstr63, fstr64, fstr65, fstr66, fstr67, fstr68, fstr69, fstr70 fstr68: ' "ΑΝΑΠ$(","STRREV$(" OK If IsFlatStringExpr(bstackstr, a$, q1$) Then r$ = StrReverse(q1$) Else MissStringExpr Exit Function End If strFunctions = FastSymbol(a$, ")", True) Exit Function fstr67: '"ΜΕΡΟΣ$(", "PIECE$(" OK strFunctions = StrToArray(bstackstr, a$, r$) Exit Function fstr66: '"IF$(","ΑΝ(" ok strFunctions = False If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then strFunctions = ProcessIfStr(p, bstackstr, a$, r$) Else SyntaxError End If Exit Function fstr1: '"FORMAT$(", "ΜΟΡΦΗ$(" OK r$ = enthesi(bstackstr, a$) If LastErNum1 Then Else strFunctions = FastSymbol(a$, ")", True) End If Exit Function fstr2: '"EVAL$(", "ΕΚΦΡ$(", "ΕΚΦΡΑΣΗ$(" ok strFunctions = mEval(q$, bstackstr, a$, r$) Exit Function fstr3: ' "STACKTYPE$(", "ΣΩΡΟΥΤΥΠΟΣ$(" ok w3 = 1 If IsExp(bstackstr, a$, p) Then If bstackstr.lastobj Is Nothing Then Set anything = bstackstr.soros w3 = Abs(CLng(Fix(p))) ElseIf TypeOf bstackstr.lastobj Is PropReference Then Stop ElseIf Not CheckStackObj(bstackstr, anything, w3) Then MyEr "Not a stack object", "Δεν είναι αντικείμενο σωρού" Exit Function ElseIf FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then w3 = Abs(CLng(Fix(p))) End If End If Set ms1 = anything backitem1: Set anything = Nothing If ms1.Total < w3 Then MyErMacroStr a$, "Stack item not found at position " & (w3), "Δεν υπάρχει στοιχείο σωρού στη θέση " & (w3) strFunctions = False: Exit Function ElseIf ms1.StackItemType(w3) = "*" Then Set anything = ms1.StackItem(w3) CheckDeepAny anything r$ = Typename$(anything) If r$ = mHdlr Then Set usehandler = anything Select Case usehandler.t1 Case 1 r$ = "Inventory" Case 2 r$ = "Buffer" Case 3 w3 = usehandler.indirect If w3 > -1 And w3 <= var2used Then r$ = VarTypeName(var(w3)) Else r$ = Typename(usehandler.objref) End If Case Else r$ = Typename(usehandler.objref) End Select Set usehandler = Nothing End If strFunctions = FastSymbol(a$, ")", True) ElseIf ms1.StackItemType(w3) = "?" Then r$ = "(?)" ElseIf ms1.StackItemType(w3) = "S" Then r$ = vbNullString Select Case Abs(IsLabel(bstackstr, CStr(ms1.StackItem(w3)), q1$)) Case 1, 3, 4 If varhash.ExistKey(q1$) Then r$ = "ReferVar" ElseIf varhash.ExistKey(q1$ + "(") Then r$ = "ReferArray" End If Case 5, 6, 7 End Select If r$ = vbNullString Then r$ = "String" strFunctions = FastSymbol(a$, ")", True) ElseIf ms1.StackItemType(w3) = "N" Then r$ = "Number" strFunctions = FastSymbol(a$, ")", True) ElseIf ms1.StackItemType(w3) = "L" Then r$ = "Long" strFunctions = FastSymbol(a$, ")", True) Else MyErMacroStr a$, "Stack item isn't known object at position " & (w3), "To στοιχείο του σωρού δεν είναι γνωστό αντικείμενο στη θέση " & (w3) strFunctions = False End If Exit Function Else Set ms1 = bstackstr.soros GoTo backitem1 End If Exit Function fstr4: 'STACKITEM$(", "ΤΙΜΗΣΩΡΟΥ$(" ok w3 = 1 If IsExp(bstackstr, a$, p) Then If bstackstr.lastobj Is Nothing Then Set anything = bstackstr.soros w3 = Abs(CLng(Fix(p))) ElseIf Not CheckStackObj(bstackstr, anything, w3) Then MyEr "Not a stack object", "Δεν είναι αντικείμενο σωρού" Exit Function ElseIf FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then w3 = Abs(CLng(Fix(p))) End If End If Set ms1 = anything backitem2: Set anything = Nothing If ms1.Total < w3 Then MyErMacroStr a$, "Stack item not found at position " & (w3), "Δεν υπάρχει τιμή σωρού στη θέση " & (w3) strFunctions = False: Exit Function ElseIf ms1.StackItemType(w3) = "S" Then r$ = ms1.StackItem(w3) strFunctions = FastSymbol(a$, ")", True) Exit Function ElseIf ms1.StackItemType(w3) = "*" Then r = 0 Set bstackstr.lastobj = ms1.StackPickRef(w3).ObjectRef strFunctions = FastSymbol(a$, ")", True) Exit Function Else MyErMacroStr a$, "Stack item isn't string at position " & (w3), "Η τιμή του σωρού δεν είναι γράμμα στη θέση " & (w3) strFunctions = False End If Exit Function Else Set ms1 = bstackstr.soros GoTo backitem2 End If fstr5: ' "ΙΣΧΝΗ$(", "WEAK$(" OK r$ = Funcweak(bstackstr, a$) strFunctions = FastSymbol(a$, ")") And r$ <> "" If Not strFunctions Then MyErMacroStr a$, "No variable found or is static", "Δεν υπάρχει μεταβλητή ή είναι στατική" End If Exit Function fstr6: '"ΛΟΓΟΣ$(", "SPEECH$(" OK If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then r$ = VoiceName(p) End If strFunctions = FastSymbol(a$, ")") Exit Function fstr7: ' "ASK$(", "ΡΩΤΑ$(" OK If IsFlatStringExpr(bstackstr, a$, AskText$) Then If UCase(q$) = "ASK$(" Then DialogSetupLang 1 Else DialogSetupLang 0 End If If AskText$ = vbNullString Then ZeroParam a$: strFunctions = False: Exit Function If FastSymbol(a$, ",") Then If Not IsFlatStringOptionalExpr(bstackstr, a$, AskTitle$) Then GoTo miss2 End If If FastSymbol(a$, ",") Then If Not IsFlatStringOptionalExpr(bstackstr, a$, s$) Then GoTo miss2 If s$ = "" Then AskOk$ = "" ElseIf s$ = "*" Then AskOk$ = "*" + AskOk$ Else AskOk$ = s$ End If End If If FastSymbol(a$, ",") Then If Not IsFlatStringOptionalExpr(bstackstr, a$, s$) Then GoTo miss2 If s$ = "" Then AskCancel$ = "" ElseIf s$ = "*" Then AskCancel$ = "*" + AskCancel$ Else AskCancel$ = s$ End If End If If FastSymbol(a$, ",") Then If Not IsFlatStringOptionalExpr(bstackstr, a$, AskDIB$) Then GoTo miss2 End If If FastSymbol(a$, ",") Then If Not IsFlatStringOptionalExpr(bstackstr, a$, AskStrInput$) Then GoTo miss2 AskInput = True End If olamazi Form1.NeoASK bstackstr r$ = AskResponse$ AskInput = False Else GoTo miss2 End If strFunctions = FastSymbol(a$, ")", True) Exit Function fstr8: ' "LOCALE$(", "ΤΟΠΙΚΟ$(" OK If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then r$ = GetlocaleString(CLng(Fix(p))) Else GoTo miss2 End If strFunctions = FastSymbol(a$, ")") Exit Function fstr9: ' "SHORTDIR$(", "ΜΙΚΡΟΣ.ΚΑΤΑΛΟΓΟΣ$(" OK If IsFlatStringExpr(bstackstr, a$, q$) Then r$ = GetDosPath(q$) Else GoTo miss2 End If strFunctions = FastSymbol(a$, ")") Exit Function fstr10: '"FILTER$(", "ΦΙΛΤΡΟ$(" OK If IsFlatStringExpr(bstackstr, a$, q$) Then If Not FastSymbol(a$, ",") Then GoTo missParam If IsFlatStringExpr(bstackstr, a$, q1$) Then r$ = CleanStr(q$, q1$) Else miss2: MissStringExpr strFunctions = False Exit Function End If Else GoTo miss2 End If strFunctions = FastSymbol(a$, ")") Exit Function fstr11: '"ΛΟΓΟΣ$(", "SPEECH$(" OK If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then r$ = VoiceName(p) Else MISS3: MissNumExpr strFunctions = False Exit Function End If strFunctions = FastSymbol(a$, ")") Exit Function fstr12: ' "ΑΡΧΕΙΟ$(", "FILE$(" OK If Left$(UCase(q$), 1) = "F" Then DialogSetupLang 1 Else DialogSetupLang 0 End If If IsFlatStringOptionalExpr(bstackstr, a$, r$) Then If IsSelectorInUse Then strFunctions = False MyErMacroStr a$, "File/Folder Selector in Use", "Ο επιλογέας αρχείων/φακέλων είναι σε χρήση" Exit Function End If If r$ = vbNullString Then r$ = LoadFileCaption End If If FastSymbol(a$, ",") Then If IsStrExp(bstackstr, a$, q1$, False) Then ' ok Else missParam: strFunctions = False missParam a$ Exit Function End If Else q1$ = "GSB" End If r$ = mylcasefILE(GetFile(bstackstr, r$, mcd, q1$)) ElseIf LastErNum1 Then Exit Function Else r$ = mylcasefILE(GetFile(bstackstr, r$, mcd, "GSB")) End If strFunctions = FastSymbol(a$, ")") Exit Function fstr13: ' "PARAM$(", "ΠΑΡΑΜ$(" OK q1$ = vbNullString If IsFlatStringExpr(bstackstr, a$, q2$) Then Do w2 = Len(q2$) If IsNumberD2(q2$, p) Then If q1$ = vbNullString Then Exit Do Else q1$ = q1$ + "," + str(p) Else ISSTRINGA q2$, s$ If q1$ = vbNullString Then r$ = s$ q1$ = "," Else q1$ = q1$ + ",{" + s$ + "}" End If End If FastSymbol q2$, "," Loop Until Trim$(q2$) = vbNullString Or w2 = Len(q2$) End If strFunctions = FastSymbol(a$, ")", True) ' FIX THIS a$=.... ' THIS INSERT NUMBERS TO CODE... a$ = Mid$(q1$, 2) + a$ Exit Function fstr14: ' "LAZY$(", "ΟΚΝ$(" OK If FastSymbol(a$, "&") Then If Abs(IsLabelBig(bstackstr, a$, q2$, par)) < 5 Then ''IsLabelDot(HERE$, A$, q2$) Exit Function End If par = False If GetSub(q2$ + ")", dd) Then If sbf(dd).sbgroup = vbNullString Then r$ = sbf(dd).sb + "}" Else r$ = sbf(dd).sb + "}" + sbf(dd).sbgroup par = True End If End If If Not FastSymbol(a$, ")") Then strFunctions = False MyErMacroStr a$, "No parameters allowed here ()", "Δεν επιτρέπονται παράμετροι εδώ ()" Exit Function End If If Left$(r$, 10) = "'11001EDIT" Then s$ = GetNextLine(r$) + vbCrLf Else s$ = vbNullString End If q2$ = vbNullString Else par = False dd = 1 q1$ = aheadstatus(a$, , dd) If dd > 0 Then q2$ = Left$(a$, dd - 1) Else q2$ = "0" a$ = Mid$(a$, dd) While FastSymbol(a$, ",") dd = 1 q1$ = aheadstatus(a$, , dd) If dd > 0 Then q2$ = q2$ + "," + Left$(a$, dd - 1) Else q2$ = q2$ + ",0" a$ = Mid$(a$, dd) Wend r$ = "=" + q2$: q2$ = "}" + bstackstr.UseGroupname s$ = vbNullString End If If Trim$(r$ + q2$) <> "" Then If par Then r$ = "{" + s$ + r$ + q2$ Else If q$ = "ΟΚΝ$(" Then If here$ = vbNullString Then r$ = "{" + s$ + "ΤΜΗΜΑ {}" + vbCrLf + r$ + q2$ Else r$ = "{" + s$ + "ΤΜΗΜΑ " + here$ + vbCrLf + r$ + q2$ End If Else If here$ = vbNullString Then r$ = "{" + s$ + "MODULE {}" + vbCrLf + r$ + q2$ Else r$ = "{" + s$ + "MODULE " + here$ + vbCrLf + r$ + q2$ End If End If End If Else r$ = "{}" End If strFunctions = FastSymbol(a$, ")") Exit Function fstr15: ' "INPUT$(", "ΕΙΣΑΓΩΓΗ$(" OK IsSymbol3 a$, "#" ' drop it - WE GET THE FILE HANDLER HERE If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) w2 = Fkind(p) If w2 = FnoUse Or w2 = Foutput Or w2 = Frandom Then MyEr "Wrong File Handler", "Λάθος Χειριστής Αρχείου": strFunctions = False: Exit Function w2 = Fstep(p) If uni(p) And w2 = 1 Then w2 = 2 dd = CLng(p) p = Empty If FastSymbol(a$, ",", True) Then If Not IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then g12367: MyErMacroStr a$, "missing parameter for length in chars", "λείπει παράμετρος για μήκος σε χαρακτήρες" strFunctions = True: Exit Function End If Else GoTo g12367 End If On Error Resume Next If w2 = 2 Then w2 = Module10.ReadFileHandler(dd) If w2 = 0 Then strFunctions = False: Exit Function Module10.FileReadString w2, r$, CLng(MyRound(Int(p * 2))) If FastSymbol(a$, ",") Then SwapStrings r$, q1$ GoTo jump001 End If Else w2 = Module10.ReadFileHandler(dd) If w2 = 0 Then strFunctions = False: Exit Function Module10.FileReadString w2, q1$, CLng(Abs(Int(p / 2))) If FastSymbol(a$, ",") Then jump001: If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If p < 0 Then r$ = utf8decode(q1$) Else If GetCodePage(CLng(Fix(p))) = 0 Then NoValidLocale Exit Function End If r$ = StrConv(q1$, vbUnicode, CLng(Fix(p))) End If Else MissPar Exit Function End If Else r$ = StrConv(q1$, vbUnicode, Clid) End If End If End If If Err.Number = 0 Then strFunctions = FastSymbol(a$, ")") End If On Error GoTo 0 Exit Function fstr16: '"MEMBER.TYPE$(", "ΜΕΛΟΥΣ.ΤΥΠΟΣ$(" OK - OLD FUNCTION - ?? If Abs(IsLabel(bstackstr, a$, s$)) = 1 Then If getvar2(bstackstr, s$, dd) Then If VarTypeName(var(dd)) = mGroup Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Fix(p) Set ms = var(dd).PrepareSoros(var(), "") If p < 1 Or p > ms.Total Then OutOfLimit Exit Function End If s$ = ms.StackItem(CLng(p)) If Left$(s$, 1) = "*" Then s$ = Mid$(s$, 2) q1$ = Split(s$)(1) s$ = Split(s$)(0) If Right$(s$, 1) = "(" Then If here$ = vbNullString Or var(dd).IamGlobal Then If varhash.ExistKey(s$) Then If Right$(s$, 3) = "$()" Then r$ = "Array String" ElseIf Right$(s$, 3) = "%()" Then r$ = "Array Integer" ' VERY OLD ?? Else r$ = "Array Double" ' VERY OLD ?? End If End If Else If varhash.ExistKey(here$ + "." + s$) Then If Right$(s$, 3) = "$()" Then r$ = "Array String" ElseIf Right$(s$, 3) = "%()" Then r$ = "Array Integer" ' VERY OLD ?? Else r$ = "Array Double" ' VERY OLD ?? End If End If End If Else w3 = val(q1$) r$ = VarTypeName(var(w3)) If r$ = mHdlr Then Set usehandler = var(w3) Select Case usehandler.t1 Case 1 r$ = "Inventory" Case 2 r$ = "Buffer" Case Else r$ = Typename(usehandler.objref) End Select End If End If Else MissNumExpr Exit Function End If Else MissNumExpr Exit Function End If Else MissingGroup Exit Function End If strFunctions = FastSymbol(a$, ")", True) Exit Function Else Nosuchvariable s$ End If Else MissingGroup End If Exit Function fstr17: ' "MEMBER$(", "ΜΕΛΟΣ$(" OK If Abs(IsLabel(bstackstr, a$, s$)) = 1 Then If getvar2(bstackstr, s$, dd) Then '' we need s$ if this is a "THIS" If VarTypeName(var(dd)) = mGroup Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Fix(p) If var(dd).IamGlobal Then Set ms = var(dd).PrepareSoros(var(), Left$(s$, Len(s$) - Len(var(dd).GroupName) + 1)) ElseIf Len(here$) > 0 Then If Len(bstackstr.UseGroupname) > 0 Then Set ms = var(dd).PrepareSoros(var(), bstackstr.UseGroupname) Else s$ = var(dd).Patch Set ms = var(dd).PrepareSoros(var(), Left$(s$, Len(s$) - Len(var(dd).GroupName) + 1)) End If Else Set ms = var(dd).PrepareSoros(var(), Left$(s$, Len(s$) - Len(var(dd).GroupName) + 1)) End If If p < 1 Or p > ms.Total Then OutOfLimit Exit Function End If s$ = ms.StackItem(CLng(p)) If Left$(s$, 1) = "*" Then s$ = Mid$(s$, 2) r$ = Split(s$)(0) If InStr(r$, ChrW(&HFFBF)) > 0 Then r$ = Replace$(r$, ChrW(&HFFBF), "") Else MissNumExpr Exit Function End If Else MissNumExpr Exit Function End If Else MissingGroup Exit Function End If strFunctions = FastSymbol(a$, ")", True) Exit Function Else Nosuchvariable s$ End If Else MissingGroup End If Exit Function fstr18: '"PIPENAME$(", "ΑΥΛΟΣ$(" OK strFunctions = pipename(bstackstr, a$, r$) Exit Function fstr19: '"DRIVE$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then r$ = DriveTypee(Left$(r$, 3)) strFunctions = FastSymbol(a$, ")") Exit Function End If Exit Function fstr20: '"FILE.TYPE$(", "ΤΥΠΟΣ.ΑΡΧΕΙΟΥ$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then r$ = ExtractType(r$) strFunctions = FastSymbol(a$, ")") Exit Function End If Exit Function fstr21: ' "FILE.NAME.ONLY$(", "ΟΝΟΜΑ.ΑΡΧΕΙΟΥ.ΜΟΝΟ$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then r$ = ExtractNameOnly(r$, True) strFunctions = FastSymbol(a$, ")") Exit Function End If Exit Function fstr22: ' "FILE.NAME$(", "ΟΝΟΜΑ.ΑΡΧΕΙΟΥ$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then r$ = ExtractName(r$, True) strFunctions = FastSymbol(a$, ")") Exit Function End If Exit Function fstr23: ' "FILE.PATH$(", "ΤΟΠΟΣ.ΑΡΧΕΙΟΥ$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then r$ = ExtractPath(r$) strFunctions = FastSymbol(a$, ")") Exit Function End If Exit Function fstr24: ' "ΟΔΗΓΟΣ$(" ok If IsFlatStringExpr(bstackstr, a$, r$) Then r$ = DriveType(Left$(r$, 3)) 'greek response strFunctions = FastSymbol(a$, ")") Exit Function End If Exit Function fstr25: '"ΤΙΤΛΟΣ.ΑΡΧΕΙΟΥ$(", "FILE.TITLE$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then If r$ <> "" Then r$ = FileNameType(r$) strFunctions = FastSymbol(a$, ")") Exit Function End If fstr26: '"ΕΦΑΡΜΟΓΗ.ΑΡΧΕΙΟΥ$(", "FILE.APP$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then If r$ <> "" Then r$ = myRegister(r$) strFunctions = FastSymbol(a$, ")") Exit Function End If fstr27: '"HIDE$(", "ΚΡΥΦΟ$(" OK If IsFlatStringExpr(bstackstr, a$, r$) Then If FastSymbol(a$, "!") Then 'NEW WORKS ONLY FOR WIDE OUTPUT s$ = vbNullString For w1 = 1 To Int((33 * Rnd) + 1): s$ = s$ + Chr(65 + Int((23 * Rnd) + 1)): Next w1 r$ = mycoder.must1(s$ + ":" + vbCrLf + r$) strFunctions = FastSymbol(a$, ")") Exit Function ElseIf FastSymbol(a$, ",") Then If IsStrExp(bstackstr, a$, q$, False) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then r$ = mycoder.encryptline(r$, q$, CLng(Fix(p))) strFunctions = FastSymbol(a$, ")") Exit Function End If End If End If End If End If Exit Function fstr28: ' "LEFTPART$(", "ΑΡΙΣΤΕΡΟΜΕΡΟΣ$(" OK strFunctions = False If IsFlatStringExpr(bstackstr, a$, s$) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant q$, p r$ = GetStrUntil(q$, s$) Else r$ = GetStrUntil(ChrW$(CLng(p)), s$) ' TAKE A NUMBER AS CHARCODE... End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then ElseIf IsStrExp(bstackstr, a$, q$, True) Then r$ = GetStrUntil(q$, s$) strFunctions = FastSymbol(a$, ")") End If End If End If Exit Function fstr29: '"RIGHTPART$(", "ΔΕΞΙΜΕΡΟΣ$(" OK strFunctions = False If IsFlatStringExpr(bstackstr, a$, r$) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then SwapString2Variant q$, p DropLeft q$, r$ Else DropLeft ChrW$(CLng(p)), r$ ' TAKE A NUMBER AS CHARCODE... End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then ElseIf IsStrExp(bstackstr, a$, q$, False) Then DropLeft q$, r$ strFunctions = FastSymbol(a$, ")") End If End If End If Exit Function fstr30: ' "ARRAY$(", "ΠΙΝΑΚΑΣ$(" - OK If IsStrExp(bstackstr, a$, q1$) Then isStr0021: If bstackstr.lastobj Is Nothing Then If Right$("!!" + q1$, 2) = "()" Then Mid$(q1$, Len(q1$), 1) = " " q1$ = RTrim$(q1$) Else dd = InStr("!" + q1$, "(") - 1 If dd > 0 And dd <= Len(q1$) Then q1$ = Left$(q1$, dd) ElseIf neoGetArray(bstackstr, q1$, ppppl) Then GoTo check1236789 Else q1$ = q1$ + "(" End If End If If neoGetArray(bstackstr, q1$, ppppl) Then check1236789: If Not ppppl.arr Then NotArray: Exit Function If FastSymbol(a$, ",") Then strFunctions = NeoGetArrayItem(ppppl, bstackstr, q1$, dd, a$) Else strFunctions = FastSymbol(a$, ")", True) dd = 0 End If check999100: If Not ppppl.IsEmpty Then If MyIsObject(ppppl.item(dd)) Then If TypeOf ppppl.itemObject(dd) Is Document Then r$ = ppppl.item(dd) Set bstackstr.lastobj = Nothing Else Set bstackstr.lastobj = ppppl.item(dd) r$ = vbNullString End If Else r$ = CStr(ppppl.item(dd)) Set bstackstr.lastobj = Nothing End If Else Set bstackstr.lastobj = Nothing MyEr "Empty Array", "Άδειος Πίνακας" End If Else Set bstackstr.lastobj = Nothing NotArray End If Exit Function ElseIf TypeOf bstackstr.lastobj Is iBoxArray Then Set ppppl = bstackstr.lastobj GoTo check1236789 Else SyntaxError Set bstackstr.lastobj = Nothing End If ElseIf LastErNum1 Then ElseIf IsExp(bstackstr, a$, p) Then If VarType(p) = vbString Then q1$ = p: GoTo isStr0021 If Not bstackstr.lastobj Is Nothing Then If TypeOf bstackstr.lastobj Is mHandler Then Set usehandler = bstackstr.lastobj If usehandler.indirect >= 0 Then If IsobjArray(var(usehandler.indirect)) Then Set ppppl = var(usehandler.indirect) GoTo check1236789 End If ElseIf IsobjArray(usehandler.objref) Then Set ppppl = usehandler.objref If bstackstr.lastobj.UseIterator Then If Not ppppl.arr Then NotArray: Exit Function If FastSymbol(a$, ",") Then strFunctions = IsExp(bstackstr, a$, r, , True) strFunctions = FastSymbol(a$, ")", True) dd = r Else strFunctions = FastSymbol(a$, ")", True) dd = ppppl.index End If If Not strFunctions Then Exit Function GoTo check999100 Else GoTo check1236789 End If ElseIf TypeOf usehandler.objref Is mStiva Then Set ms1 = usehandler.objref Set bstackstr.lastobj = Nothing If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then Set bstackstr.lastobj = ms1.ExportArray(CLng(MyRound(p))) End If Else Set bstackstr.lastobj = ms1.ExportArray(ms1.Count) End If Set ms1 = Nothing strFunctions = FastSymbol(a$, ")", True) Exit Function Else Set bstackstr.lastobj = Nothing NotArray End If ElseIf TypeOf bstackstr.lastobj Is mArray Then Set ppppl = bstackstr.lastobj GoTo check1236789 End If End If Else SyntaxError Set bstackstr.lastobj = Nothing strFunctions = False End If Exit Function fstr31: '"TYPE$(", "ΤΥΠΟΣ$(" ok If lookOne(a$, "(") Then ch1245: If IsExp(bstackstr, a$, p) Then If Not bstackstr.lastobj Is Nothing Then Set p = bstackstr.lastobj End If CheckItemType bstackstr, p, "", r$ ElseIf IsStrExp(bstackstr, a$, s$) Then If bstackstr.lastobj Is Nothing Then r$ = Typename$(s$) Else Set p = bstackstr.lastobj CheckItemType bstackstr, p, "", r$ End If Else SyntaxError Exit Function End If strFunctions = FastSymbol(a$, ")") Else s$ = aheadstatus(a$, False, (1)) If InStr(s$, "o") > 0 Or InStr(s$, "NN") > 0 Then GoTo ch1245 dd = Abs(IsLabel(bstackstr, a$, s$)) If dd = 0 Then GoTo ch1245 If dd > 4 And dd < 8 Then If neoGetArray(bstackstr, s$, ppppl) Then w2 = 0 If FastSymbol(a$, ")") Then GoTo cont111 ElseIf Not NeoGetArrayItem(ppppl, bstackstr, s$, w2, a$) Then If Not ppppl.arr Then If Typename(ppppl.GroupRef) = mHdlr Then Set p = ppppl.GroupRef strFunctions = CheckItemType(bstackstr, p, a$, r$) Exit Function End If End If If FastSymbol(a$, ")") Then cont111: If Not ppppl Is Nothing Then If TypeOf ppppl Is mArray Then r$ = myArray ElseIf TypeOf ppppl Is tuple Then r$ = "tuple" ElseIf TypeOf ppppl Is ppppLight Then r$ = Typename(ppppl.GroupRef) Else r$ = "iBoxArray" End If strFunctions = FastSymbol(a$, ")") End If Else SyntaxError End If Exit Function End If If ppppl.arr Then If ppppl.ItemIsObject(w2) Then Set p = ppppl.item(w2) strFunctions = CheckItemType(bstackstr, p, a$, r$) Exit Function Else r$ = ppppl.ItemType(w2) End If Else If Typename(ppppl.GroupRef) = mHdlr Then Set p = ppppl.GroupRef strFunctions = CheckItemType(bstackstr, p, a$, r$, True) Exit Function ElseIf Typename(ppppl.GroupRef) = "PropReference" Then p = ppppl.GroupRef.Value If ppppl.GroupRef.LastHasObject Then r$ = Typename(ppppl.GroupRef.lastobj) Set p = ppppl.GroupRef.lastobj ppppl.GroupRef.clearlastobject Else r$ = Typename(p) End If Else r$ = Typename(ppppl.GroupRef) End If End If If r$ = "VarItem" Then r$ = "Optional" strFunctions = FastSymbol(a$, ")") Else bstackstr.tmpstr = s$ + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) GoTo ch1245 End If ElseIf dd > 0 Then If Left$(a$, 2) = "=>" Then If dd = 8 Then bstackstr.tmpstr = s$ + "[" + Left$(a$, 1) Else bstackstr.tmpstr = s$ + Left$(a$, 1) End If If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) GoTo ch1245 ElseIf GetVar(bstackstr, s$, w3) Then If dd = 8 Then If Typename(var(w3)) = "RefArray" Then bstackstr.tmpstr = s$ + "[" + Left$(a$, 1) 'BackPort a$ If Len(a$) = 0 Then a$ = Chr(8) Else Mid$(a$, 1, 1) = Chr(8) If IsNumberNew(bstackstr, a$, p, False) Then If bstackstr.lastobj Is Nothing Then If var(w3).Count > 0 And var(w3).vtType() = 8204 Then If var(w3).vtType(0) = 9 Then r$ = "Nothing" strFunctions = FastSymbol(a$, ")") Exit Function End If End If strFunctions = CheckItemType(bstackstr, p, a$, r$) Else Set p = bstackstr.lastobj Set bstackstr.lastobj = Nothing If Typename(p) = "RefArray" Then If MyIsObject(p(0)) Then Set p = p(0) Else p = p(0) End If End If strFunctions = CheckItemType(bstackstr, p, a$, r$) End If Else SyntaxError End If ElseIf Typename(var(w3)) = "mHandler" Then Set usehandler = var(w3) If usehandler.t1 = 2 Then w1 = 1 If BlockParam2s(a$, w1) Then a$ = Mid$(a$, w1 + 1) GoTo contaaaa End If End If MissingObj Else MissingObj End If Exit Function Else contaaaa: strFunctions = CheckItemType(bstackstr, var(w3), a$, r$) End If Exit Function ElseIf bstackstr.ExistVar2(s$) Then bstackstr.ReadVar s$, p strFunctions = CheckItemType(bstackstr, p, a$, r$) Exit Function Else Nosuchvariable s$ End If ElseIf IsFlatStringExpr(bstackstr, a$, s$) Then r$ = strProgIDfromSrting(s$) strFunctions = FastSymbol(a$, ")") Else SyntaxError End If End If Exit Function fstr32: ' "PARAGRAPH$(", "ΠΑΡΑΓΡΑΦΟΣ$(" ok w1 = Abs(IsLabel(bstackstr, a$, s$)) If w1 = 3 Then If GetVar(bstackstr, s$, w1) Then ' GET PARAGRAPH ORDER NUMBER If Not FastSymbol(a$, ",") Then missParam a$ Exit Function End If If FastSymbol(a$, "(") Then w3 = Abs(IsLabel(bstackstr, a$, s$)) If w3 = 1 Or w3 = 4 Then If Not GetVar(bstackstr, s$, w3) Then Nosuchvariable s$: Exit Function If Not FastSymbol(a$, ")") Then SyntaxError: Exit Function dd = 1 Else MissingnumVar Exit Function End If ElseIf Not IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then MissNumExpr Exit Function End If If VarTypeName(var(w1)) = doc Then r$ = var(w1).TextParagraphOrder(CLng(Fix(p))) If FastSymbol(a$, ",") Then If Not IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then MissNumExpr: Exit Function If pp < 0 Then If dd = 1 Then dd = var(w3) p = dd If var(w1).InvalidPara(CLng(p)) Then MissingDocRef Exit Function End If If var(w1).BackMove Then var(w3) = var(w1).BackStep(dd) Else var(w3) = var(w1).Advance(dd) End If r$ = var(w1).RemoveDocParaIndex(CLng(p)) Else r$ = var(w1).TextParagraphOrderRemove(CLng(p)) End If Else If dd = 1 Then dd = var(w3) p = dd If var(w1).InvalidPara(dd) Then MissingDocRef Exit Function End If If var(w1).BackMove Then var(w3) = var(w1).BackStep(dd) Else var(w3) = var(w1).Advance(dd) End If r$ = Mid$(var(w1).TextParagraph(CLng(p)), CLng(pp)) Else r$ = Mid$(var(w1).TextParagraphOrder(CLng(Fix(p))), CLng(pp)) End If End If Else If dd = 1 Then dd = var(w3) p = dd If var(w1).InvalidPara(dd) Then MissingDocRef Exit Function End If If var(w1).BackMove Then var(w3) = var(w1).BackStep(dd) Else var(w3) = var(w1).Advance(dd) End If r$ = var(w1).TextParagraph(CLng(p)) Else r$ = var(w1).TextParagraphOrder(CLng(Fix(p))) End If End If Else MissingDoc Exit Function End If strFunctions = FastSymbol(a$, ")", True) Else MissFuncParameterStringVarMacro a$ Exit Function End If ElseIf w1 = 6 Then If neoGetArray(bstackstr, s$, ppppl) Then If Not NeoGetArrayItem(ppppl, bstackstr, s$, w2, a$) Then Exit Function If Not FastSymbol(a$, ",") Then missParam a$ Exit Function End If If FastSymbol(a$, "(") Then w3 = Abs(IsLabel(bstackstr, a$, s$)) If w3 = 1 Or w3 = 4 Then If Not GetVar(bstackstr, s$, w3) Then Nosuchvariable s$: Exit Function If Not FastSymbol(a$, ")") Then SyntaxError: Exit Function dd = 1 Else MissingnumVar Exit Function End If ElseIf Not IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then MissNumExpr Exit Function End If If ppppl.ItemType(w2) = doc Then If FastSymbol(a$, ",") Then If Not IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then MissNumExpr: Exit Function If pp < 0 Then If dd = 1 Then dd = var(w3) p = dd If ppppl.item(w2).InvalidPara(dd) Then MissingDocRef Exit Function End If If ppppl.item(w2).BackMove Then var(w3) = ppppl.item(w2).BackStep(dd) Else var(w3) = ppppl.item(w2).Advance(dd) End If r$ = ppppl.item(w2).RemoveDocParaIndex(CLng(p)) Else r$ = ppppl.item(w2).TextParagraphOrderRemove(CLng(Fix(p))) End If Else If dd = 1 Then dd = var(w3) p = dd If ppppl.item(w2).InvalidPara(dd) Then MissingDocRef Exit Function End If If ppppl.item(w2).BackMove Then var(w3) = ppppl.item(w2).BackStep(dd) Else var(w3) = ppppl.item(w2).Advance(dd) End If r$ = Mid$(ppppl.item(w2).TextParagraph(CLng(p)), CLng(pp)) Else r$ = Mid$(ppppl.item(w2).TextParagraphOrder(CLng(Fix(p))), CLng(pp)) End If End If Else If dd = 1 Then dd = var(w3) p = dd If ppppl.item(w2).InvalidPara(dd) Then MissingDocRef Exit Function End If If ppppl.item(w2).BackMove Then var(w3) = ppppl.item(w2).BackStep(dd) Else var(w3) = ppppl.item(w2).Advance(dd) End If r$ = ppppl.item(w2).TextParagraph(CLng(p)) Else r$ = ppppl.item(w2).TextParagraphOrder(CLng(Fix(p))) End If End If Else MissingDoc Exit Function End If strFunctions = FastSymbol(a$, ")", True) Else missParam a$ End If End If Exit Function fstr33: '"UNION.DATA$(", "ΕΝΩΣΗ.ΣΕΙΡΑΣ$(" ok strFunctions = uniondata(bstackstr, a$, r$) Exit Function fstr34: ' "MAX.DATA$(", "ΜΕΓΑΛΟ.ΣΕΙΡΑΣ$(" ok If IsFlatStringExpr(bstackstr, a$, r$) Then Do While FastSymbol(a$, ",") If Not IsFlatStringExpr(bstackstr, a$, s) Then MissStringExpr: Exit Function If r$ < s Then r$ = s Loop strFunctions = FastSymbol(a$, ")", True) Else MissStringExpr End If Exit Function fstr35: ' "MIN.DATA$(", "ΜΙΚΡΟ.ΣΕΙΡΑΣ$(" ok If IsFlatStringExpr(bstackstr, a$, r$) Then Do While FastSymbol(a$, ",") If Not IsFlatStringExpr(bstackstr, a$, s) Then MissStringExpr: Exit Function If r$ > s Then r$ = s Loop strFunctions = FastSymbol(a$, ")", True) Else MissStringExpr End If Exit Function fstr36: ' "FUNCTION$(", "ΣΥΝΑΡΤΗΣΗ$(" ok If IsFlatStringExpr(bstackstr, a$, s$) Then If IsSymbolBracket(s$) Then PushStage bstackstr, False GlobalSub "A$()", block(s$) IsSymbol3 a$, "," ' fix this a$=... a$ = "A$(*" + a$ strFunctions = IsStrExp(bstackstr, a$, r$, False) PopStage bstackstr Else If lookOne(a$, ".") Then dd = 1 q1$ = aheadstatus(a$, , dd) s$ = s$ + Left$(a$, dd - 1) a$ = Mid$(a$, dd) End If FastSymbol a$, "," If Right$(s$, 1) = ")" Then ' fix this a$=... a$ = Left$(s$, Len(s$) - 1) + a$ ElseIf InStr(s$, ").") > 0 Then ''''''Or A$ Like ".*" FastSymbol a$, ")" ' fix this a$=... a$ = s$ + a$ Else If Right$("!" + s$, 1) = "$" Then ' fix this a$=... a$ = s$ + "(*" + a$ '' w1 put a @ from 102 Else ' fix this a$=... a$ = s$ + "$(" + a$ End If End If strFunctions = IsFlatStringExpr(bstackstr, a$, r$) End If End If Exit Function fstr37: '"HEX$(", "ΔΕΚΑΕΞ$(" ok strFunctions = mHex(bstackstr, a$, r$) Exit Function fstr38: '"SHOW$(", "ΦΑΝΕΡΟ$(" ok If IsFlatStringExpr(bstackstr, a$, r$) Then If FastSymbol(a$, ",") Then If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then r$ = mycoder.decryptline(r$, q$, CLng(Fix(p))) strFunctions = FastSymbol(a$, ")") Exit Function End If End If End If End If End If Exit Function fstr39: '"MENU$(", "ΕΠΙΛΟΓΗ$(", "ΕΠΙΛΟΓΕΣ$(" If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Abs(CLng(Fix(p))) With Form1.List1 If p > 0 And .listcount >= p Then r$ = .list(CLng(p) - 1) Else MyErMacroStr a$, "index out of limits", "ο δείκτης είναι εκτός ορίων" End If End With Else ' return a copy Set ppppl = New tuple: ppppl.PushDim (Form1.List1.listcount): ppppl.PushEnd: ppppl.arr = True For w2 = 0 To Form1.List1.listcount - 1 ppppl.item(w2) = Form1.List1.list(w2) Next w2 Set usehandler = New mHandler usehandler.t1 = 3 Set usehandler.objref = ppppl Set bstackstr.lastobj = usehandler Set ppppl = Nothing Set usehandler = Nothing r$ = vbNullString End If strFunctions = FastSymbol(a$, ")") Exit Function fstr40: '"REPLACE$(", "ΑΛΛΑΓΗ$(" ok If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") And IsFlatStringExpr(bstackstr, a$, q1$) Then If FastSymbol(a$, ",") And IsFlatStringExpr(bstackstr, a$, q2$) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Int(p) ElseIf LastErNum1 Then Exit Function ElseIf Not lookOne(a$, ",") Then SyntaxError Exit Function Else p = 1 End If If p < 0 Then p = 1 w1 = Len(q2$) pp = 0& If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then w1 = Abs(Int(pp)) ElseIf LastErNum1 Then Exit Function ElseIf Not lookOne(a$, ",") Then SyntaxError Exit Function Else w1 = Len(q2$) End If pp = 0& If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then ElseIf LastErNum1 Then Exit Function ElseIf Not lookOne(a$, ",") Then SyntaxError Exit Function End If End If End If If p > 1 Then r$ = Left$(q2$, p - 1) + Replace$(q2$, q$, q1$, p, w1, CLng(Abs(pp))) Else r$ = Replace$(q2$, q$, q1$, p, w1, CLng(Abs(pp))) End If ElseIf LastErNum1 Then ' no arithmetic parameters Exit Function Else r$ = Replace$(q2$, q$, q1$) End If ElseIf LastErNum1 Then ' third parameter Exit Function Else missParam a$ Exit Function End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If strFunctions = FastSymbol(a$, ")") Exit Function fstr41: '"PATH$(", "ΤΟΠΟΣ$(" ok get number or string If IsExp(bstackstr, a$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then q$ = p r$ = ExtractPath$(q$) Else r$ = GetSpecialfolder(CLng(Fix(p))) AddDirSep r$ End If ElseIf LastErNum1 Then Exit Function ElseIf IsStrExp(bstackstr, a$, q$, False) Then r$ = ExtractPath$(q$) ElseIf LastErNum1 Then Exit Function End If strFunctions = FastSymbol(a$, ")") Exit Function fstr42: '"UCASE$(", "ΚΕΦ$(" ok If IsFlatStringExpr(bstackstr, a$, r$) Then If FastSymbol(a$, ",") And IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If Fix(p) <> 0 Then If GetCodePage(CLng(Fix(p))) = 0 Then NoValidLocale Exit Function End If r$ = kUpper(Convert3(r$, CLng(Fix(p))), Fix(p)) Else r$ = kUpper(Convert3(r$, CLng(Clid)), CDbl(Clid)) End If ElseIf LastErNum1 Then Exit Function Else myUcase2 r$ End If ElseIf LastErNum1 Then Exit Function End If strFunctions = FastSymbol(a$, ")") Exit Function fstr43: '"LCASE$(", "ΠΕΖ$(" ok If IsFlatStringExpr(bstackstr, a$, r$) Then If FastSymbol(a$, ",") And IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If Fix(p) <> 0 Then If GetCodePage(CLng(Fix(p))) = 0 Then NoValidLocale Exit Function End If r$ = klower(Convert3(r$, CLng(Fix(p))), Fix(p)) Else r$ = klower(Convert3(r$, CLng(Clid)), CDbl(Clid)) End If ElseIf LastErNum1 Then Exit Function Else myLcase2 r$ End If ElseIf LastErNum1 Then Exit Function End If strFunctions = FastSymbol(a$, ")") Exit Function fstr44: '"STRING$(", "ΕΠΑΝ$(" OK w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) If LenB(q$) > 0 Then On Error Resume Next w2 = StrPtr(q$) If w2 > 0 And p > 0 Then w2 = MemLong(w2 - 4) If w2 > 0 Then pp = LibMemory.EmptyArray(1, vbByte) ReDim pp(w2 * p - 1) r$ = pp pp = Empty While p > 0 p = p - 1 MidB$(r$, p * w2 + 1, w2) = q$ Wend Else r$ = vbNullString End If Else r$ = vbNullString End If End If ElseIf LastErNum1 Then Exit Function End If ElseIf IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsSymbol(a$, "JSON", 4) Then r$ = StringToEscapeStr(q$, True) ElseIf IsSymbol(a$, "ENCODE64", 8) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Int(Abs(p)) If p = 0 Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then r$ = Encode64(q$, False, CLng(p)) ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else r$ = Encode64(q$, CBool(p)) End If Else r$ = Encode64(q$, CBool(p)) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else r$ = Encode64(q$) End If ElseIf IsSymbol(a$, "DECODE64", 8) Then While FastSymbol(q$, vbCrLf, , 2) Wend r$ = Decode64(q$, par) If Not par Then MyEr "No base 64 encoding string", "Το αλφαριθμητικό δεν έχει δεδομένα σε βάση 64" Exit Function End If ElseIf IsSymbol(a$, "UTF8", 4) Then If IsSymbolNoSpace(a$, "DEC", 3) Then r$ = utf8decode(q$) ElseIf IsSymbolNoSpace(a$, "ENC", 3) Then r$ = utf8encode(q$) Else SyntaxError strFunctions = False Exit Function End If ElseIf IsSymbol(a$, "URL", 3) Then If IsSymbolNoSpace(a$, "ENC", 3) Then dd = 0 If FastSymbol(a$, "1") Then dd = 1 ElseIf IsSymbolNoSpace(a$, "RFC3986", 7) Then dd = 1 ElseIf FastSymbol(a$, "2") Then dd = 2 ElseIf IsSymbolNoSpace(a$, "HTML5", 5) Then dd = 2 ElseIf IsSymbolNoSpace(a$, "SYS", 3) Then dd = 3 End If If dd = 3 Then r$ = URLEncode(q$, IsSymbol(a$, "+")) Else r$ = URLEncodeEsc(q$, IsSymbol(a$, "+"), dd) End If ElseIf IsSymbolNoSpace(a$, "DEC", 3) Then r$ = DecodeEscape(q$, IsSymbol(a$, "+")) ElseIf IsSymbolNoSpace(a$, "HOST", 4) Then r$ = GetHost(q$) ElseIf IsSymbolNoSpace(a$, "PATH", 4) Then r$ = GetUrlPath(q$) ElseIf IsSymbolNoSpace(a$, "PORT", 4) Then r$ = GetDomainName(q$, True) If r$ <> vbNullString Then If Left$(r$, 1) = "[" Then dd = InStr(r$, "]") + 1 r$ = Mid$(r$, dd) Else dd = InStr(r$, "@") If dd > 0 Then r$ = Mid$(r$, dd + 1) End If If r$ <> vbNullString Then dd = InStr(r$, ":") If dd > 0 Then r$ = Mid$(r$, dd + 1) Else r$ = "" End If End If If r$ = "" Then Select Case UCase(GetUrlParts(q$, 1)) Case "HTTP", "TELNET" r$ = "80" Case "FTP" r$ = "21" Case "HTTPS" r$ = "443" Case "LDAP" r$ = "389" Case "SOCKS5" r$ = "1080" End Select End If ElseIf IsSymbolNoSpace(a$, "PART", 4) Then If IsExp(bstackstr, a$, p, True, True, False) Then dd = CLng(p) Else dd = 1 End If r$ = GetUrlParts(q$, p) ElseIf IsSymbolNoSpace(a$, "SCHEME", 6) Then If IsExp(bstackstr, a$, p, True, True, False) Then dd = CLng(p) Else dd = 1 End If r$ = GetUrlParts(q$, dd, 1) ElseIf IsSymbolNoSpace(a$, "FRAGMENT", 8) Then r$ = DecodeEscape(q$, IsSymbol(a$, "+")) If r$ <> vbNullString Then dd = InStr(r$, "#") If dd > 0 Then r$ = Mid$(r$, dd + 1) Else r$ = vbNullString End If ElseIf IsSymbolNoSpace(a$, "USERINFO", 8) Then r$ = GetDomainName(q$, True) If r$ <> vbNullString Then dd = InStr(r$, "@") If dd > 0 Then r$ = Left$(r$, dd - 1) Else r$ = vbNullString End If ElseIf IsSymbolNoSpace(a$, "AUTHORITY", 9) Then r$ = GetDomainName(q$, True) If r$ <> vbNullString Then If Left$(r$, 1) = "[" Then dd = InStr(r$, "]") r$ = Mid$(r$, 2, dd - 2) End If End If Else SyntaxError strFunctions = False Exit Function End If ElseIf IsSymbolNoSpace(a$, "WIDE2BYTES", 10) Then ' CONVERT STRING TO BYTES (NEED VALUES TO BE 0 TO 255 FOR EACH WCHAR) r$ = FixStr2Bytes(q$) ' ? STRING$(STR$("ABCD") AS BYTES2WIDE)="ABCD" (CHR$(STR$("ABCD") DO THE SAME BUT FOR SPECIFIC LOCALE) ElseIf IsSymbolNoSpace(a$, "BYTES2WIDE", 10) Then r$ = FixBytes2String(q$) Else SyntaxError Exit Function End If ElseIf LastErNum1 Then Exit Function Else r$ = StringToEscapeStr(q$) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If strFunctions = FastSymbol(a$, ")") Exit Function fstr45: ' "MID$(", "ΜΕΣ$(" OK w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Abs(p) If p = 0 Then MyErMacroStr a$, "Zero pos in mid$ not allowed", "Μηδενική θέση στην ΜΕΣ$ δεν επιτρέπεται" Exit Function ElseIf FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then pp = Abs(pp) If IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = MidB$(q$, p, pp) ElseIf LastErNum1 Then Exit Function Else SyntaxError Exit Function End If Else r$ = Mid$(q$, p, pp) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If ElseIf IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = MidB$(q$, p) Else SyntaxError Exit Function End If Else r$ = Mid$(q$, p) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ End If strFunctions = FastSymbol(a$, ")") Else missParam a$ End If ElseIf LastErNum1 Then Exit Function Else MissStringExpr Exit Function End If Exit Function fstr46: ' "LEFT$(", "ΑΡΙΣ$(" OK w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") And IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Abs(p) If IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = LeftB$(q$, p) Else SyntaxError Exit Function End If Else r$ = Left$(q$, p) End If ElseIf LastErNum1 Then Exit Function End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else MissStringExpr End If Exit Function fstr47: ' "RIGHT$(", "ΔΕΞΙ$(" OK w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") And IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = Abs(p) If IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = RightB$(q$, p) Else SyntaxError Exit Function End If Else r$ = Right$(q$, p) End If ElseIf LastErNum1 Then Exit Function End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else MissStringExpr End If Exit Function fstr48: ' "SND$(", "ΗΧΟ$(" OK If IsFlatStringExpr(bstackstr, a$, q$) Then q1$ = ExtractNameOnly(q$) If q1$ = "" Then MyEr "NO FILENAME", "ΧΩΡΙΣ ΟΝΟΜΑ ΑΡΧΕΙΟΥ" Else q1$ = ExtractPath(q$) + q1$ q$ = ExtractType(q$) If q$ = "" Then r$ = CFname(q1$ + ".WAV") If r$ = "" Then r$ = CFname(q1$ + ".MP3") ElseIf q$ = "wav" Or q$ = "mp3" Then r$ = CFname(q1$ + "." + q$) End If strFunctions = FastSymbol(a$, ")") End If ElseIf LastErNum1 Then Exit Function Else MissStringExpr End If Exit Function fstr49: ' "BMP$(", "ΕΙΚ$(" OK If IsFlatStringExpr(bstackstr, a$, q$) Then q1$ = ExtractNameOnly(q$) If q1$ = "" Then MyEr "NO FILENAME", "ΧΩΡΙΣ ΟΝΟΜΑ ΑΡΧΕΙΟΥ" Else q1$ = ExtractPath(q$) + q1$ q$ = ExtractType(q$) If q$ = "" Then r$ = CFname(q1$ + ".bmp") If r$ = "" Then r$ = CFname(q1$ + ".png") If r$ = "" Then r$ = CFname(q1$ + ".gif") If r$ = "" Then r$ = CFname(q1$ + ".jpg") ElseIf q$ = "bmp" Or q$ = "png" Or q$ = "gig" Or q$ = "jpg" Then r$ = CFname(q1$ + "." + q$) End If strFunctions = FastSymbol(a$, ")") End If ElseIf LastErNum1 Then Exit Function Else MissStringExpr End If Exit Function fstr50: '"JPG$(", "ΦΩΤΟ$(" If IsFlatStringExpr(bstackstr, a$, q$) Then q1$ = ExtractNameOnly(q$) If q1$ = "" Then MyEr "NO FILENAME", "ΧΩΡΙΣ ΟΝΟΜΑ ΑΡΧΕΙΟΥ" Else q1$ = ExtractPath(q$) + q1$ q$ = ExtractType(q$) If q$ = "" Then r$ = CFname(q1$ + ".jpg") If r$ = "" Then r$ = CFname(q1$ + ".png") If r$ = "" Then r$ = CFname(q1$ + ".gif") If r$ = "" Then r$ = CFname(q1$ + ".bmp") ElseIf q$ = "bmp" Or q$ = "png" Or q$ = "gig" Or q$ = "jpg" Then r$ = CFname(q1$ + "." + q$) End If strFunctions = FastSymbol(a$, ")") End If ElseIf LastErNum1 Then Exit Function Else MissStringExpr End If Exit Function fstr69: '"RTRIM$(", "ΑΠΟΚ.ΔΕ$(" ok w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = MyTrimRB$(q$) Else SyntaxError Exit Function End If Else r$ = MyTrimRW$(q$) End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else missParam a$ End If Exit Function fstr70: '"LTRIM$(", "ΑΠΟΚ.ΑΡ$(" ok w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = MyTrimLB$(q$) Else SyntaxError Exit Function End If Else r$ = MyTrimLW$(q$) End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else missParam a$ End If Exit Function fstr51: '"TRIM$(", "ΑΠΟΚ$(" ok w2 = 2 + (AscW(q$) < 128) If IsFlatStringExpr(bstackstr, a$, q$) Then If IsLabelSymbolNew(a$, "ΩΣ", "AS", w2) Then If IsLabelSymbolNew(a$, "ΨΗΦΙΟ", "BYTE", w2) Then r$ = MyTrimB$(q$) Else SyntaxError Exit Function End If Else r$ = MyTrim$(q$) End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else missParam a$ End If Exit Function fstr52: '"QUOTE$(", "ΠΑΡΑΘΕΣΗ$(" ok r$ = vbNullString q1$ = vbNullString Do If IsStrExp(bstackstr, a$, q$) Then jmp12984657: r$ = r$ + q1$ + Chr(34) + q$ + Chr(34) ElseIf LastErNum1 Then Exit Function ElseIf IsExp(bstackstr, a$, p, , True) Then If MemInt(VarPtr(p)) = 20 Then r$ = r$ + q1$ + CStr(p) ElseIf MemInt(VarPtr(p)) = vbString Then q$ = p GoTo jmp12984657 Else r$ = r$ + q1$ + LTrim$(str(p)) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If If Not FastSymbol(a$, ",") Then Exit Do q1$ = "," Loop strFunctions = FastSymbol(a$, ")"): Exit Function Exit Function fstr53: '"ΣΩΡΟΣ$(", "STACK$(" ok ' now we can add complex and biginteger as part of the string type stack. r$ = vbNullString Do If IsStrExp(bstackstr, a$, q$) Then r$ = r$ + Sput(q$) ElseIf LastErNum1 Then Exit Function ElseIf IsExp(bstackstr, a$, p) Then If Not bstackstr.lastobj Is Nothing Then Set p = bstackstr.lastobj Set bstackstr.lastobj = Nothing If TypeOf p Is BigInteger Then r$ = r$ + " " + p.ToString + "U" ' new GoTo cont12345 Else MyEr "Number or and string allowed", "επιτρέπονται Αριθμοί ή και Γράμματα " Exit Function End If End If Select Case VarType(p) Case vbByte r$ = r$ + " " + LTrim$(str$(p)) + "UB" ' new Case vbDate r$ = r$ + " " + LTrim$(str$(CDbl(p))) + "UD" ' new Case vbString r$ = r$ + Sput(q$) Case vbLong r$ = r$ + " " + LTrim$(str$(p)) + "&" Case vbDecimal r$ = r$ + " " + LTrim$(str$(p)) + "@" Case vbSingle r$ = r$ + " " + LTrim$(str$(p)) + "~" Case vbCurrency r$ = r$ + " " + LTrim$(str$(p)) + "#" Case vbInteger r$ = r$ + " " + LTrim$(str$(p)) + "%" Case 20 r$ = r$ + " " + CStr(p) + "&&" Case 36 If TypeOf p Is Complex Then r$ = r$ + " " + strComplex(p, , True) Else r$ = r$ + " 0" End If Case Else r$ = r$ + " " + LTrim$(str$(p)) End Select ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function cont12345: End If If Not IsSymbol3(a$, ",") Then Exit Do Loop strFunctions = FastSymbol(a$, ")") Exit Function fstr54: '"ADD.LICENSE$(", "ΒΑΛΕ.ΑΔΕΙΑ$(" If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If IsFlatStringExpr(bstackstr, a$, q1$) Then Err.Clear On Error Resume Next If q1$ = vbNullString Then r$ = Licenses.Add(q$) Else r$ = Licenses.Add(q$, q1$) End If If Err.Number > 0 And Err.Number <> 732 Then MissLicense Err.Clear On Error GoTo 0 strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else Err.Clear On Error Resume Next r$ = Licenses.Add(q$) If Err > 0 And Err.Number <> 732 Then MissLicense Err.Clear On Error GoTo 0 strFunctions = FastSymbol(a$, ")") End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Exit Function fstr55: '"ENVELOPE$(", "ΦΑΚΕΛΟΣ$(" ok If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If Not IsFlatStringExpr(bstackstr, a$, q1$) Then missParam a$ Exit Function End If Else q1$ = vbNullString End If If LastErNum1 Then Exit Function ElseIf VALIDATE(q$, UCase$(q1$), q2$) Then ' Only S and N r$ = q2$ Else r$ = vbNullString End If ElseIf LastErNum1 Then Exit Function Else ' STACK$(BSTACKSTR) If FastSymbol(a$, ",") Then If Not IsFlatStringExpr(bstackstr, a$, q1$) Then missParam a$ Exit Function End If Else q1$ = vbNullString End If If LastErNum1 Then Exit Function ElseIf VALIDATEmStiva(bstackstr, UCase$(q1$), q2$) Then r$ = q2$ Else r$ = vbNullString End If End If strFunctions = FastSymbol(a$, ")") Exit Function fstr56: '"FIELD$(", "ΠΕΔΙΟ$(" If IsFlatStringExpr(bstackstr, a$, q$) Then If FastSymbol(a$, ",") Then If Not IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then strFunctions = False Exit Function End If p = Abs(p) Else strFunctions = False Exit Function End If dd = CLng(p) r$ = Left$(Trim$(q$), dd) dd = dd - Len(r$) If dd > 0 Then r$ = r$ + space$(dd) strFunctions = FastSymbol(a$, ")"): Exit Function Else missParam a$ End If Exit Function fstr57: '"DRW$(", "ΣΧΔ$(" If IsFlatStringExpr(bstackstr, a$, q$) Then q1$ = ExtractNameOnly(q$) If q1$ = "" Then MyEr "NO FILENAME", "ΧΩΡΙΣ ΟΝΟΜΑ ΑΡΧΕΙΟΥ" Else q1$ = ExtractPath(q$) + q1$ q$ = ExtractType(q$) If q$ = "" Then r$ = CFname(q1$ + ".WMF") If r$ = "" Then r$ = CFname(q1$ + ".EMF") ElseIf q$ = "wav" Or q$ = "mp3" Then r$ = CFname(q1$ + "." + q$) End If strFunctions = FastSymbol(a$, ")") End If ElseIf LastErNum1 Then Exit Function Else MissStringExpr End If Exit Function fstr58: '"TIME$(", "ΧΡΟΝΟΣ$(" OK If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True) Then If MemInt(VarPtr(pp)) = vbString Then SwapString2Variant s$, pp pp = Clid GoTo contstr111 End If ElseIf LastErNum1 Then Exit Function ElseIf IsStrExp(bstackstr, a$, s$, False) Then pp = Clid GoTo contstr111 ElseIf LastErNum1 Then Exit Function Else pp = Clid End If If FastSymbol(a$, ",") Then If IsFlatStringExpr(bstackstr, a$, s$) Then contstr111: If UCase(s$) = "SHORT TIME" Then s$ = GetlocaleString2(&H5D, pp) ElseIf UCase(s$) = "LONG TIME" Then s$ = GetlocaleString2(&H79, pp) ElseIf InStr(s$, ":n") > 0 Or InStr(s$, "n:") > 0 Then r$ = format(CDate(p), s$) GoTo str1112344 End If s$ = Replace(s$, "M", "m") s$ = Replace(s$, "S", "s") s$ = Replace(s$, "n", "m") r$ = FormatTimeWithLocale(s$, CDate(p), pp) str1112344: ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else r$ = FormatTimeWithLocale(GetlocaleString2(&H5D, pp), CDate(p), pp) End If Else r$ = format(p, "SHORT TIME") End If ElseIf LastErNum1 Then Exit Function Else r$ = Trim$(GetTimeZoneInfo) End If strFunctions = FastSymbol(a$, ")") Exit Function fstr59: ' "DATE$(", "ΗΜΕΡΑ$(" ok strFunctions = mDate(bstackstr, a$, r$) Exit Function fstr60: '"STR$(", "ΓΡΑΦΗ$(" ok If IsExp(bstackstr, a$, p) Then fstr601: If Not bstackstr.lastobj Is Nothing Then If TypeOf bstackstr.lastobj Is Group Then If Not bstackstr.lastobj.HasValue Then MyErMacro a$, "Group has no value", "Η ομάδα δεν έχει αξία" Exit Function End If ElseIf TypeOf bstackstr.lastobj Is mHandler Then p = 0 Set usehandler = bstackstr.lastobj If usehandler.t1 = 4 Then p = usehandler.index_cursor Set bstackstr.lastobj = Nothing Set usehandler = Nothing ElseIf TypeOf bstackstr.lastobj Is BigInteger Then r$ = bstackstr.lastobj.ToString Set bstackstr.lastobj = Nothing If FastSymbol(a$, ")") Then strFunctions = True Exit Function ElseIf FastSymbol(a$, ",") Then w1 = 1 s$ = aheadstatus(a$, True, w1) If s$ = vbNullString Then GoTo km102300 If w1 > 1 Then Mid$(a$, 1, w1 - 1) = space$(w1 - 1) If FastSymbol(a$, ")") Then strFunctions = True Exit Function Else GoTo km102300 End If Else km102300: SyntaxError Exit Function End If ElseIf TypeOf bstackstr.lastobj Is PropReference Then Set bstackstr.lastobj = Nothing GoTo fstr601 End If ElseIf MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p GoTo KM234 End If If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True) Then ' it is LCID If MemInt(VarPtr(pp)) = vbString Then SwapString2Variant q$, pp GoTo KM123 ElseIf pp = 0 Then If MemInt(VarPtr(p)) = vbBoolean Then If ShowBooleanAsString Then r$ = format$(p, DefBooleanString) Else r$ = CStr(p * 1) End If Else r$ = CStr(p) End If Else q$ = GetlocaleString2(14, pp) If MemInt(VarPtr(p)) = vbBoolean Then If Not ShowBooleanAsString Then r$ = CStr(p * 1) ElseIf pp = 1032 Then r$ = format$(p, ";Αληθές;Ψευδές") ElseIf pp = 1033 Then r$ = format$(p, ";\T\r\u\e;\F\a\l\s\e") Else r$ = format$(p, DefBooleanString) End If ElseIf MemInt(VarPtr(p)) = vbDate Then If p <= 1 Then r$ = FormatTimeWithLocale(GetlocaleString2(&H79, pp), CDate(p), pp) GoTo contstrhere End If r$ = FormatDateWithLocale(GetlocaleString2(&H1F, pp), CDate(p), pp) Else If CheckInt64(p) Then r$ = CStr(p) ElseIf MemInt(VarPtr(p)) = 36 Then If TypeOf p Is Complex Then r$ = strComplex(p, q$) Else r$ = "" End If Else r$ = LTrim$(str$(p)) Select Case VarType(p) Case vbLong, vbInteger Case Else If Left$(r$, 1) = "." Then If AscW(q$) = 46 Then r$ = "0" + r$ Else r$ = "0" + Replace(r$, ".", q$) End If ElseIf Left$(r$, 2) = "-." Then If AscW(q$) = 46 Then r$ = "-0" + Mid$(r$, 2) Else r$ = "-0" + Replace(Mid$(r$, 2), ".", q$) End If ElseIf AscW(q$) <> 46 Then If InStr(r$, ".") > 1 Then r$ = Replace(r$, ".", q$) End If End If End Select End If End If End If GoTo contstrhere ElseIf IsStrExp(bstackstr, a$, q$, False) Then ' or we give first a KM123: On Error Resume Next If TypeOf p Is Complex Then If p.i = 0 Then r$ = format$(p.r, q$) ElseIf p.r = 0 Then r$ = "(" & format$(p.i, q$) & "i)" Else If p.i < 0 Then r$ = "" Else r$ = "+" r$ = "(" & format$(p.r, q$) & r$ & format$(p.i, q$) & "i)" End If ElseIf MemInt(VarPtr(p)) = vbDate Then contdatetime: q$ = Trim$(q$) If UCase(q$) = "SHORT DATE" Then q$ = GetlocaleString2(&H1F, 1033&) ElseIf UCase(q$) = "LONG DATE" Then q$ = GetlocaleString2(&H20, 1033&) ElseIf UCase(q$) = "SHORT TIME" Then q$ = GetlocaleString2(&H5D, 1033&) r$ = FormatTimeWithLocale(q$, CDate(p), 1033&) GoTo contstrhere ElseIf UCase(q$) = "LONG TIME" Then q$ = GetlocaleString2(&H79, 1033&) r$ = FormatTimeWithLocale(q$, CDate(p), 1033&) GoTo contstrhere ElseIf q$ = "" Then If p <= 1 Then s$ = GetlocaleString2(&H79, 1033&) r$ = FormatTimeWithLocale(s$, CDate(p), 1033&) GoTo contstrhere End If p = Int(p) q$ = GetlocaleString2(&H1F, 1033&) ElseIf InStr(q$, "D") > 0 Or InStr(q$, "Y") > 0 Then r$ = format(CDate(p), q$) GoTo contstrhere ElseIf (InStr(q$, "M") = 0 And InStr(q$, "d") = 0 And InStr(q$, "y") = 0) Then ' InStr(q$, "m") > 0 Or r$ = format(CDate(p), q$) GoTo contstrhere End If q$ = Replace(q$, "m", "M") q$ = Replace(q$, "D", "d") q$ = Replace(q$, "Y", "y") q$ = Replace(q$, "G", "g") ' era r$ = FormatDateWithLocale(q$, CDate(p), 1033&) GoTo contstrhere Else r$ = format(p, q$) End If If Err.Number = 6 Then Overflow Err.Clear If Not NoUseDec Then If mNoUseDec Then r$ = Replace$(r$, GetDeflocaleString(LOCALE_SDECIMAL), Chr(2)) If InStr(r$, "#IN") > 0 Then r$ = Replace$(r$, GetDeflocaleString(LOCALE_STHOUSAND) + "#", Chr(2) + "#") r$ = Replace$(r$, GetDeflocaleString(LOCALE_STHOUSAND), Chr(3)) r$ = Replace$(r$, Chr(2), NowDec$) r$ = Replace$(r$, Chr(3), NowThou$) ElseIf GetDeflocaleString(LOCALE_SDECIMAL) = "," Then r$ = Replace$(r$, ",", Chr(2)) r$ = Replace$(r$, ".", ",") r$ = Replace$(r$, Chr(2), ".") End If Else If InStr(r$, "#IN") > 0 Then r$ = Replace$(r$, ".#", NowDec$ + "#") End If contstrhere: If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then If pp > 0 Then r$ = Left$(r$ + space$(pp), pp) Else r$ = Right$(space$(Abs(pp)) + r$, Abs(pp)) End If Else Exit Function End If End If Else missParam a$ Exit Function End If Else Select Case MemInt(VarPtr(p)) Case vbBoolean If ShowBooleanAsString Then r$ = format$(p, ";\T\r\u\e;\F\a\l\s\e") Else r$ = CStr(p * 1) End If Case vbEmpty r$ = vbNullString Case vbDate If p <= 1 Then r$ = FormatTimeWithLocale("HH:mm:ss", CDate(p), 1033&) Else r$ = FormatDateWithLocale(GetlocaleString2(&H1F, 1033&), CDate(p), 1033&) End If Case Else If TypeOf p Is Complex Then r$ = strComplex(p) Else r$ = str(p) End If End Select End If strFunctions = FastSymbol(a$, ")") Exit Function ElseIf IsStrExp(bstackstr, a$, r$, False) Then KM234: If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True) Then If VarType(pp) = vbString Then SwapString2Variant q$, pp r$ = format(r$, q$) ElseIf Fix(pp) = 0 Then r$ = Convert2(r$, Clid) Else If GetCodePage(CLng(Fix(pp))) <> 0 Then r$ = Convert2(r$, CLng(Fix(pp))) Else strFunctions = False NoValidLocale Exit Function End If End If ElseIf LastErNum1 Then Exit Function ElseIf IsStrExp(bstackstr, a$, q$, False) Then r$ = format(r$, q$) ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else r$ = StrConv(r$, vbFromUnicode, Clid) End If strFunctions = FastSymbol(a$, ")") Exit Function ElseIf LastErNum1 Then Exit Function Else missParam a$ End If Exit Function fstr61: '"CHRCODE$(", "ΧΑΡΚΩΔ$(" ok If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then w3 = CLng(p) If w3 >= &H10000 And w3 <= &H10FFFF Then w3 = w3 - &H10000 r$ = ChrW(UINT(w3 \ &H400& + &HD800&)) + ChrW(UINT((w3 And &H3FF&) + &HDC00&)) Else r$ = ChrW$(w3) End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Exit Function Else missParam a$ End If Exit Function fstr62: ' "CHR$(", "ΧΑΡ$(" ok If IsExp(bstackstr, a$, p, , True) Then If MemInt(VarPtr(p)) = vbString Then q$ = p: GoTo g131993 If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then If pp = 0 Then pp = LCID_DEF Else If GetCodePage(CLng(Fix(pp))) = 0 Then NoValidLocale Exit Function End If End If r$ = ChrW$(AscW(StrConv(ChrW$(p Mod 256), 64, CLng(Fix(pp))))) ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else r$ = ChrW$(AscW(StrConv(ChrW$(Fix(p) Mod 256), 64, Clid))) End If If InStr(r$, ChrW(&HFFFFF8FB)) > 0 Then r$ = Replace(r$, ChrW(&HFFFFF8FB), ChrW(&H2007)) strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then ElseIf IsStrExp(bstackstr, a$, q$, False) Then 'CONVERT TO ASCII g131993: If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, pp, flatobject:=True, nostring:=True) Then If Fix(pp) = 0 Then r$ = Convert3(q$, LCID_DEF) ElseIf LCID_DEF = 1032 Then If GetCodePage(CLng(Fix(pp))) = 0 Then NoValidLocale Exit Function End If r$ = Convert3(q$, CLng(Fix(pp))) Else If GetCodePage(CLng(Fix(pp))) = 0 Then NoValidLocale Exit Function End If r$ = Convert3(Convert2(q$, LCID_DEF), CLng(Fix(pp))) End If ElseIf LastErNum1 Then Exit Function Else missParam a$ Exit Function End If Else r$ = StrConv(q$, vbUnicode, Clid) End If strFunctions = FastSymbol(a$, ")") ElseIf LastErNum1 Then Else missParam a$ End If Exit Function fstr63: ' "GROUP$(", "ΟΜΑΔΑ$(" ok r$ = vbNullString strFunctions = IsGroupCom(bstackstr, a$, p) Exit Function fstr64: ' "PROPERTY$(", "ΙΔΙΟΤΗΤΑ$(" ok dd = Abs(IsLabel(bstackstr, a$, s$)) If dd = 1 Or dd = 3 Or dd = 6 Then If dd = 6 Then If Not FastSymbol(a$, ")", True) Then Exit Function If Not GetVar(bstackstr, s$, w2) Then GoTo jmp147811 If dd = 6 Then If Not MyIsObject(var(w2)) Then GoTo jmp147811 If TypeOf var(w2) Is iBoxArray Then GoTo jmp147811 Set ppppl = var(w2) If ppppl.arr Then GoTo jmp147811 If Not ppppl.ItemType(-1) = mProp Then GoTo jmp147811 Set bstackstr.lastobj = ppppl.GroupRef Else If Not VarTypeName(var(w2)) = mProp Then GoTo jmp147811 Set bstackstr.lastobj = var(w2) End If r$ = vbNullString strFunctions = FastSymbol(a$, ")", True) Exit Function Else jmp147811: MyErMacro a$, "Expected a property name", "Περίμενα όνομα ιδιότητας" End If Exit Function fstr65: ' Title$() ok If IsFlatStringExpr(bstackstr, a$, q$) Then strFunctions = True r$ = Tcase(q$) End If strFunctions = FastSymbol(a$, ")") Exit Function End Function Function mEval(ByVal q$, bstackstr As basetask, a$, r$) As Boolean Dim myGroup As Group, usehandler As mHandler, w2 As Long, w3 As Long Dim p, pp, dd As Long, anything As Object, s$, pppp As ppppLight, oldremove As Boolean If IsExp(bstackstr, a$, p) Then If MemInt(VarPtr(p)) = vbString Then If bstackstr.lastobj Is Nothing Then q$ = p: GoTo g19383 End If End If If bstackstr.lastobj Is Nothing Then Exit Function If TypeOf bstackstr.lastobj Is mHandler Then Set usehandler = bstackstr.lastobj Set anything = usehandler If usehandler.IamEnum Then r$ = usehandler.index_cursor Set bstackstr.lastobj = Nothing mEval = FastSymbol(a$, ")", True) Exit Function ElseIf Not CheckLastHandlerOrIterator(anything, dd) Then InternalError mEval = False Exit Function End If Set usehandler = anything With usehandler If .t1 = 1 Or .t1 = 5 Then If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then p = MyRound(p) If Abs(p) < .objref.Count Then If p < 0 Then .objref.index = .objref.Count + MyRound(p) Else .objref.index = MyRound(p) End If .objref.Done = True r$ = .objref.KeyToString Else MyErMacroStr a$, "Index out of limits", "Δείκτης εκτός ορίων" mEval = False Exit Function End If Else MissPar End If ElseIf .objref.Done Or dd >= 0 Then If dd >= 0 Then .objref.index = dd .objref.Done = True End If If FastSymbol(a$, "!") Then r$ = .objref.KeyToString Set bstackstr.lastobj = Nothing Else If .objref.IsObj Then rValue bstackstr, usehandler.objref.ValueObj r$ = vbNullString Else Set bstackstr.lastobj = Nothing r$ = CStr(.objref.Value) End If End If End If ElseIf .t1 = 4 Then If dd = -1 Then .objref.index = .index_start r$ = .objref.KeyToString() Set bstackstr.lastobj = Nothing Else ' IS A MEMBLOCK Set bstackstr.lastobj = Nothing If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then pp = p If FastSymbol(a$, "!") Then If FastPureLabel(a$, s$, , True) Then If .objref.UseStruct Then If .objref.structref.Find(s$) Then pp = .objref.structref.sValue w2 = cUlng(uintnew(.objref.GetPtr(p)) + .objref.structref.StructOffset) If FastSymbol(a$, "!") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then w2 = cUlng(uintnew(w2) + MyRound(p) * Abs(pp)) End If End If Else MyErMacroStr a$, "Unknown variable " + s$, "Άγνωστη μεταβλητή " + s$ Exit Function End If Else MyErMacroStr a$, "no structure exist", "δεν υπάρχει δομή" Exit Function End If Else w2 = .objref.GetBytePtr(p) End If Else w2 = .objref.GetPtr(p) End If If .objref.status = 4 Then MyEr "Buffer locked, wrong use of pointer", "Η Διάρθρωση κλειδώθηκε, κακή χρήση δείκτη": Exit Function End If dd = 2 + (AscW(q$) < 128) If FastSymbol(a$, ",") Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then ' NOW WE KNOW HOW MANY BYTES WE TAKE (ALWAYS BYTES) p = MyRound(p) If .objref.ValidArea(w2, p) Then If p Mod 2 = 1 Then r$ = StrConv(String(p, Chr(0)), vbFromUnicode) Else r$ = String$((p + 1) \ 2, Chr(0)) End If CopyBytes CLng(p), StrPtr(r$), w2 Else MyErMacroStr a$, "Buffer is small, can't get so many bytes", "Η Διάρθρωση είναι μικρή, δεν μπορώ να πάρω τόσα ψηφία" End If Else MissPar mEval = False Exit Function End If ElseIf IsLabelSymbolNew(a$, "ΩΣ", "AS", dd) Then w2 = .objref.GetBytePtr(p) If IsLabelSymbolNew(a$, "ΓΡΑΜΜΑ", "STRING", dd) Then CopyBytes 4, VarPtr(w3), w2 dd = .objref.GetStringFromOffset(w2, r$) If w3 <> dd Then MyEr "Invalid Pointer for BSTR at Buffer", "Μη έγκυρος δείκτης για BSTR στη Διάθρωση" mEval = False Exit Function End If ElseIf IsLabelSymbolNew(a$, "ΧΑΡΑΚΤΗΡΕΣ", "UNICODE", dd) Then w2 = .objref.GetBytePtr(p) CopyBytes 4, VarPtr(w3), w2 If w3 > &H100000 Then r$ = GetBStrFromBstrPtr(w3) Else MyEr "Invalid Pointer for BSTR at Buffer", "Μη έγκυρος δείκτης για BSTR στη Διάθρωση" mEval = False Exit Function End If ElseIf IsLabelSymbolNew(a$, "ΤΟΠΙΚΟ", "LOCALE", dd) Then w2 = .objref.GetBytePtr(p) CopyBytes 4, VarPtr(w3), w2 If w3 > &H100000 Then If IsExp(bstackstr, a$, p, flatobject:=True, nostring:=True) Then If GetCodePage(CLng(Fix(p))) = 0 Then NoValidLocale Exit Function End If r$ = Convert3(Convert2(GetBStrFromPtr(w3, True), LCID_DEF), CLng(Fix(p))) Else r$ = Convert3(Convert2(GetBStrFromPtr(w3, True), LCID_DEF), Clid) End If Else MyEr "Invalid Pointer for BSTR at Buffer", "Μη έγκυρος δείκτης για BSTR στη Διάθρωση" mEval = False Exit Function End If End If Else If .objref.WhatIsBasicItem = vbString Or pp < 0 Then CopyBytes 4, VarPtr(w3), w2 dd = .objref.GetStringFromOffset(w2, r$) If w3 <> dd Then If dd = 0 Then r$ = vbNullString Else ' extreme change with Fast ! in console or in code using Set Fast ! If extreme Then ' unsafe may crash r$ = GetBStrFromBstrPtr(w3) Else MyEr "Invalid Pointer for BSTR at Buffer", "Μη έγκυρος δείκτης για BSTR στη Διάθρωση" mEval = False Exit Function End If End If End If Else p = .objref.SizeByte - pp * 2 If .objref.SizeByte Mod 2 = 1 Then r$ = StrConv(String$(.objref.SizeByte - pp * 2, Chr(0)), vbFromUnicode) Else r$ = String$((.objref.SizeByte - pp * 2 + 1) \ 2, Chr(0)) End If CopyBytes CLng(p), StrPtr(r$), w2 End If End If mEval = FastSymbol(a$, ")") And .objref.status = 0 Exit Function Else MissPar mEval = False Exit Function End If Else ' elval$(alfa) 'copy entire block to r$ If .objref.SizeByte > 0 And .objref.status = 0 Then 'r$ = String$((.objref.SizeByte + 1) \ 2, Chr(0)) r$ = StrConv(String$(.objref.SizeByte, Chr(32)), vbFromUnicode) CopyBytes .objref.SizeByte, StrPtr(r$), .objref.GetPtr(0) Else r$ = vbNullString End If End If End If mEval = FastSymbol(a$, ")", True) Exit Function End With Set anything = Nothing ElseIf Typename(bstackstr.lastobj) = "VarItem" Then ' ??? mEval = FastSymbol(a$, ")", True) Exit Function ElseIf Not bstackstr.lastpointer Is Nothing Then getgroup: If TypeOf bstackstr.lastobj Is Group Then Set myGroup = bstackstr.lastpointer If Not myGroup.IamApointer Then Set myGroup = bstackstr.lastobj If Not myGroup.link Is Nothing Then Set myGroup = myGroup.link End If End If If myGroup.IamFloatGroup Then Set bstackstr.lastobj = Nothing Set bstackstr.lastpointer = Nothing Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set pppp.item(0) = myGroup entry100: If myGroup.HasParameters Then Mid$(a$, 1, 1) = "(" oldremove = myGroup.HasRemove myGroup.HasRemove = False If myGroup.HasStrValue Then mEval = SpeedGroup(bstackstr, pppp, "VAL$", "", a$, 0) = 1 myGroup.HasRemove = oldremove r$ = bstackstr.LastValue ElseIf myGroup.HasValue Then mEval = SpeedGroup(bstackstr, pppp, "VAL", "", a$, 0) = 1 myGroup.HasRemove = oldremove SwapVariant p, bstackstr.LastValue If MemInt(VarPtr(p)) = vbString Then SwapString2Variant r$, p Else r$ = fixthis(p) End If If Not myGroup.HasParameters Then mEval = FastSymbol(a$, ")", True) And mEval Exit Function Else mEval = False Exit Function End If If Not myGroup.HasParameters Then mEval = FastSymbol(a$, ")", True) And mEval Exit Function Else If lookOne(a$, ",") Then If myGroup.HasStrValue Then Mid$(a$, 1, 1) = Chr(1) If IsStr1(bstackstr, a$, r$) Then mEval = True Exit Function End If Else Mid$(a$, 1, 1) = Chr(0) If IsNumber(bstackstr, a$, r) Then mEval = True Exit Function End If End If Else If myGroup.HasStrValue Then If IsStr1(bstackstr, Chr$(0) + "$'", r$) Then mEval = FastSymbol(a$, ")", True) Set anything = Nothing Exit Function End If Else If IsNumber(bstackstr, Chr$(0) + "'", r) Then mEval = FastSymbol(a$, ")", True) End If Exit Function End If End If End If End If ElseIf TypeOf bstackstr.lastobj Is Group Then Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set myGroup = bstackstr.lastobj Set pppp.item(0) = bstackstr.lastobj Set bstackstr.lastobj = Nothing GoTo entry100 End If missParam a$ Else dd = 1 q$ = aheadstatus(a$, False, dd) q$ = Left$(a$, dd) If CheckGroupOrPointer(bstackstr, (q$), myGroup, Nothing, (0)) Then If myGroup Is Nothing Then ElseIf Not myGroup.IamApointer Then a$ = Mid$(a$, dd) Set pppp = New ppppLight pppp.PushDim 1 pppp.PushEnd pppp.arr = True Set pppp.item(0) = myGroup If myGroup.HasParameters Then If Left$(a$, 1) <> ")" Then Mid$(a$, 1, 1) = "(" Else mEval = SpeedGroup(bstackstr, pppp, "VAL$", "", "", 0) = 1 r$ = bstackstr.LastValue mEval = FastSymbol(a$, ")", True) Exit Function End If End If mEval = SpeedGroup(bstackstr, pppp, "VAL$", "", a$, 0) = 1 r$ = bstackstr.LastValue If Not myGroup.HasParameters Then mEval = FastSymbol(a$, ")", True) Exit Function Else a$ = Mid$(a$, dd + 1) GoTo getgroup End If Else If IsStrExp(bstackstr, a$, q$, False) Then g19383: If FastSymbol(a$, ".") Then If lookOne(a$, ")") Then a$ = q$ + a$ Else a$ = q$ + "." + a$ End If If Not IsStrExp(bstackstr, a$, r$, False) Then mEval = False: Exit Function End If ElseIf CheckGroupOrPointer(bstackstr, (q$), myGroup, Nothing, (0)) Then If myGroup.HasParameters Then Mid$(a$, 1, dd + 1) = " " s$ = BlockParam(a$) Mid$(a$, 1, Len(s$)) = space(Len(s$)) If Right$(q$, 1) <> "$" Then If IsStrExp(bstackstr, q$ + "$(" + s$ + ")", r$) Then mEval = FastSymbol(a$, ")", True) Exit Function End If Else If IsStrExp(bstackstr, q$ + "(" + s$ + ")", r$) Then mEval = FastSymbol(a$, ")", True) Exit Function End If End If Else If IsStrExp(bstackstr, q$ + "$'", r$) Then mEval = FastSymbol(a$, ")", True) End If Exit Function End If Else r$ = q$ mEval = FastSymbol(a$, ")", True) Exit Function End If Else r$ = vbNullString End If End If End If mEval = FastSymbol(a$, ")", True) End Function Public Function IsLabelDotSub(where$, a$, rrr$, r$, Lang As Long, Optional P1 As Integer = 0) As Long ' for left side...no & Dim rr&, one As Boolean, br As Integer, c$, firstdot$, gr As Boolean rrr$ = vbNullString r$ = vbNullString Dim i&, l As Long, p3 As Integer Dim P2 As Long, p4 As Long '', excludesp As Long l = Len(a$): If l = 0 Then IsLabelDotSub = 0: Lang = 1: Exit Function P2 = StrPtr(a$): l = l - 1 p4 = P2 + l * 2 For i = P2 To p4 Step 2 GetMem2 i, P1 Select Case P1 Case 13 If i < p4 Then GetMem2 i + 2, p3 If p3 = 10 Then IsLabelDotSub = 1234 If i + 6 > p4 Then a$ = vbNullString Else i = i + 4 Do While i < p4 GetMem2 i, P1 If P1 = 32 Or P1 = 160 Or P1 = 9 Then i = i + 2 Else GetMem2 i + 2, p3 If P1 <> 13 And p3 <> 10 Then Exit For i = i + 4 End If Loop a$ = Mid$(a$, (i + 2 - P2) \ 2) End If Else If i > P2 Then a$ = Mid$(a$, (i - 2 - P2) \ 2) End If Else If i > P2 Then a$ = Mid$(a$, (i - 2 - P2) \ 2) End If Lang = 1 Exit Function Case 0 To 7, 32, 160, 9 Case 8 IsLabelDotSub = 8: Exit Function Case Else Exit For End Select Next i If i > p4 Then a$ = vbNullString: IsLabelDotSub = 0: Exit Function For i = i To p4 Step 2 GetMem2 i, P1 If P1 < 256 Then Select Case P1 Case 0 To 6 ' no chars Case 7 If i + 2 <= p4 Then GetMem2 i + 2, P1 Select Case P1 Case 61, 40 If Len(r$) > 1 Then r$ = Left$(r$, Len(r$) - 1) End Select End If Case 64 '"@" If i < p4 And r$ <> "" Then GetMem2 i + 2, P1 If ChrW(P1) <> "(" Then where$ = myUcase(r$, gr) r$ = vbNullString rrr$ = vbNullString Else IsLabelDotSub = 0: a$ = firstdot$ + Mid$(a$, (i - P2) \ 2): Exit Function End If Else If LenB(r$) = 0 And i < p4 Then r$ = r$ + "@" Else IsLabelDotSub = 0: a$ = vbNullString: Exit Function End If End If Case 63 '"?" If r$ = vbNullString And firstdot$ = vbNullString Then rrr$ = "?" r$ = rrr$ i = i + 4 a$ = Mid$(a$, (i - P2) \ 2) IsLabelDotSub = 1 Lang = -1 Exit Function ElseIf firstdot$ = vbNullString Then IsLabelDotSub = 1 Lang = 1 + CLng(gr) If Lang = 1 Then rrr$ = UCase(r$) Else rrr$ = myUcase(r$) End If a$ = Mid$(a$, (i + 2 - P2) \ 2) Exit Function Else IsLabelDotSub = 0 a$ = Mid$(a$, (i + 2 - P2) \ 2) Exit Function End If Case 46 '"." If one Then Exit For ElseIf r$ <> "" And i < p4 Then GetMem2 i + 2, P1 If ChrW(P1) = "." Or ChrW(P1) = " " Then If ChrW(P1) = "." And i + 2 < p4 Then GetMem2 i + 4, P1 If ChrW(P1) = " " Then i = i + 4: Exit For Else i = i + 2 Exit For End If End If GetMem2 i, P1 r$ = r$ & ChrW(P1) rr& = 1 Else firstdot$ = firstdot$ + "." End If Case 92, 94, 123 To 126, 160 '"\","^", "{" To "~" Exit For Case 48 To 57, 95 '"0" To "9", "_" If one Then Exit For ElseIf r$ <> "" Then r$ = r$ + ChrW(P1) rr& = 1 'is an identifier or floating point variable Else Exit For End If Case 91 If Len(r$) > 0 Then If Len(r$) = 1 Then If r$ <> "[" Then rr& = 10 Exit For End If ElseIf Right$(r$, 1) <> "." Then If Right$(r$, 1) <> ChrW(&HFFBF) Then If Left$(r$, 1) <> "[" Then rr& = 10 ' for EXECUTE only Exit For End If End If End If br = br + 1 r$ = r$ + "[" Else r$ = "[" br = 1 rr& = 1 'is an identifier End If Case 93 If Len(r$) = 0 Then Exit For If br > 0 Then br = br - 1 r$ = r$ + "]" Else Exit For End If Case Is < 0, Is > 64 ' >=A and negative If one Then Exit For Else r$ = r$ + ChrW(P1) rr& = 1 'is an identifier or floating point variable End If Case 36 ' "$" If one Then Exit For If r$ <> "" Then one = True rr& = 3 ' is string variable r$ = r$ & ChrW(P1) Else Exit For End If Case 37 ' "%" If one Then Exit For If r$ <> "" Then one = True rr& = 4 ' is long variable r$ = r$ & ChrW(P1) Else Exit For End If Case 40 '"(" If r$ <> "" Then If i + 4 <= p4 Then GetMem2 i + 2, P1 GetMem2 i + 2, p3 If ChrW(P1) + ChrW(p3) = ")@" Then r$ = r$ & "()." i = i + 4 Else GoTo i123 End If Else i123: Select Case rr& Case 1 rr& = 5 ' float array or function Case 3 rr& = 6 'string array or function Case 4 rr& = 7 ' long array Case Else Exit For End Select GetMem2 i, P1 r$ = r$ & ChrW(P1) i = i + 2 Exit For End If Else Exit For End If Case Else Exit For End Select Else If one Then Exit For Else gr = True r$ = r$ + ChrW(P1) rr& = 1 'is an identifier or floating point variable End If End If Next i If i > p4 Then a$ = vbNullString: P1 = 0 Else If (i + 2 - P2) \ 2 > 1 Then a$ = Mid$(a$, (i + 2 - P2) \ 2) End If rrr$ = firstdot$ + myUcase(r$, gr) Lang = 1 + CLng(gr) IsLabelDotSub = rr& End Function Private Sub Assign(ss$, p) Select Case MemInt(VarPtr(p)) Case vbString SwapString2Variant ss$, p Case vbBoolean If ShowBooleanAsString Then ss$ = format$(p, DefBooleanString) Else ss$ = CStr(p * 1) End If Case 20 ss$ = CStr(p) Case vbDate ss$ = p Case 36 If TypeOf p Is Complex Then ss$ = fixthis(p) Else ss$ = "*" + Typename(p) End If Case 9, 13 ss$ = "*" + Typename(p) Case Else ss$ = fixthis(p) End Select End Sub Private Function fixthis(p As Variant) As String '!!! If TypeOf p Is Complex Then If p.i = 0 Then fixthis = fixthis(CVar(p.r)) ElseIf p.r = 0 Then If Abs(p.i) = 1 Then If p.i < 0 Then fixthis = "(-i)" Else fixthis = "(+i)" End If Else fixthis = "(" & fixthis(CVar(p.i)) & "i)" End If Else If p.i < 0 Then fixthis = "" Else fixthis = "+" If Abs(p.i) = 1 Then If p.i < 0 Then fixthis = "(" & fixthis(CVar(p.r)) & "-i)" Else fixthis = "(" & fixthis(CVar(p.r)) & "+i)" End If Else fixthis = "(" & fixthis(CVar(p.r)) & fixthis & fixthis(CVar(p.i)) & "i)" End If End If Else Select Case MemInt(VarPtr(p)) Case vbDate If p <= 1 Then fixthis = FormatTimeWithLocale("HH:mm:ss", CDate(p), Clid) Else fixthis = FormatDateWithLocale(GetlocaleString2(&H1F, Clid), CDate(p), Clid) End If Case vbBoolean If ShowBooleanAsString Then fixthis = format$(p, ";\T\r\u\e;\F\a\l\s\e") Else fixthis = CStr(p * 1) End If Case vbEmpty fixthis = vbNullString Case vbString fixthis = p Case 20 fixthis = CStr(p) Case Else fixthis = LTrim$(str(p)) If Left$(fixthis, 1) = "." Then fixthis = "0" + fixthis ElseIf Left$(fixthis, 2) = "-." Then fixthis = "-0" + Mid$(fixthis, 2) End If If InStr(fixthis, ".") > 0 Then If NoUseDec Then fixthis = Replace(fixthis, ".", NowDec$) End If End Select End If End Function Function AddGroupFromClass(bstack As basetask, rest$, className$, isglobal As Boolean, islocal As Boolean, ohere$) As Boolean Dim i As Long, W$, v As Long, useType As Boolean, r, part$, ret As Boolean, exist As Boolean, ww$, ss$ Dim isStruct As Boolean, useBuffer As MemBlock, usehandler As mHandler, usehandlerBuffer As mHandler, j As Long Dim structLen As Long If GetVar3(bstack, bstack.GroupName + className$, v) Then If IsExp(bstack, bstack.GroupName + className$, r) Then If Not bstack.lastobj Is Nothing Then GoTo Checkit End If End If ElseIf GetVar3(bstack, bstack.GroupName + className$, v) Then If IsExp(bstack, (className$), r) Then If Not bstack.lastobj Is Nothing Then Checkit: If TypeOf bstack.lastobj Is mHandler Then Set usehandler = bstack.lastobj Set bstack.lastobj = Nothing If usehandler.t1 = 5 Then If TypeOf usehandler.objref Is StructCollection Then If Not usehandler.objref.structLen = 0 Then isStruct = True Else MyEr "Zero Length Structure", "Μηδενικού Μήκους Δομή" Exit Function End If End If End If End If End If End If Else 'Exit Function End If Do exist = False useType = False 'I = IsLabelA(here$, rest$, W$) j = -1 i = IsLabelAnew("", rest$, W$, j) If (i <> 8 Or isStruct) And j > 0 Then rest$ = Mid$(rest$, j) If Len(rest$) = 0 Then If i = 0 Then SyntaxError: Exit Function End If AddGroupFromClass = True If isStruct Then If i = 1 Or i = 8 Then If i = 8 Then Mid$(rest$, 1, 1) = " " If Not IsExp(bstack, rest$, r) Then End If If Not Left$(rest$, 1) = "]" Then End If Mid$(rest$, 1, 1) = " " Else r = 1 End If If r < 1& Then r = 1& If isglobal Or islocal Then GoTo CONTGLO ElseIf GetVar(bstack, bstack.GroupName + W$, i, , , True, ww$, useType) Then If Typename(var(i)) = "mHandler" Then Set usehandlerBuffer = var(i) If usehandlerBuffer.t1 = 2 And Not usehandlerBuffer.ReadOnly Then Set useBuffer = usehandlerBuffer.objref If useBuffer.structref Is Nothing Then ElseIf useBuffer.structref Is usehandler.objref Then v = useBuffer.items If v <> r Then ret = useBuffer.items < r useBuffer.ResizeItems CLng(r) ' fill zero If ret Then Dim k() As Byte ReDim k(useBuffer.ItemSize) As Byte For i = v To CLng(r) - 1& j = useBuffer.GetPtr(v) If j > 0 Then CopyMemory ByVal j, ByVal VarPtr(k(0)), useBuffer.ItemSize End If Next i End If End If GoTo cont111 ElseIf useBuffer.structref.Tag = usehandler.objref.Tag Then GoTo cont111 End If End If End If WrongType Exit Function Else CONTGLO: i = globalvar(bstack.GroupName + W$, Empty, , isglobal, , True) MakeitObjectBuffer var(i) Set usehandlerBuffer = var(i) Set useBuffer = usehandlerBuffer.objref v = usehandler.objref.structLen Set useBuffer.structref = usehandler.objref useBuffer.UseStruct = True Set usehandlerBuffer = Nothing useBuffer.ClearError useBuffer.Construct v, CLng(r), CLng(8) Set useBuffer = Nothing End If cont111: GoTo loophere Else SyntaxError Exit Function End If ElseIf i = 1 Then part$ = className$ + "()" ElseIf i = 3 Then part$ = className$ + "$()" W$ = Left$(W$, Len(W$) - 1) ElseIf i = 5 Then W$ = Left$(W$, Len(W$) - 1) part$ = className$ + "(" ElseIf i = 6 Then W$ = Left$(W$, Len(W$) - 2) part$ = className$ + "$(" ElseIf i = 8 Then part$ = className$ + "()" Else SyntaxError AddGroupFromClass = False Exit Function End If If isglobal Or islocal Then GoTo CONTGLO1 ElseIf GetVar(bstack, bstack.GroupName + W$, v, True, , , ww$, useType) Then If i = 8 Then GoTo A112233 ElseIf Typename(var(v)) <> "Group" Then WrongType AddGroupFromClass = False Exit Function End If If useType Then Dim mm As Group Set mm = var(v) If Not mm.TypeGroup(className$) Then WrongType AddGroupFromClass = False Exit Function End If End If exist = True Else CONTGLO1: If i = 1 Then v = globalvar(bstack.GroupName + W$, 0, , here$ = "", , True) ElseIf i = 8 Then A112233: If IsExp(bstack, part$, r) Then Set r = bstack.lastobj Set bstack.lastobj = Nothing If Not MyAnyType(bstack, rest$, (0&), islocal, 9, Not (islocal Or isglobal), r) Then WrongType Exit Function End If GoTo loophere End If Else v = globalvar(bstack.GroupName + W$, 0, , here$ = "", , True) 'ret = globalvar(bstack.GroupName + W$, (v), True, here$ = "", , True) End If End If If i = 1 Then If lookOne(rest$, "=") Then ret = IsExp(bstack, part$, r) Else bstack.tmpstr = part$ + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) ret = IsExp(bstack, rest$, r) End If ElseIf i = 3 Then If lookOne(rest$, "=") Then ret = IsStrExp(bstack, (part$), ss$) If Not ret Then ret = IsExp(bstack, className$ + "()", r) End If Else bstack.tmpstr = part$ + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) ret = IsStrExp(bstack, rest$, ss$) If ret = False Then bstack.tmpstr = className$ + "()" + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) ret = IsExp(bstack, rest$, r) End If End If ElseIf i = 5 Then bstack.tmpstr = part$ + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) ret = IsExp(bstack, rest$, r) ElseIf i = 6 Then bstack.tmpstr = part$ + Left$(rest$, 1) 'BackPort rest$ If Len(rest$) = 0 Then rest$ = Chr(8) Else Mid$(rest$, 1, 1) = Chr(8) ret = IsStrExp(bstack, rest$, ss$) Else WrongType Exit Function End If If isglobal Or islocal Then exist = False If ret Then If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is Group Then Set mm = bstack.lastobj Set bstack.lastobj = Nothing If useType Then If Not mm.TypeGroup(className$) Then WrongType AddGroupFromClass = False Exit Function End If End If If exist Then ss$ = bstack.GroupName If ww$ <> "" Then W$ = ww$ If Len(var(v).GroupName) > Len(W$) Then Dim sw$ sw$ = here$ here$ = vbNullString UnFloatGroupReWriteVars bstack, var(v).Patch, v, mm here = sw$ mm.ToDelete = True Else bstack.GroupName = Left$(W$, Len(W$) - Len(var(v).GroupName) + 1) If Len(var(v).GroupName) > 0 Then W$ = Left$(var(v).GroupName, Len(var(v).GroupName) - 1) sw$ = here$ here$ = vbNullString UnFloatGroupReWriteVars bstack, W$, v, mm here = sw$ mm.ToDelete = True ElseIf var(v).IamApointer Then WrongType Exit Function Else Set mm = Nothing bstack.GroupName = ss$ If var(v).IamApointer Then UseArrow Else GroupWrongUse End If Exit Function End If End If bstack.GroupName = ss$ Set mm = Nothing Else mm.ToDelete = True UnFloatGroup bstack, W$, v, mm, here$ = "" Or isglobal, myVarType(var(v), vbEmpty), islocal ' global?? If Len(bstack.UseGroupname) <> 0 Then var(v).IamRef = True If here$ <> "" Then globalvar W$, CVar(v), True, True End If End If Set mm = Nothing If lookOne(rest$, "=") Then If i = 3 Then ExecuteVar3 i, bstack, W$ + "$", rest$, v, 1, isglobal, islocal, 0, "", 0, ohere$, True ElseIf i = 1 Then ExecuteVar1 i, bstack, W$, rest$, v, 1, isglobal, islocal, 0, "", 0, ohere$, True ElseIf i = 4 Then ExecuteVar4 i, bstack, W$, rest$, v, 1, isglobal, islocal, 0, "", 0, ohere$, True ElseIf i = 5 Then ExecuteVar5 i, bstack, W$, rest$, v, 1, isglobal, islocal, 0, "", 0, ohere$, True ElseIf i = 6 Then ExecuteVar6 i, bstack, W$, rest$, v, 1, isglobal, islocal, 0, "", 0, ohere$, True Else ExecuteVar i, (i), bstack, W$, rest$, v, 1, isglobal, islocal, 0, "", 0, ohere$, True End If End If End If Set bstack.lastobj = Nothing End If Else WrongType End If loophere: Loop Until Not FastSymbol(rest$, ",") className$ = "" End Function Function chektype1(bstack As basetask, b$, Lang As Long) As Integer chektype1 = 1 If IsLabelSymbolNew(b$, "ΔΙΠΛΟΣ", "DOUBLE", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbDouble, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΚΕΡΑΙΟΣ", "INTEGER", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbInteger, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbLong, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΠΛΟΣ", "SINGLE", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbSingle, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΚΟΣ", "BOOLEAN", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbBoolean, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΡΙΘΜΟΣ", "DECIMAL", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbDecimal, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbCurrency, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΓΡΑΜΜΑ", "STRING", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbString, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΤΥΠΟΣ", "VARIANT", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbVariant, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΟΜΑΔΑ", "GROUP", Lang) Then If Not ProcGroup(-1, bstack, b$, Lang) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΨΗΦΙΟ", "BYTE", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbByte, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΗΜΕΡΟΜΗΝΙΑ", "DATE", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbDate, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΑΝΤΙΚΕΙΜΕΝΟ", "OBJECT", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbObject, True) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΜΕΓΑΛΟΣΑΚΕΡΑΙΟΣ", "BIGINTEGER", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", vbObject, True, New BigInteger) Then Exit Function ElseIf IsLabelSymbolNew(b$, "ΜΙΓΑΔΙΚΟΣ", "COMPLEX", Lang) Then If Not MyAnyType(bstack, b$, Lang, here$ = "", 200, True) Then Exit Function Else chektype1 = 2 End If End Function Function TakeOffset(bstack As basetask, usehandler As mHandler, b$, r, Optional where, Optional NewVal) As Boolean ' just throw offsets Dim thisHandler As mHandler, useBuffer As MemBlock, otherBuffer As MemBlock, mylist As StructCollection, pp As Long, p As Variant Dim rB As Byte, ri As Integer, dn As Long, db As Double, ds As Single, w2 As Long, s$ Dim itisSingle As Boolean, itisInt64 As Boolean, itisCur As Boolean, itisString As Boolean Dim i As Long Dim LastBracket As Boolean If usehandler.t1 <> 2 Then WrongType Exit Function End If Set useBuffer = usehandler.objref If Not useBuffer.UseStruct Then If Left$(b$, 1) = "|" Then MyEr "this buffer has no struct attached", "αυτή η διάρθρωση δεν έχει δομή ενσωματωμένη" End If pp = useBuffer.ItemSize If pp = 4 Then itisSingle = useBuffer.WhatIsBasicItem = vbSingle ElseIf pp = -4 Then pp = 4 itisString = True ElseIf pp = 8 Then itisInt64 = useBuffer.WhatIsBasicItem = 20 itisCur = useBuffer.WhatIsBasicItem = vbCurrency End If p = (-OneLongLong And useBuffer.GetPtr(where)) w2 = MemLong(VarPtr(p) + 8) If Not IsMissing(NewVal) Then SwapVariant r, p r = 0 If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set thisHandler = bstack.lastobj If thisHandler.t1 = 2 Then Set otherBuffer = thisHandler.objref If useBuffer.ValidArea(w2, otherBuffer.SizeByte) Then CopyBytes otherBuffer.SizeByte, w2, otherBuffer.GetPtr(0) TakeOffset = True Exit Function Else MyEr "this buffer not fit", "δεν χωράει στη διάρθρωση" Exit Function End If End If End If Else If MemInt(VarPtr(p)) = vbString Then SwapVariant r, p p = 0 End If End If End If GoTo contthere End If Set mylist = useBuffer.structref Dim W$, back$ If Left$(b$, 1) = "|" Or IsMissing(NewVal) Then Mid$(b$, 1, 1) = " " jumpagain: i = IsLabelAnew("", b$, W$, (0&)) If i = 1 Or i = 8 Then If mylist.Find(W$) Then pp = Abs(mylist.sValue) If pp = 4 Then itisSingle = mylist.KeyTypeValue = vbSingle itisString = mylist.sValue < 0 ElseIf pp = 8 Then itisInt64 = mylist.sValue < 0 itisCur = mylist.KeyTypeValue = vbCurrency End If If w2 = 0 Then With useBuffer If Not IsMissing(where) Then p = (-OneLongLong And .GetPtr(where)) + mylist.StructOffset Else p = (-OneLongLong And .GetPtr(0&)) + mylist.StructOffset End If End With w2 = MemLong(VarPtr(p) + 8) ElseIf mylist.StructOffset > 0 Then ' mylist.StructOffset > 0 w2 = (-OneLongLong And w2) + mylist.StructOffset End If pp = Abs(pp) If i = 8 Then Mid$(b$, 1, 1) = " " If Not IsExp(bstack, b$, p, , True) Then If Left$(b$, 1) = "]" Then Mid$(b$, 1, 1) = " " Set otherBuffer = New MemBlock If Not mylist.StructObj Is Nothing Then otherBuffer.Construct pp, mylist.StructMany, , , CLng(r) Else If itisInt64 Then r = 20 ElseIf itisCur Then r = vbCurrency ElseIf itisSingle Then r = vbSingle Else End If otherBuffer.Construct pp, mylist.StructMany, , , CLng(r) End If CopyMemory ByVal otherBuffer.GetPtr(0), ByVal w2, pp * mylist.StructMany If useBuffer.ItemsHaveStrings Then useBuffer.copyStringsPartial otherBuffer, otherBuffer.GetPtr(0), w2, pp * mylist.StructMany End If If Not mylist.StructObj Is Nothing Then Set otherBuffer.structref = mylist.StructObj otherBuffer.UseStruct = True Else otherBuffer.UseStruct = False End If r = 0 Set thisHandler = New mHandler thisHandler.t1 = 2 Set thisHandler.objref = otherBuffer Set bstack.lastobj = thisHandler TakeOffset = True End If Exit Function Else LastBracket = True End If p = CLng(p) If mylist.StructMany <= p Or p < 0 Then MyEr "index out of limit for items of " + mylist.KeyToString, "ο δείκτης είναι εκτός ορίων για το " + mylist.KeyToString TakeOffset = False Exit Function End If p = w2 + (-OneLongLong And p) * pp w2 = MemLong(VarPtr(p) + 8) p = 0 If FastSymbol(b$, ",") Then LastBracket = False If Not IsExp(bstack, b$, p, , True) Then Exit Function pp = Abs(p) If pp < 1 Then r = "" If Not useBuffer.ValidArea(w2, 0&) Then MyEr "wrong offset and width for string", "λάθος το επιπλέον και το μήκος για αλφαριθμητικό" Else TakeOffset = True End If Exit Function End If If pp Mod 2 = 1 Then s$ = StrConv(String(pp, Chr(0)), vbFromUnicode) Else s$ = String$((pp + 1) \ 2, Chr(0)) End If CopyBytes pp, StrPtr(s$), w2 r = "" SwapString2Variant s$, r TakeOffset = FastSymbol(b$, "]") Exit Function ElseIf Not lookOne(b$, "]") Then i = IsLabelAnew("", b$, W$, (0&)) If i = 1 Then dn = Abs(Asc(W$) < 128) If dn = 1 Then i = W$ = "AS" Else i = W$ = "ΩΣ" End If b$ = LTrim$(b$) If i Then If IsLabelSymbolNew(b$, "ΨΗΦΙΟ", "BYTE", dn) Then pp = 1 ElseIf IsLabelSymbolNew(b$, "ΑΚΕΡΑΙΟΣ", "INTEGER", dn) Then pp = 2 ElseIf IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", dn) Then If IsLabelSymbolNew(b$, "ΜΑΚΡΥΣ", "LONG", dn) Then pp = 8 itisInt64 = True Else pp = 4 End If ElseIf IsLabelSymbolNew(b$, "ΔΙΠΛΟΣ", "DOUBLE", dn) Then pp = 8 ElseIf IsLabelSymbolNew(b$, "ΛΟΓΙΣΤΙΚΟΣ", "CURRENCY", dn) Then pp = 8 itisCur = True ElseIf IsLabelSymbolNew(b$, "ΑΠΛΟΣ", "SINGLE", dn) Then pp = 4 itisSingle = True Else SyntaxError Exit Function End If Else SyntaxError Exit Function End If ElseIf i > 0 Then SyntaxError Exit Function End If End If If Not FastSymbol(b$, "]") Then Exit Function End If If Not IsMissing(NewVal) Then If IsMissing(where) Then SwapVariant p, r GoTo JUMPHERE ElseIf lookOne(b$, "=") Then FastSymbol b$, "=" If IsExp(bstack, b$, p) Then JUMPHERE: If MemInt(VarPtr(p)) = vbString Then SwapVariant p, r p = 0 Set bstack.lastobj = Nothing GoTo contthere End If looklastobj: If Not bstack.lastobj Is Nothing Then If TypeOf bstack.lastobj Is mHandler Then Set thisHandler = bstack.lastobj Set bstack.lastobj = Nothing If thisHandler.t1 = 2 Then Set otherBuffer = thisHandler.objref pp = otherBuffer.SizeByte If useBuffer.ValidArea(w2, pp) Then If useBuffer.ItemsHaveStrings Then useBuffer.ClearStringPartial w2, pp End If CopyMemory ByVal w2, ByVal otherBuffer.GetPtr(0), pp If otherBuffer.ItemsHaveStrings Then otherBuffer.copyStringsPartial useBuffer, w2, otherBuffer.GetPtr(0), pp End If TakeOffset = True Exit Function End If End If MyEr "invalid use of buffer", "κακή χρήση διάρθρωσης" Exit Function Else Set bstack.lastobj = Nothing WrongType Exit Function End If End If Else If IsStrExp(bstack, b$, s$, False) Then r = "" SwapString2Variant s$, r GoTo contthere End If Exit Function End If End If End If If FastSymbol(b$, "|") Then LastBracket = False If Not mylist.StructObj Is Nothing Then Set mylist = mylist.StructObj GoTo jumpagain End If SyntaxError Exit Function Else If LastBracket Then If IsMissing(NewVal) Then Set otherBuffer = New MemBlock If Not mylist.StructObj Is Nothing Then Set mylist = mylist.StructObj otherBuffer.Construct mylist.structLen, mylist.StructMany, , , CLng(0) Set otherBuffer.structref = mylist otherBuffer.UseStruct = True CopyMemory ByVal otherBuffer.GetPtr(0), ByVal w2, mylist.structLen If useBuffer.ItemsHaveStrings Then useBuffer.copyStringsPartial otherBuffer, otherBuffer.GetPtr(0), w2, mylist.structLen End If r = 0 Set thisHandler = New mHandler thisHandler.t1 = 2 Set thisHandler.objref = otherBuffer Set bstack.lastobj = thisHandler TakeOffset = True Exit Function End If End If End If End If contthere: With useBuffer If MemInt(VarPtr(r)) = vbString And Not IsMissing(NewVal) Then SwapString2Variant s$, r If itisString Then GoTo contItIsString ElseIf .ValidArea(w2, CVar(LenB(s$))) Then CopyMemory ByVal w2, ByVal StrPtr(s$), LenB(s$) TakeOffset = True Else MyEr "string can't fit to buffer", "δεν χωράει το αλφαριθμητικό στη διάρθρωση" End If ElseIf .ValidArea(w2, pp) Then Select Case pp Case 1 If Not IsMissing(NewVal) Then PutMem1 w2, CByte(LowWord(signlong(p)) And &HFF) Else GetMem1 w2, rB r = CCur(rB) End If TakeOffset = True Case 2 If Not IsMissing(NewVal) Then PutMem2 w2, cUint(LowWord(signlong(p))) Else GetMem2 w2, ri r = CCur(UINT(CLng(ri))) End If TakeOffset = True Case 4 If Not IsMissing(NewVal) Then If itisSingle Then ds = CSng(p) PutMemS w2, ds ElseIf itisString Then s$ = fixthis(p) contItIsString: dn = useBuffer.PutStringAtOffset(w2, s$) PutMem4 w2, dn Else PutMem4 w2, signlong(p) End If Else If itisSingle Then GetMemS w2, ds r = ds Else GetMem4 w2, dn If itisString Then useBuffer.GetStringFromOffset w2, s$ r = vbNullString SwapString2Variant s$, r Else r = CCur(uintnew1(dn)) End If End If End If TakeOffset = True Case 8 If Not IsMissing(NewVal) Then If itisCur Then MemCur(w2) = CCur(p) ElseIf itisInt64 Or pp < 0 Then p = cInt64(p) CopyMemory ByVal w2, ByVal VarPtr(p) + 8, 8 Else PutMem8 w2, p End If TakeOffset = True Else If itisCur Then r = MemCur(w2) TakeOffset = True ElseIf itisInt64 Then r = cInt64(0) CopyMemory ByVal VarPtr(r) + 8, ByVal w2, 8 r = CDec(r) If r < 0 Then r = r + maxlonglong TakeOffset = True Else GetMem8 w2, db r = db TakeOffset = True End If End If Case Else If pp Mod 2 = 1 Then s$ = StrConv(String(pp, Chr(0)), vbFromUnicode) Else s$ = String$((pp + 1) \ 2, Chr(0)) End If CopyBytes pp, StrPtr(s$), w2 r = "" SwapString2Variant s$, r TakeOffset = True ' ???? End Select End If End With End If Else Exit Function End If Else If Not IsMissing(NewVal) Then If Not IsMissing(where) Then p = (-OneLongLong And useBuffer.GetPtr(where)) Else p = (-OneLongLong And useBuffer.GetPtr(0&)) End If w2 = MemLong(VarPtr(p) + 8) GoTo looklastobj End If End If End Function Private Function IsProp(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsProp = TypeOf v Is PropReference End If End If End Function Private Function IsGroup(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsGroup = TypeOf v Is Group End If End If End Function Private Function IsRefArray(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsRefArray = TypeOf v Is refArray End If End If End Function Private Function IsObjGroup(v) As Boolean If Not v Is Nothing Then IsObjGroup = TypeOf v Is Group End If End Function Private Function IsConstant(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsConstant = TypeOf v Is Constant End If End If End Function Private Function IsLambda(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsLambda = TypeOf v Is lambda End If End If End Function Private Function IsObjLambda(v) As Boolean If Not v Is Nothing Then IsObjLambda = TypeOf v Is lambda End If End Function Private Function IsArrayProp(pppp As iBoxArray, v) As Boolean Dim that If pppp.IsObjAt(CLng(v), that) Then IsArrayProp = TypeOf that Is PropReference End If End Function Private Function IsArrayGroup(pppp As iBoxArray, v) As Boolean Dim that If pppp.IsObjAt(CLng(v), that) Then IsArrayGroup = TypeOf that Is Group End If End Function Private Function IsArrayArray(pppp As iBoxArray, v) As Boolean Dim that If pppp.IsObjAt(CLng(v), that) Then IsArrayArray = TypeOf that Is iBoxArray End If End Function Private Function IsobjAndArray(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsobjAndArray = TypeOf v Is iBoxArray End If End If End Function Private Function IsobjArray(v) As Boolean If Not v Is Nothing Then IsobjArray = TypeOf v Is iBoxArray End If End Function Private Function IsobjmArray(v) As Boolean If Not v Is Nothing Then IsobjmArray = TypeOf v Is mArray End If End Function Private Function IsobjTuple(v) As Boolean If Not v Is Nothing Then IsobjTuple = TypeOf v Is tuple End If End Function Private Function IsObjProp(v) As Boolean If Not v Is Nothing Then IsObjProp = TypeOf v Is PropReference End If End Function Private Function IsmHandler(v) As Boolean If MemInt(VarPtr(v)) = vbObject Then If Not v Is Nothing Then IsmHandler = TypeOf v Is mHandler End If End If End Function Private Function IsObjmStiva(v As Object) As Boolean If Not v Is Nothing Then IsObjmStiva = TypeOf v Is mStiva End If End Function Private Function IsObjmHandler(v As Object) As Boolean If Not v Is Nothing Then IsObjmHandler = TypeOf v Is mHandler End If End Function Private Function GetPPPP(tstArray As iBoxArray, pppp As mArray) As Boolean Dim usehandler As mHandler, myTuple As tuple If Not tstArray Is Nothing Then If Not tstArray.arr Then Exit Function If TypeOf tstArray Is mArray Then Set pppp = tstArray Else If varhash.lastNDX > 0 Then If IsmHandler(var(varhash.lastNDX)) Then Set usehandler = var(varhash.lastNDX) If usehandler.t1 = 3 Then Set myTuple = tstArray Set pppp = New mArray myTuple.CopyTuple2Array pppp Set usehandler.objref = pppp GoTo contArrayOnly1 End If End If End If conflictname Exit Function End If contArrayOnly1: GetPPPP = True End If End Function Function strComplex(ByRef p As Variant, Optional q$ = ".", Optional UseSep As Boolean = False) As String Dim q2$ strComplex = LTrim$(str(p.i)) If Left$(strComplex, 1) = "." Then If AscW(q$) = 46 Then strComplex = "0" + strComplex Else strComplex = "0" + Replace(strComplex, ".", q$) End If ElseIf Left$(strComplex, 2) = "-." Then If AscW(q$) = 46 Then strComplex = "-0" + Mid$(strComplex, 2) Else strComplex = "-0" + Replace(Mid$(strComplex, 2), ".", q$) End If ElseIf AscW(q$) <> 46 Then If InStr(strComplex, ".") > 1 Then strComplex = Replace(strComplex, ".", q$) End If End If q2$ = strComplex strComplex = LTrim$(str(p.r)) If Left$(strComplex, 1) = "." Then If AscW(q$) = 46 Then strComplex = "0" + strComplex Else strComplex = "0" + Replace(strComplex, ".", q$) End If ElseIf Left$(strComplex, 2) = "-." Then If AscW(q$) = 46 Then strComplex = "-0" + Mid$(strComplex, 2) Else strComplex = "-0" + Replace(Mid$(strComplex, 2), ".", q$) End If ElseIf AscW(q$) <> 46 Then If InStr(strComplex, ".") > 1 Then strComplex = Replace(strComplex, ".", q$) End If End If If UseSep Then strComplex = "(" + strComplex + "," + q2$ + "i)" Else If Left$(q2$, 1) <> "-" Then strComplex = "(" + strComplex + "+" + q2$ + "i)" Else strComplex = "(" + strComplex + q2$ + "i)" End If End If End Function Function JoyPadRead(r, a$) As Boolean r = Int(r) If r < 0 Or r > 15 Then WrongJoypadNumber a$ Exit Function End If If Not MYJOYSTAT(r).enabled Then joypader a$, r Exit Function End If If Not MYJOYSTAT(r).Wait2Read Then PollJoypadOne r If Not MYJOYSTAT(r).Wait2Read Then joypader a$, r Exit Function End If End If JoyPadRead = True End Function Function DropSelect2(b$, Lang As Long, Optional ByVal Pos As Long = 1) As Long Dim ss$, last As Boolean Dim OLDPOS As Long Dim sPos As Long Const RemChar = "'\/" Static RemWhitSpace As String If Len(RemWhitSpace) = 0 Then RemWhitSpace = " 0123456789" + vbCr + vbLf + ":" + vbTab + Chr$(160) sPos = Pos Do While Len(b$) > Pos ss$ = Mid$(b$, Pos, 1) If InStr(RemWhitSpace, ss$) > 0 Then Pos = Pos + 1 ElseIf InStr(RemChar, ss$) > 0 Then Pos = Pos + 1 Do While Len(b$) > Pos If Mid$(b$, Pos, 1) = vbCr Then Exit Do Pos = Pos + 1 Loop Else Exit Do End If Loop aheadstatusSkipParam b$, Pos If Pos > sPos Then If Mid$(b$, Pos, 2) = vbCrLf Then Pos = Pos + 2 Else Pos = Pos + 1 End If End If While Pos < Len(b$) jump0: Pos = MyTrimLi(b$, Pos) jump1: Do While Len(b$) > Pos ss$ = Mid$(b$, Pos, 1) If InStr(RemWhitSpace, ss$) > 0 Then Pos = Pos + 1 ElseIf InStr(RemChar, ss$) > 0 Then Pos = Pos + 1 Do While Len(b$) > Pos If Mid$(b$, Pos, 1) = vbCr Then Exit Do Pos = Pos + 1 Loop ElseIf ss$ = "{" Then If Pos > 1 Then b$ = Mid$(b$, Pos + 1) ss$ = block(b$) If Not FastSymbol(b$, "}", True) Then Exit Function End If Pos = 1 Else Exit Do End If Loop OLDPOS = Pos If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then Select Case ss$ Case "ΜΕ" If Lang = 0 Then If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then If ss$ = "ΑΛΛΙΩΣ" Then If last Then MyEr "Bad use of case else", "Κακή χρήση του Με Αλλιώς" Else last = True GoTo jump2 End If Else Pos = Pos - Len(ss$) GoTo jump2 End If End If Else MyEr "Bad use of Με (greel statement)", "Κακή χρήση του Με" Exit Function End If Case "CASE" If Lang = 1 Then ' CASE ELSE If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then If ss$ = "ELSE" Then If last Then MyEr "Bad use of CASE ELSE", "Κακή χρήση του CASE ELSE" Else last = True GoTo jump2 End If Else Pos = Pos - Len(ss$) GoTo jump2 End If End If Else MyEr "Bad use of CASE", "Κακή χρήση του CASE" Exit Function End If Case "ELSE" ' else case If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then If ss$ = "CASE" Then If last Then MyEr "Bad use of ELSE CASE", "Κακή χρήση του ELSE CASE" Else Pos = Pos - 4 last = True GoTo jump0 End If Else Pos = Pos - Len(ss$) GoTo jump2 End If End If Case "ΑΛΛΙΩΣ" ' else case If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then If ss$ = "ΜΕ" Then If last Then MyEr "Bad use of Αλλιώς Με", "Κακή χρήση του Αλλιώς Με" Else Pos = Pos - 2 last = True GoTo jump0 End If Else Pos = Pos - Len(ss$) GoTo jump2 End If End If Case "ΤΕΛΟΣ" If Lang = 0 Then 'Pos = Pos + 5 Pos = MyTrimLi(b$, Pos) If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then If ss$ = "ΕΠΙΛΟΓΗΣ" Then Pos = Pos - 1 Do Pos = Pos + 1 aheadstatusSkipParam b$, Pos Loop While Mid$(b$, Pos) = ":" GoTo finale End If End If End If Case "END" If Lang = 1 Then 'Pos = OLDPOS + 3 Pos = MyTrimLi(b$, Pos) If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then If ss$ = "SELECT" Then Pos = Pos - 1 Do Pos = Pos + 1 aheadstatusSkipParam b$, Pos Loop While Mid$(b$, Pos) = ":" ' If Pos > 1 Then b$ = Mid$(b$, Pos) GoTo finale End If End If End If Case "ΕΠΙΛΕΞΕ", "ΕΠΕΛΕΞΕ" Pos = Module1.DropSelect2(b$, 0, Pos - 7) If Pos = 0 Then Exit Function GoTo jump0 Case "SELECT" Pos = Module1.DropSelect2(b$, 1, Pos) If Pos = 0 Then Exit Function GoTo jump0 Case Else jump2: Pos = OLDPOS - 1 Do Pos = Pos + 1 aheadstatusSkipParam b$, Pos Loop While Mid$(b$, Pos) = ":" GoTo jump1 End Select GoTo jump2 Else If Pos > Len(b$) Then MyEr "problem in select", "πρόβλημα στην ΕΠΙΛΕΞΕ" Exit Function End If GoTo jump2 End If OLDPOS = Pos Wend 'SetNextLine b$ - this delete b$ if can't find vbCrLf sPos = InStr(b$, vbCrLf) If sPos > 0 Then sPos = sPos + 2 If Not last Then Pos = MyTrimLi(b$, Pos) If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then Select Case Lang Case 1 If ss$ = "END" Then ExpectedEndSelect Exit Function End If Case Else If ss$ = "ΤΕΛΟΣ" Then ExpectedEndSelect Exit Function End If End Select End If Pos = MyTrimLi(b$, Pos) If FastPureLabel(b$, ss$, Pos, True, , , False) = 1 Then Select Case Lang Case 1 If Not ss$ = "SELECT" Then ExpectedEndSelect Exit Function End If Case Else If ss$ = "ΕΠΙΛΟΓΗΣ" Then ExpectedEndSelect Exit Function End If End Select End If finale: Do While Len(b$) > Pos ss$ = Mid$(b$, Pos, 1) If InStr(RemWhitSpace, ss$) > 0 Then Pos = Pos + 1 ElseIf InStr(RemChar, ss$) > 0 Then Pos = Pos + 1 Do While Len(b$) > Pos If Mid$(b$, Pos, 1) = vbCr Then Exit Do Pos = Pos + 1 Loop Else Exit Do End If Loop End If DropSelect2 = Pos End Function