cblock.cls

来自「多种图表的绘制及其运用」· CLS 代码 · 共 416 行

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cBlock"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Attribute VB_Ext_KEY = "Member0" ,"blockCollection"
' =========================================================
'  === Project of Data-flow Visual Programming Language ===
' =========================================================
' Copyright Emu8086, Inc. Free Code !
'
'
' URL: http://www.emu8086.com/vb/




' [e-mail]
' =========================================================
'  The class for cBlock
'  (works with myShape Active-X like
'   two these objects are single big object).
'  Programs are made from cBlock(s) connected
'  by cLine(s).
' =========================================================

Option Explicit




'local variable(s) to hold property value(s)
' currect active-x object linked with this
' block (assumed they are the same object):
Public theObjectShape As PictureBox 'GShape

'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent linkError[(arg1, arg2, ... , argn)]
Public Event linkError(sERROR As String)
'local variable(s) to hold property value(s)
Private mvarbSetUpperCaptionDown As Boolean 'local copy

'local variable(s) to hold property value(s)
' added internal property to allow running without GUI:
Private mvar_TagID As String


Public zAction As String   ' action of this block.
Public zParam1 As String   ' first parameter for action.
Public zParam2 As String   ' second parameter for action.
Public zParam3 As String   ' third parameter (generally result).

'Property Variables:
Dim m_TextColor As OLE_COLOR
Dim m_BGColor As OLE_COLOR
Dim m_Shape As Integer
Dim m_BorderColor As OLE_COLOR
Dim m_sCaptionUp As String
Dim m_sCaption As String



Public Property Let TextColor(ByVal vData As Long)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.TextColor = 5
    m_TextColor = vData
End Property


Public Property Get TextColor() As Long
'used when retrieving value of a property, on the right side of an assignment.
    TextColor = m_TextColor
End Property


' this procedure sets the caption for the block
' according to zAction (the action for this block):
Public Sub setCaptionToAction()
    Select Case zAction
    
    Case "START"
        sCaption = cLang("start")
        
    Case "STOP"
        sCaption = cLang("stop")
    
    Case "INTERSECTION"
        ' nothing.
    
    Case "OUTPUT"
        sCaptionUp = cLang("output")
        If zParam2 = "" Then    ' only message
            sCaption = """" & zParam1 & """"
        ElseIf zParam1 = "" Then ' only variable
            sCaption = zParam2
        Else                    ' both message & variable
            sCaption = """" & zParam1 & """, " & zParam2
        End If
        
    Case "INPUT"
        sCaptionUp = cLang("input")
        If zParam1 = "" Then    ' only variable
            sCaption = zParam2
        Else                    ' both message & variable
            sCaption = """" & zParam1 & """, " & zParam2
        End If
        
    Case "DEFINITION"
        sCaption = zParam1 & " = " & zParam2

        
    Case "IF_EQUAL"
        sCaption = zParam1 & " = " & zParam2
    Case "IF_GREATER"
        sCaption = zParam1 & " > " & zParam2
    Case "IF_LESS"
        sCaption = zParam1 & " < " & zParam2
    Case "IF_LESS_EQUAL"
        sCaption = zParam1 & " <= " & zParam2
    Case "IF_GREATER_EQUAL"
        sCaption = zParam1 & " >= " & zParam2
        
    Case "ADD"
        sCaption = zParam3 & " = " & zParam1 & " + " & zParam2
    Case "SUBTRACT"
        sCaption = zParam3 & " = " & zParam1 & " - " & zParam2
    Case "MULTIPLY"
        sCaption = zParam3 & " = " & zParam1 & " * " & zParam2
    Case "DIVIDE"
        sCaption = zParam3 & " = " & zParam1 & " / " & zParam2
        
    Case "JOIN"
        sCaption = zParam3 & " = " & zParam1 & " & " & zParam2
    Case "COMP"
        sCaption = zParam3 & " = " & zParam1 & " COMP " & zParam2
        
    Case "SQL"
        sCaption = "SQL"
        
    Case "FUNCTION"
        If zParam3 <> "" Then
            sCaption = zParam3 & " = " & zParam1 & "(" & zParam2 & ")"
        Else
            sCaption = zParam1 & "(" & zParam2 & ")"
        End If
        
    Case "WINDOW"
        sCaption = cLang("window")
        
    Case Else
        Debug.Print "setCaptionToAction(). Unknown action code in zAction: " & zAction
    End Select
    
    ' making sure the caption will be visible on the block
    '   (resize if required)
    ' assumed: frmScreen uses the same font as blocks!
    If sCaption <> "" Then  ' ignored for intersections.
        If m_Shape = 92 Then ' 92 - for diamond.
            If frmScreen.TextWidth(sCaption) + 40 > shapeWidth Then
                shapeWidth = frmScreen.TextWidth(sCaption) + 40
            End If
        Else ' all other boxes:
            If frmScreen.TextWidth(sCaption) + 20 > shapeWidth Then
                shapeWidth = frmScreen.TextWidth(sCaption) + 20
            End If
        End If
    End If
    
