frmform.frm

用VB实现的编译器的源代码

            .AppendLine "    > this." & GetVN(GetCN(f)) & ".zOrder 1 [@0];;"
            .AppendLine ""
        Next f
        .AppendLine "    windowLoop;;"
        .AppendLine "  end method"
        .AppendLine ""
        For f = 0 To ControlsCount - 1
            If Objects(f).Tag = "CommandButton" Then
                .AppendLine "  method void event_" & GetCN(f) & "_Click"
                .AppendLine "    // Button " & GetCN(f) & "(" & GetVN(GetCN(f)) & ") was clicked."
                .AppendLine "  end method"
                .AppendLine ""
            End If
        Next f
        .AppendLine "  method void event_Form_Unload"
        .AppendLine "    if [:this.mainForm] | = | [!true]"
        .AppendLine "      leave;;"
        .AppendLine "  end method"
        .AppendLine ""
        .AppendLine "end class"
    End With
End Sub

Public Sub setCode(ID As Integer, nCode As String)
    Code(ID) = nCode
End Sub

Public Sub ChangeCode(ID As Integer, Setting As String, Value As String)
    On Error Resume Next
    For f = 1 To Len(Code(ID))
        If Mid(Code(ID), f, Len(Setting) + Len(vbCrLf)) = vbCrLf & Setting Then
            TMP = Mid(Code(ID), f)
            TMP = Left(TMP, InStr(3, TMP, vbCrLf) - 1)
            Code(ID) = Replace(Code(ID), TMP, vbCrLf & Setting & "=" & Value)
            MyProp.txtCode.Text = Code(ID)
            Exit Sub
        End If
    Next f
    Code(ID) = Code(ID) & Setting & "=" & Value & vbCrLf
    MyProp.txtCode.Text = Code(ID)
End Sub

Public Sub RedrawAllControls()
    On Error Resume Next
    For f = 0 To ControlsCount - 1
        P = Code(f)
        P = Replace(P, vbCrLf, vbLf)
        Q = Split(P, vbLf)
        For g = 1 To UBound(Q)
            R = Split(Q(g), "=")
            If UBound(R) > 0 Then
                Prefix = Left(R(1), 1)
                R(1) = Mid(R(1), 2)
                If Right(R(1), 1) = """" Then R(1) = Left(R(1), Len(R(1)) - 1)
                If Prefix = "!" Then
                    If R(1) = "true" And Prefix = "!" Then
                        R(1) = True
                    Else
                        R(1) = False
                    End If
                End If
                If Prefix = "@" Then
                    CallByName Objects(f), CStr(R(0)), VbLet, Val(R(1))
                ElseIf Prefix = "!" Then
                    CallByName Objects(f), CStr(R(0)), VbLet, CBool(R(1))
                ElseIf Prefix = """" Then
                    CallByName Objects(f), CStr(R(0)), VbLet, CStr(R(1))
                End If
                Debug.Print R(0) & "=" & CallByName(Objects(f), CStr(R(0)), VbGet)
            End If
        Next g
        Objects(f).ZOrder vbBringToFront
    Next f
End Sub

Public Function getControl(ID As Integer) As Object
    Set getControl = Objects(ID)
End Function

Public Function getCurrentControl() As Object
    Set getCurrentControl = Objects(Me.SelectedID)
End Function

Public Sub SelectControl(ID As Integer)
    If ID < 0 Or ID > ControlsCount - 1 Then Exit Sub
    Dim obj As Object
    Set obj = Objects(ID)
    MyProp.txtID = ID
    picCursor.Visible = True
    picCursor.Move obj.Left - 5, obj.Top - 5, obj.Width + 10, obj.Height + 10
    Set SelectedControl = obj
    picCursor.ZOrder vbBringToFront
    SelectedControl.ZOrder vbBringToFront
    SelectedID = ID
    MyProp.txtCode.Text = Code(ID)
    If TypeOf obj Is Label Then
        picCursor.Visible = False
        shpDrag.Visible = True
        shpDrag.Move SelectedControl.Left - 1, SelectedControl.Top - 1, SelectedControl.Width + 2, SelectedControl.Height + 2
    End If
End Sub

