frmrun.frm

一个14岁的小孩写的D++编译器

VERSION 5.00
Begin VB.Form Form1 
   BorderStyle     =   1  'Fixed Single
   Caption         =   "D++ APP"
   ClientHeight    =   3825
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7200
   Icon            =   "frmRun.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   3825
   ScaleWidth      =   7200
   StartUpPosition =   3  'Windows Default
   Begin VB.TextBox txtIn 
      BackColor       =   &H00000000&
      BeginProperty Font 
         Name            =   "Terminal"
         Size            =   9
         Charset         =   255
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   3855
      Left            =   360
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   1
      Top             =   4920
      Width           =   6855
   End
   Begin VB.TextBox txtText 
      BackColor       =   &H00000000&
      BeginProperty Font 
         Name            =   "Terminal"
         Size            =   9
         Charset         =   255
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      ForeColor       =   &H00FFFFFF&
      Height          =   3855
      Left            =   0
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   0
      Width           =   7455
   End
   Begin VB.Timer Timer1 
      Interval        =   1
      Left            =   1800
      Top             =   2640
   End
   Begin VB.Label input1 
      Height          =   615
      Left            =   4920
      TabIndex        =   2
      Top             =   1920
      Width           =   1095
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim flag As Boolean, flag1 As Boolean
Dim val1, val2, val3, val4, val5, val6, val7, chartext, chartext1

Private Sub Form_Load()
On Error GoTo Errorh
    
    Me.Show
    
    Open App.Path + "\" + App.EXEName + ".EXE" For Binary As #1
    
    FileSize = LOF(1)
    FileData$ = Space$(LOF(1))
    
    Get #1, , FileData$

    For i = 1 To FileSize
        If Mid(FileData$, i, 4) = "DPP:" Then
            i = i + 4
            FileChunk$ = String(1000, 0)
            Get #1, i, FileChunk$
            txtIn.Text = FileChunk$
            Linkit
            Exit Sub
        End If
    Next i
    
    Close #1
    
Errorh:
MsgBox "Error #" & Err.Number & " has occured: " & Err.Description, vbCritical, "Error"
End Sub