End Sub

Public Property Let sCaption(ByVal vData As String)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.sCaption = 5
    m_sCaption = vData
End Property

Public Property Get sCaption() As String
'used when retrieving value of a property, on the right side of an assignment.
    sCaption = m_sCaption
End Property

Public Property Let sCaptionUp(ByVal vData As String)
    m_sCaptionUp = vData
End Property

Public Property Get sCaptionUp() As String
    sCaptionUp = m_sCaptionUp
End Property


' this makes active-x object and this object have:
'      Tag == TagID
Public Property Let TagID(ByVal vData As String)
    mvar_TagID = vData
    If bGUI Then theObjectShape.Tag = mvar_TagID
End Property

Public Property Get TagID() As String
    TagID = mvar_TagID 'theObjectShape.Tag
End Property


Public Property Let BorderColor(ByVal vData As Long)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.shapeBorderColor = 5
    m_BorderColor = vData
End Property


Public Property Get BorderColor() As Long
'used when retrieving value of a property, on the right side of an assignment.
    BorderColor = m_BorderColor
End Property


Public Property Let BGColor(ByVal vData As Long)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.shapeBackColor = 5
    m_BGColor = vData
End Property


Public Property Get BGColor() As Long
'used when retrieving value of a property, on the right side of an assignment.
    BGColor = m_BGColor
End Property


Public Property Let shapeHeight(ByVal vData As Integer)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.shapeHeight = 5
    theObjectShape.Height = vData
End Property


Public Property Get shapeHeight() As Integer
'used when retrieving value of a property, on the right side of an assignment.
    shapeHeight = theObjectShape.Height
End Property


Public Property Let shapeWidth(ByVal vData As Integer)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.shapeWidth = 5
    theObjectShape.Width = vData
End Property


Public Property Get shapeWidth() As Integer
'used when retrieving value of a property, on the right side of an assignment.
    shapeWidth = theObjectShape.Width
End Property


Public Property Let Shape(ByVal vData As Integer)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Shape = 5
    m_Shape = vData
End Property


Public Property Get Shape() As Integer
'used when retrieving value of a property, on the right side of an assignment.
    Shape = m_Shape
End Property


Public Property Let Visible(ByVal vData As Boolean)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.Visible = 5
    theObjectShape.Visible = vData
End Property


Public Property Get Visible() As Boolean
'used when retrieving value of a property, on the right side of an assignment.
    Visible = theObjectShape.Visible
End Property

Public Property Let shapeLeft(ByVal vData As Single)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.shapeLeft = 5
    theObjectShape.Left = vData
End Property


Public Property Get shapeLeft() As Single
'used when retrieving value of a property, on the right side of an assignment.
    shapeLeft = theObjectShape.Left
End Property


Public Property Let shapeTop(ByVal vData As Single)
'used when assigning a value to the property, on the left side of an assignment.
'Syntax: X.shapeTop = 5
    theObjectShape.Top = vData
