frmwindow.frm

来自「多种图表的绘制及其运用」· FRM 代码 · 共 545 行 · 第 1/2 页

        '         frmMain.Private Sub timerRunner_Timer()
        ' some assembler.... :)

        frmStack.PUSH (frmVars.ifVarGetValue("PARAM")) ' [*] save param of previous function.
        ' PUSHING: 1. parameter(s), 2. where to store return, 3. CS, 4. IP
        frmStack.PUSH frmVars.ifVarGetValue(sParameters)   ' parameter(s).
        frmStack.PUSH "SUB_RETURN" ' where to store result in.
        frmStack.PUSH ExtractFileName(currentFileName)  ' CS - return to that program.
        Dim blockToReturnTo As cBlock
        
        Set blockToReturnTo = currentRunPointer  ' return to the same WINDOW!!!!

        frmMain.shp_Selector.Visible = False ' hide selector.
        frmStack.PUSH blockToReturnTo.TagID    ' IP - next command to return to (alpha...).

        ' #020105:
        If frmMain.load_FILE(currentPATH & sCommand & ".fpp") Then  ' load another program (function).
            Set currentRunPointer = findBlock("START")
            frmMain.setSelector currentRunPointer
        Else
            mBox "Cannot load function: " & sCommand
            frmMain.setSelector currentRunPointer   ' just to show where we stoped.
            ''Set currentRunPointer = Nothing ' Stop execution.
            frmMain.TerminateExecution  ' stop program!
            ' stack is filled with some data, so it's better to stop.
        End If

        ' start timer!!!!!!!! (stoped when returns back to window!!!)
        frmMain.StartExecution
        
    End If
    
End Sub

Private Function objectNameExists(sName As String) As Boolean
    Dim cg As cGUI_obj
    
    For Each cg In theGUI
       If StrComp(sName, cg.sID, vbTextCompare) = 0 Then
            objectNameExists = True
            Exit Function
       End If
    Next cg
    
    ' if gets here, not found:
    objectNameExists = False
End Function



' currenlty exchanging values between OBJECTS is not
'   supported. only between variables and objects.
' on success returns "TRUE", on any error - shows error message,
'   and returns "FALSE".
Public Function processObjectDefinition(p1 As String, p2 As String) As Boolean