Sub Linkit()
For i = 1 To Len(txtIn.Text)

    If Mid(txtIn.Text, i, 11) = "screenout " & Chr(34) Or Mid(txtIn.Text, i, 11) = "SCREENOUT " & Chr(34) Then
        i = i + 11
        d = i + 256
        Do Until Mid(txtIn.Text, i, 2) = Chr(34) & ";"
        If i = d Then
            MsgBox "Expected ';' at " & i & "; Found end of program.", vbCritical, "Error"
            End
        End If
        a Mid(txtIn.Text, i, 1)
        i = i + 1
        Loop
        
    ElseIf Mid(txtIn.Text, i, 11) = "screenput """ Or Mid(txtIn.Text, i, 11) = "SCREENPUT """ Then
        i = i + 11
        d = i + 256
        chartext = ""
        Do Until Mid(txtIn.Text, i, 2) = """;"
        If i = d Then
            MsgBox "Expected ';' at " & i & "; Found end of program.", vbCritical, "Error"
            End
        End If
        chartext = chartext & Mid(txtIn.Text, i, 1)
        i = i + 1
        Loop
        txtText.Text = txtText.Text & chartext
        
    ElseIf Mid(txtIn.Text, i, 10) = "screenout " Or Mid(txtIn.Text, i, 11) = "SCREENOUT " Then
        i = i + 10
        d = i + 256
        Do Until Mid(txtIn.Text, i, 1) = ";"
        If i = d Then
            MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
            End
        End If
        val3 = val3 & Mid(txtIn.Text, i, 1)
        i = i + 1
        Loop
        If val3 = val1 Then
            a val2
        Else
            MsgBox "Syntax Error: variable not defined.", vbCritical, "Syntax Error"
            End
        End If

    ElseIf Mid(txtIn.Text, i, 10) = "screenput " Or Mid(txtIn.Text, i, 10) = "SCREENPUT " Then
        i = i + 10
        d = i + 256
        Do Until Mid(txtIn.Text, i, 1) = ";"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            chartext1 = chartext1 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        If chartext1 = val1 Then
            txtText.Text = txtText.Text & val2
        Else
            MsgBox "Syntax Error: variable not defined.", vbCritical, "Syntax Error"
            End
        End If
        
    ElseIf Mid(txtIn.Text, i, 9) = "screenin " Or Mid(txtIn.Text, i, 9) = "SCREENIN " Then
        val4 = ""
        i = i + 9
        d = i + 256
        Do Until Mid(txtIn.Text, i, 3) = ", """
            If i = d Then
                MsgBox "Syntax Error: Expected ',' at " & i & "; Found end of program.", vbCritical, "Error"
                End
            End If
            val1 = val1 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        i = i + 3
        Do Until Mid(txtIn.Text, i, 2) = """;"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            val4 = val4 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        val2 = InputBox(val4, "Input Value", "Value")
        
        
    ElseIf Mid(txtIn.Text, i, 7) = "title """ Or Mid(txtIn.Text, i, 7) = "TITLE """ Then
        i = i + 7
        d = i + 256
        Me.Caption = ""
    
        Do Until Mid(txtIn.Text, i, 2) = """;"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            Me.Caption = Me.Caption & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        App.Title = Me.Caption

    ElseIf Mid(txtIn.Text, i, 8) = "delete """ Or Mid(txtIn.Text, i, 8) = "DELETE """ Then
        i = i + 8
        d = i + 256
        Do Until Mid(txtIn.Text, i, 2) = """;"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            val5 = val5 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        If FileExist(val5) = False Then
            MsgBox "Run Time Error: File not found", vbCritical, "Run Time Error"
            End
        Else
            Kill val5
        End If
        
    ElseIf Mid(txtIn.Text, i, 7) = "delete " Or Mid(txtIn.Text, i, 7) = "DELETE " Then
        i = i + 7
        d = i + 256
        val6 = ""
        Do Until Mid(txtIn.Text, i, 1) = ";"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            val6 = val6 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        If val6 = val1 Then
            If FileExist(val2) = False Then
                MsgBox "Error!  File not found!", vbCritical, "File Not Found"
            Else
                Kill val2
            End If
        Else
            MsgBox "Syntax Error: Variable not defined: " & val6, vbCritical, "Syntax Error"
            End
        End If
        
    ElseIf Mid(txtIn.Text, i, 1) = "<" Then
        i = i + 1
        Do Until Mid(txtIn.Text, i, 1) = ">"
            i = i + 1
        Loop
        i = i + 1
        
    ElseIf Mid(txtIn.Text, i, 5) = "box """ Or Mid(txtIn.Text, i, 5) = "BOX""" Then
        i = i + 5
        d = i + 256
    
        Do Until Mid(txtIn.Text, i, 4) = """, """
            If i = d Then
                MsgBox "Syntax Error: Expected ',' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            box1 = box1 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        i = i + 4
        Do Until Mid(txtIn.Text, i, 2) = """;"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            box2 = box2 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        MsgBox box1, vbExclamation, box2
        
    ElseIf Mid(txtIn.Text, i, 5) = "pause" Or Mid(txtIn.Text, i, 5) = "pause" Then
        i = i + 5
        d = i + 256
        val7 = ""
        Do Until Mid(txtIn.Text, i, 1) = ";"
            If i = d Then
                MsgBox "Syntax Error: Expected ';' at " & i & "; Found end of program.", vbCritical, "Syntax Error"
                End
            End If
            val7 = val7 & Mid(txtIn.Text, i, 1)
            i = i + 1
        Loop
        Pause val7
        
    ElseIf Mid(txtIn.Text, i, 6) = "clear;" Or Mid(txtIn.Text, i, 6) = "CLEAR;" Then
        txtText.Text = ""
        
    ElseIf Mid(txtIn.Text, i, 8) = "pause05;" Or Mid(txtIn.Text, i, 8) = "PAUSE1;" Then
        Pause 0.5

    ElseIf Mid(txtIn.Text, i, 7) = "pause1;" Or Mid(txtIn.Text, i, 7) = "PAUSE1;" Then
        Pause 1
        
    ElseIf Mid(txtIn.Text, i, 7) = "pause2;" Or Mid(txtIn.Text, i, 7) = "PAUSE2;" Then
        Pause 2
        
    ElseIf Mid(txtIn.Text, i, 7) = "pause3;" Or Mid(txtIn.Text, i, 7) = "PAUSE3;" Then
        Pause 3
        
    ElseIf Mid(txtIn.Text, i, 4) = "end;" Or Mid(txtIn.Text, i, 4) = "END;" Then
        End
        
    ElseIf Mid(txtIn.Text, i, 7) = "screen;" Or Mid(txtIn.Text, i, 7) = "SCREEN;" Then
        txtText.Text = txtText.Text & vbCrLf
        
    Else
        If Mid(txtIn.Text, i, 1) <> "" And Mid(txtIn.Text, i, 1) = vbCrLf And Mid(txtIn.Text, i, 1) <> " " And Mid(txtIn.Text, i, 1) <> "    " Then
            MsgBox "Syntax Error: Invalid syntax at " & i & ". (" & Mid(txtIn.Text, i, 1) & ")", vbCritical, "Syntax Error"
        End If
    End If
    
Next i
End Sub

Sub Pause(interval)
Current = Timer
Do While Timer - Current < Val(interval)
DoEvents
Loop
End Sub

Sub a(TextToPut)
On Error Resume Next
'txtText.SelText = vbCrLf
For sd = 1 To Len(TextToPut)
txtText.SelStart = Len(txtText)
txtText.SelText = Mid(TextToPut, sd, 1)
DoEvents
Pause 0.01
Next sd
txtText.SelStart = Len(txtText)
End Sub

Function FileExist(ByVal FileName As String) As Boolean
    Dim fileFile As Integer
    fileFile = FreeFile
    On Error Resume Next
    Open FileName For Input As fileFile
    If Err Then
        FileExist = False
    Else
        Close fileFile
        FileExist = True
    End If
End Function

Private Sub Form_Unload(Cancel As Integer)
End
End Sub

Private Sub Timer1_Timer()
    txtText.SelStart = Len(txtIn.Text)
End Sub