Public Sub AddAControl(cType As String)
    On Error Resume Next
    Dim obj As Object
    Select Case cType
        Case "PictureBox"
            Load PictureBox(ControlsCount)
            Set Objects(ControlsCount) = PictureBox(ControlsCount)
        Case "Label"
            Load Label(ControlsCount)
            Set Objects(ControlsCount) = Label(ControlsCount)
        Case "TextBox"
            Load TextBox(ControlsCount)
            Set Objects(ControlsCount) = TextBox(ControlsCount)
        Case "TextArea"
            Load TextArea(ControlsCount)
            Set Objects(ControlsCount) = TextArea(ControlsCount)
        Case "Frame"
            Load Frame(ControlsCount)
            Set Objects(ControlsCount) = Frame(ControlsCount)
        Case "CommandButton"
            Load CommandButton(ControlsCount)
            Set Objects(ControlsCount) = CommandButton(ControlsCount)
        Case "CheckBox"
            Load CheckBox(ControlsCount)
            Set Objects(ControlsCount) = CheckBox(ControlsCount)
        Case "OptionButton"
            Load OptionButton(ControlsCount)
            Set Objects(ControlsCount) = OptionButton(ControlsCount)
        Case "ComboBox"
            Load ComboBox(ControlsCount)
            Set Objects(ControlsCount) = ComboBox(ControlsCount)
        Case "ListBox"
            Load ListBox(ControlsCount)
            Set Objects(ControlsCount) = ListBox(ControlsCount)
        Case "Timer"
            Load Timer(ControlsCount)
            Set Objects(ControlsCount) = Timer(ControlsCount)
    End Select
    With Objects(ControlsCount)
        .Visible = True
        .Left = shpDrag.Left
        .Top = shpDrag.Top
        .Width = shpDrag.Width
        .Height = shpDrag.Height
        .Tag = cType
    End With
    Code(ControlsCount) = "ctl" & cType & ControlsCount & vbCrLf & _
                        "visible=!true" & vbCrLf & _
                        "left=@" & Objects(ControlsCount).Left & vbCrLf & _
                        "top=@" & Objects(ControlsCount).Top & vbCrLf & _
                        "width=@" & Objects(ControlsCount).Width & vbCrLf & _
                        "height=@" & Objects(ControlsCount).Height & vbCrLf
    shpDrag.Visible = False
    
    SelectControl ControlsCount
    ControlsCount = ControlsCount + 1
    RedrawAllControls
End Sub

Private Sub Form_DblClick()
    GridType = GridType + 1
    If GridType = 6 Then GridType = 0
    DrawGrid
End Sub

Private Sub Form_DragDrop(Source As Control, X As Single, Y As Single)
    On Error Resume Next
    If Source = picCursor Then
        If picCursor.MousePointer = vbSizeWE Then
            picCursor.Width = X - (picCursor.Left)
        ElseIf picCursor.MousePointer = vbSizeNS Then
            picCursor.Height = Y - (picCursor.Top)
        Else
            picCursor.Move X - MinusX, Y - MinusY
        End If
    End If
    SelectedControl.Move picCursor.Left + 5, picCursor.Top + 5, picCursor.Width - 10, picCursor.Height - 10
    ChangeCode SelectedID, "left", "@" & SelectedControl.Left
    ChangeCode SelectedID, "top", "@" & SelectedControl.Top
    ChangeCode SelectedID, "width", "@" & SelectedControl.Width
    ChangeCode SelectedID, "height", "@" & SelectedControl.Height
End Sub

Private Sub Form_Load()
    GridSize = 8
    Set MyProp = New frmProperties
    MyProp.Show
    Set MyProp.Owner = Me
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        X = Int(X / GridSize) * GridSize
        Y = Int(Y / GridSize) * GridSize
        shpDrag.Move X, Y, 1, 1
        shpDrag.Visible = True
    Else
        PopupMenu mnuContext
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    On Error Resume Next
    lblInfo.Visible = False
    If Button = 0 Then Exit Sub
    X = Int(X / GridSize) * GridSize + 1
    Y = Int(Y / GridSize) * GridSize + 1
    shpDrag.Width = X - shpDrag.Left
    shpDrag.Height = Y - shpDrag.Top