End Property


Public Property Get shapeTop() As Single
'used when retrieving value of a property, on the right side of an assignment.
    shapeTop = theObjectShape.Top
End Property


Public Sub PaintMe()
    Dim tWidth As Single
    Dim tHeight As Single
    Dim p(0 To 5) As POINTAPI

 ' because of below:
 On Error GoTo err_expt

' sometimes there is an error: Client site not available!
'  in the end  of execution of c.tzr (on closing of frmMain):
    theObjectShape.BackColor = theObjectShape.Parent.BackColor
    theObjectShape.Cls

    ' temporary variables to keep width-1 and height-1
    tWidth = theObjectShape.ScaleWidth - 1
    tHeight = theObjectShape.ScaleHeight - 1

    theObjectShape.ForeColor = m_BorderColor
    theObjectShape.FillColor = m_BGColor
    Select Case m_Shape
    
    Case 0      ' rectangle
        ' draw frame:
        theObjectShape.Line (0, 0)-(tWidth, tHeight), , B
        ' draw inside:
        theObjectShape.Line (1, 1)-(tWidth - 1, tHeight - 1), theObjectShape.FillColor, BF
    Case 2      ' oval
        theObjectShape.Circle (tWidth / 2, tHeight / 2), tWidth / 2, , , , tHeight / tWidth
    
    Case 3      ' circle
        theObjectShape.Circle (tWidth / 2, tHeight / 2), tWidth / 2
    
    Case 91     ' parallelogram.
        p(0).X = 10
        p(0).Y = 0
        p(1).X = tWidth
        p(1).Y = 0
        p(2).X = tWidth - 10
        p(2).Y = tHeight
        p(3).X = 0
        p(3).Y = tHeight
        Polygon theObjectShape.hdc, p(0), 4
        
    Case 92     ' diamond.
        p(0).X = tWidth / 2
        p(0).Y = 0
        p(1).X = tWidth
        p(1).Y = tHeight / 2
        p(2).X = tWidth / 2
        p(2).Y = tHeight
        p(3).X = 0
        p(3).Y = tHeight / 2
        Polygon theObjectShape.hdc, p(0), 4
        
    Case 93     ' six-point diamond.
        p(0).X = 0
        p(0).Y = tHeight / 2
        p(1).X = 10
        p(1).Y = 0
        p(2).X = tWidth - 10
        p(2).Y = 0
        p(3).X = tWidth
        p(3).Y = tHeight / 2
        p(4).X = tWidth - 10
        p(4).Y = tHeight
        p(5).X = 10
        p(5).Y = tHeight
        Polygon theObjectShape.hdc, p(0), 6
          
    Case Else
        MsgBox "wrong setting to Shape property: " & m_Shape
    End Select

   
    ' print the caption:
    
    ' restore ForeColor:
    theObjectShape.ForeColor = m_TextColor
    
    ' in case there is one line caption:
    If m_sCaptionUp = "" Then
        theObjectShape.CurrentX = tWidth / 2 - theObjectShape.TextWidth(m_sCaption) / 2
        theObjectShape.CurrentY = tHeight / 2 - theObjectShape.TextHeight(m_sCaption) / 2
        theObjectShape.Print m_sCaption
    ' in case there are two lines in caption:
    Else
        ' print first line:
        theObjectShape.CurrentX = tWidth / 2 - theObjectShape.TextWidth(m_sCaptionUp) / 2
        theObjectShape.CurrentY = tHeight / 2 - theObjectShape.TextHeight(m_sCaptionUp)
        theObjectShape.Print m_sCaptionUp
        ' print second line:
        theObjectShape.CurrentX = tWidth / 2 - theObjectShape.TextWidth(m_sCaption) / 2
        theObjectShape.CurrentY = tHeight / 2
        theObjectShape.Print m_sCaption
    End If

    Exit Sub
err_expt:

End Sub