On Error GoTo errDef

    processObjectDefinition = True ' could be changed to "False" later.

    Dim sName As String
    Dim sPROP As String
    Dim s As String
    
    ' string constants can have dots inside:
    If (InStr(1, p1, ".") > 0) And ((InStr(1, p2, ".") > 0) And (Mid(p2, 1, 1) <> """")) Then
        mBox "Object to object assignment is not supported yet!"
        processObjectDefinition = False
        
    ' first is an object, second is a variable/constant:
    ElseIf InStr(1, p1, ".") > 0 Then

        sName = extractObjectName(p1)
        sPROP = UCase(extractProperty(p1))

        p2 = removeQuotes(p2) ' quotes around are ignored.


        If StrComp(sName, "WINDOW", vbTextCompare) = 0 Then
            Select Case sPROP

            Case "W"
                s = frmVars.ifVarGetValue(p2)
                s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
                Me.Width = Val(s) * Screen.TwipsPerPixelX
                
            Case "H"
                s = frmVars.ifVarGetValue(p2)
                s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
                Me.Height = Val(s) * Screen.TwipsPerPixelY
                
            Case Else
                mBox "Cannot do: " & p1 & " = " & p2 & _
                     vbNewLine & "This window's property isn't" _
                     & vbNewLine & "available for reading!"
                processObjectDefinition = False
            End Select
            Exit Function
        End If


        ' check object name, to avoid error when
        '   there is a wrong GUI name:
        If Not objectNameExists(sName) Then
            mBox "Cannot do: " & p1 & " = " & p2 & _
                    vbNewLine & "Object with name: " & sName & _
                    vbNewLine & "not found on current window."
            processObjectDefinition = False
            Exit Function
        End If
        
        Select Case sPROP
        Case "TEXT"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            s = replaceALL(s, "\n", vbNewLine) ' replace "\n" with real newline.
            theGUI(sName).sText = s
        
        Case "IMAGE"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            s = checkFileAndPath(s)
            ' in case file not exists, checkFileAndPath() sets s="",
            '    and nothing is loaded:
            theGUI(sName).objGUI.Picture = LoadPicture(s)
        
        ' this isn't a property, but METHOD,
        '   we just don't want to create a special operation:
        Case "LINE"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            theGUI(sName).objGUI.Line _
              (getPar(0, s), getPar(1, s))-(getPar(2, s), getPar(3, s))
            
        Case "VISIBLE"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            If UCase(s) = "TRUE" Then
                theGUI(sName).objGUI.Visible = True
            Else
                theGUI(sName).objGUI.Visible = False
            End If
            
        Case "DRAWMODE"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            If UCase(s) = "INVERT" Then
                theGUI(sName).objGUI.DrawMode = vbInvert
            Else
                theGUI(sName).objGUI.DrawMode = vbCopyPen
            End If
          
        Case "X"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            theGUI(sName).X = Val(s) * Screen.TwipsPerPixelX

        Case "Y"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            theGUI(sName).Y = Val(s) * Screen.TwipsPerPixelY
            
        Case "W"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            theGUI(sName).w = Val(s) * Screen.TwipsPerPixelX
            
        Case "H"
            s = frmVars.ifVarGetValue(p2)
            s = removeQuotes(s) ' quotes around are ignored (var can also have quotes).
            theGUI(sName).h = Val(s) * Screen.TwipsPerPixelY
            
        Case Else
            mBox "Cannot do: " & p1 & " = " & p2 & _
                    vbNewLine & "Property not found!"
            processObjectDefinition = False
        End Select
    
    ' first is a variable, second is an object:
    Else
        sName = extractObjectName(p2)
        sPROP = UCase(extractProperty(p2))
        
        If StrComp(sName, "WINDOW", vbTextCompare) = 0 Then
            Select Case sPROP

            Case "W"
                frmVars.setVar p1, Int(Me.Width / Screen.TwipsPerPixelX)

            Case "H"
                frmVars.setVar p1, Int(Me.Height / Screen.TwipsPerPixelY)

            Case Else
                mBox "Cannot do: " & p1 & " = " & p2 & _
                     vbNewLine & "This window's property isn't" _
                     & vbNewLine & "available for reading!"
                processObjectDefinition = False
            End Select
            Exit Function
        End If
        
        ' check object name, to avoid error when
        '   there is a wrong GUI name:
        If Not objectNameExists(sName) Then
            mBox "Cannot do: " & p1 & " = " & p2 & _
                    vbNewLine & "Object with name: " & sName & _
                    vbNewLine & "not found on current window."
            processObjectDefinition = False
            Exit Function
        End If
        
        Select Case sPROP
        Case "TEXT"
            frmVars.setVar p1, theGUI(sName).sText
            
        Case "X"
            frmVars.setVar p1, Int(theGUI(sName).X / Screen.TwipsPerPixelX)
            
        Case "Y"
            frmVars.setVar p1, Int(theGUI(sName).Y / Screen.TwipsPerPixelY)
            
        Case "W"
            frmVars.setVar p1, Int(theGUI(sName).w / Screen.TwipsPerPixelX)
            
        Case "H"
            frmVars.setVar p1, Int(theGUI(sName).h / Screen.TwipsPerPixelY)
            
        Case Else
            mBox "Cannot do: " & p1 & " = " & p2 & _
                    vbNewLine & "Property not available for reading!"
            processObjectDefinition = False
        End Select
               
    End If
     
    'Debug.Print p1 & " = " & p2
    Exit Function
errDef:
    mBox "Error in object definition: " & vbNewLine & _
           p1 & " = " & p2 & vbNewLine & _
           Err.Description
    processObjectDefinition = False
    
End Function

Private Function extractObjectName(s As String) As String
    Dim i As Long
    
    i = InStr(1, s, ".")
    
    If (i > 0) Then
         ' return everything before dot:
        extractObjectName = Mid(s, 1, i - 1)
    Else
        extractObjectName = s
    End If
End Function

Private Function extractProperty(s As String) As String
    Dim i As Long
    
    i = InStr(1, s, ".")
    
    If (i > 0) Then
         ' return everything after the dot:
        extractProperty = Mid(s, i + 1)
    Else
        extractProperty = ""
    End If
End Function