End Sub

Private Sub DrawGrid()
    Me.Cls
    Select Case GridType
        Case 0
            For X = 0 To Me.ScaleWidth Step GridSize
                For Y = 0 To Me.ScaleHeight Step GridSize
                    Me.PSet (X, Y), 0
                Next
            Next
        
        Case 1
            For X = 0 To Me.ScaleWidth Step GridSize
                For Y = 0 To Me.ScaleHeight Step GridSize
                    Me.PSet (X, Y), vbRed
                Next
            Next
        
        Case 2
            For X = 0 To Me.ScaleWidth Step GridSize
                Me.Line (X, 0)-(X, Me.ScaleHeight), 0
            Next
            For Y = 0 To Me.ScaleHeight Step GridSize
                Me.Line (0, Y)-(Me.ScaleWidth, Y), 0
            Next
        
        Case 3
            For X = 0 To Me.ScaleWidth Step GridSize
                Me.Line (X, 0)-(X, Me.ScaleHeight), RGB(0, 0, 128)
            Next
            For Y = 0 To Me.ScaleHeight Step GridSize
                Me.Line (0, Y)-(Me.ScaleWidth, Y), RGB(0, 0, 128)
            Next
        
        Case 4
            For X = 0 To Me.ScaleWidth Step GridSize
                For Y = 0 To Me.ScaleHeight Step GridSize
                    Me.Line (X, Y - 2)-(X, Y + 3), RGB(0, 0, 128)
                    Me.Line (X - 2, Y)-(X + 3, Y), RGB(0, 0, 128)
                Next
            Next
    End Select
End Sub

Private Sub Form_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then Exit Sub
    For f% = 0 To ControlsCount - 1
        If Objects(f).Top > shpDrag.Top And _
            Objects(f).Left > shpDrag.Left And _
            Objects(f).Height + Objects(f).Top < shpDrag.Height + shpDrag.Top And _
            Objects(f).Width + Objects(f).Left < shpDrag.Width + shpDrag.Left Then
            SelectControl f
            shpDrag.Visible = False
            Exit Sub
        End If
    Next
    Dim nFS As New frmSelector
    nFS.Move Me.Left + X * Screen.TwipsPerPixelX, Me.Top + Y * Screen.TwipsPerPixelY
    nFS.Show
    Set nFS.OwnerForm = Me
End Sub

Private Sub Form_Resize()
    DrawGrid
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Unload MyProp
End Sub

Private Sub mnuContextCaption_Click()
    NewCaption$ = InputBox("Please enter the new caption.", "Set caption", Me.Caption)
    If NewCaption = "" Then Exit Sub
    Me.Caption = NewCaption
End Sub

Private Sub picCursor_DragDrop(Source As Control, X As Single, Y As Single)
    On Error Resume Next
    If Source = picCursor Then
        If picCursor.MousePointer = vbSizeWE Then
            picCursor.Width = X
        ElseIf picCursor.MousePointer = vbSizeNS Then
            picCursor.Height = Y
        End If
    End If
    If picCursor.ScaleWidth < 10 Then picCursor.Width = 14
    If picCursor.ScaleHeight < 10 Then picCursor.Height = 14
    SelectedControl.Move picCursor.Left + 5, picCursor.Top + 5, picCursor.Width - 10, picCursor.Height - 10
    ChangeCode SelectedID, "left", "@" & SelectedControl.Left
    ChangeCode SelectedID, "top", "@" & SelectedControl.Top
    ChangeCode SelectedID, "width", "@" & SelectedControl.Width
    ChangeCode SelectedID, "height", "@" & SelectedControl.Height
End Sub

Private Sub picCursor_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If X > picCursor.Width - 5 Then
        picCursor.MousePointer = vbSizeWE
    ElseIf Y > picCursor.Height - 5 Then
        picCursor.MousePointer = vbSizeNS
    Else
        picCursor.MousePointer = vbArrow
    End If
    
    If Button = 0 Then Exit Sub
    
    If X > picCursor.Width - 5 Then
    ElseIf Y > picCursor.Height - 5 Then
    Else
        MinusX = X
        MinusY = Y
    End If
    picCursor.Drag
End Sub