frmmain.frm

多种图表的绘制及其运用

Private Sub mnuHelpToStudent_Click()
  '  Dim r As Long
    
   ' r = ShellExecute(Me.hwnd, "open", AddSlash(App.Path) & "Help\index.html", "", App.Path, SW_SHOWDEFAULT)
    
      Call ShellExecute(Me.hwnd, "open", "http://www.emu8086.com/fp/Help/index.html", "", App.Path, SW_SHOWDEFAULT)
 
    
  '  If r <= 32 Then
  '      MsgBox "Cannot open help file, make sure program that reads HTML files is installed on your system."
  '  End If
End Sub

Private Sub mnuLoad_Click()

    If Not Check_If_Saved Then Exit Sub
    
   ''''''''''''''''''''''''''''
   

On Error GoTo Canceled

    CommonDialog1.InitDir = App.Path ' 1.88
    
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "Flow Program Projects (*.fpp)|*.fpp|All Files|*.*"
    CommonDialog1.DefaultExt = "fpp"
    CommonDialog1.CancelError = True
    CommonDialog1.ShowOpen

    ' hide selector:
    shp_Selector.Visible = False
    
    load_FILE CommonDialog1.FileName

    ' reset the selection:
    PREV_SELECTED_SHAPE = -1
    SELECTED_SHAPE = -1

Canceled:
    
End Sub

' returns True when load successful, otherwise False:
Public Function load_FILE(sFILE As String) As Boolean

    ' no need to destroy all previous data if file doesn't
    '   even exits:
    If Not FileExists(sFILE) Then
        load_FILE = False
        Exit Function
    End If

    
    currentFileName = ""
    Me.Caption = ""


On Error GoTo error_load

    Dim i As Integer
    
    Dim mFileNum As Integer
    mFileNum = FreeFile
    
    ' unload all previous objects:
    For i = 1 To MAX_SHAPE
        Unload shp(i)
    Next i
    MAX_SHAPE = 0
    For i = theBlockCollection.Count To 1 Step -1
        theBlockCollection.Remove i
    Next i
    For i = 1 To MAX_LINE
        Unload ln(i)
        Unload aDot(i)
        Unload arrUp(i)
        Unload arrDown(i)
        Unload lblLineCap(i)
    Next i
    MAX_LINE = 0
    For i = theLineCollection.Count To 1 Step -1
        theLineCollection.Remove i
    Next i
    
    Open sFILE For Input As mFileNum

    Dim tempS As String
    
    Dim lineCounter As Integer
    Dim shapeCounter As Integer
    
    Line Input #mFileNum, tempS
    shapeCounter = Val(tempS)
    Line Input #mFileNum, tempS
    lineCounter = Val(tempS)
           
    Dim xS As cBlock
    Dim sName As String
           
    For i = 1 To shapeCounter
        Line Input #mFileNum, tempS
        sName = tempS
    
        Line Input #mFileNum, tempS
        Set xS = theBlockCollection.AddShape(Val(tempS), sName, 0, 0)

        Line Input #mFileNum, tempS
        If bGUI Then xS.shapeLeft = Val(tempS)
        Line Input #mFileNum, tempS
        If bGUI Then xS.shapeTop = Val(tempS)
        Line Input #mFileNum, tempS
        If bGUI Then xS.shapeWidth = Val(tempS)
        Line Input #mFileNum, tempS
        If bGUI Then xS.shapeHeight = Val(tempS)
        Line Input #mFileNum, tempS
        If bGUI Then xS.BGColor = Val(tempS)
        Line Input #mFileNum, tempS
        If bGUI Then xS.BorderColor = Val(tempS)
        Line Input #mFileNum, tempS
        If bGUI Then xS.TextColor = Val(tempS)
        Line Input #mFileNum, tempS ' reserved 1
        ' reserved line 1
        Line Input #mFileNum, tempS ' reserved 2
        ' reserved line 2
        Line Input #mFileNum, tempS
        xS.zAction = tempS
        ' new line charectres are replaced by [\n] because of
        '  file format we are using:
        Line Input #mFileNum, tempS
        xS.zParam1 = returnNewLine(tempS)
        Line Input #mFileNum, tempS
        xS.zParam2 = returnNewLine(tempS)
        Line Input #mFileNum, tempS
        xS.zParam3 = returnNewLine(tempS)
        
        If bGUI Then xS.Visible = True
        
        If bGUI Then xS.setCaptionToAction       ' sets the caption from data.
    Next i
    
    ' skip two lines (idefication):
    Line Input #mFileNum, tempS
    Line Input #mFileNum, tempS
        
    Dim sFrom As String
    Dim sTo As String
    Dim psik_index As Integer
    
    Dim xL As cLine
    
    For i = 1 To lineCounter
        Line Input #mFileNum, tempS
        psik_index = InStr(1, tempS, ",")
        sFrom = Mid(tempS, 1, psik_index - 1)
        sTo = Mid(tempS, psik_index + 1)
        Line Input #mFileNum, tempS ' reserved 1
        Line Input #mFileNum, tempS ' get line caption (if any).
        Set xL = theLineCollection.AddLine(sFrom, sTo, tempS)
    Next i
    
    '' no need to update, updated by AddLine():
    theLineCollection.updateAllLines
    
    Close mFileNum
    
    
    currentFileName = sFILE
    Me.Caption = ExtractFileName(currentFileName)
    
    ' #020105:
    currentPATH = ExtractFilePath(currentFileName)
    
    bIS_MODIFIED = False    ' loaded, so no midifications.
    
    load_FILE = True        ' load successful!
    
    Exit Function
error_load:
    mBox "Error loading: " & sFILE & vbNewLine & _
           Err.Description
           
    bIS_MODIFIED = False    ' not loaded ?!, so no midifications.
    
    load_FILE = False       ' load failed!
End Function

Private Function Check_If_Saved() As Boolean
    If bIS_MODIFIED Then
        Dim r As Integer
        
        r = MsgBox("Project " & ExtractFileName(currentFileName) & " isn't saved!" _
           & vbNewLine & _
           vbNewLine & "Save changes?", vbYesNoCancel, "Save changes?")
           
        If r = vbYes Then
            ' by default "Save", if required "Save As..." is done:
            mnuSave_Click
        ElseIf r = vbCancel Then
            Check_If_Saved = False   ' cancel any action.
            Exit Function
        End If
        
        ' in case of "NO" just returns true (like it's saved).
    End If
    
    ' gets here when saved, or save is canceled:
    Check_If_Saved = True
End Function


Private Sub mnuNew_Click()
On Error GoTo err_nc ' 1.88

    If Not Check_If_Saved Then Exit Sub
    
   ''''''''''''''''''''''''''''
   
    load_FILE AddSlash(App.Path) & "NEW_TEMPLATE.fpp"
    currentFileName = ""
    Me.Caption = ""
    
    shp_Selector.Visible = False
   
       
    ' #020105:
    SELECTED_SHAPE = findBlock("START").theObjectShape.Index
    PREV_SELECTED_SHAPE = -1
    
    Exit Sub
err_nc:
    Debug.Print "mnuNew_Click: " & Err.Description
End Sub

Private Sub mnuSave_Click()
    If currentFileName <> "" Then
        SAVE_FILE currentFileName
    Else
        mnuSaveAs_Click     ' do "Save As...".
    End If
End Sub

Private Sub mnuSaveAs_Click()
On Error GoTo Canceled

    CommonDialog1.InitDir = App.Path ' 1.88
    
    CommonDialog1.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt
    CommonDialog1.Filter = "Flow Program Projects (*.fpp)|*.fpp|All Files|*.*"
    CommonDialog1.DefaultExt = "fpp"
    CommonDialog1.CancelError = True
    CommonDialog1.ShowSave

    currentFileName = CommonDialog1.FileName
    Me.Caption = ExtractFileName(currentFileName)
    
    ' #020105:
    currentPATH = ExtractFilePath(currentFileName)
    
    
    SAVE_FILE currentFileName
    
Canceled:

End Sub

Private Sub SAVE_FILE(sFileName As String)
    
    On Error GoTo err1
    
    Dim mFileNum As Integer
    mFileNum = FreeFile
    
    Open sFileName For Output As mFileNum
           
    Dim sDl As String
    
    sDl = "       " & vbTab & " <--"
    
    Print #mFileNum, theBlockCollection.Count & sDl & "SHAPES"
    Print #mFileNum, theLineCollection.Count & sDl & "LINES"
    
    Dim xB As cBlock
    
    For Each xB In theBlockCollection
    
        Print #mFileNum, xB.TagID
        Print #mFileNum, xB.Shape & sDl & "TYPE"
        Print #mFileNum, xB.shapeLeft & sDl & "LEFT"
        Print #mFileNum, xB.shapeTop & sDl & "TOP"
        Print #mFileNum, xB.shapeWidth & sDl & "WIDTH"
        Print #mFileNum, xB.shapeHeight & sDl & "HEIGHT"
        Print #mFileNum, xB.BGColor & sDl & "BACKCOLOR"
        Print #mFileNum, xB.BorderColor & sDl & "BORDERCOLOR"
        Print #mFileNum, xB.TextColor & sDl & "BORDERCOLOR"
        Print #mFileNum, "-reserved 1-"   ' reserved!
        Print #mFileNum, "-reserved 2-"   ' reserved!
        Print #mFileNum, xB.zAction
        ' since parameters could be set by a user, it's required to
        '  check if there are new line characters inside, due to file
        '  format:
        Print #mFileNum, removeNewLine(xB.zParam1)
        Print #mFileNum, removeNewLine(xB.zParam2)
        Print #mFileNum, removeNewLine(xB.zParam3)
        
    Next xB
    
    Dim xL As cLine
    
    Print #mFileNum, "  "
    Print #mFileNum, "---- LINES ---- from,to ----"
    
    For Each xL In theLineCollection
        Print #mFileNum, xL.sFrom & "," & xL.sTo
        Print #mFileNum, "reserved 1"   ' reserved 1
        Print #mFileNum, xL.sCaption
    Next xL
    
    Close mFileNum
    
    bIS_MODIFIED = False        ' all saved, so not modified.
    
    
    Exit Sub
    
err1:
    
    MsgBox "Error on SAVE_FILE: " & Err.Description
    
End Sub

Private Sub shp_DblClick(Index As Integer)
    ' #020105:
    cmdEdit_Click
End Sub

Private Sub shp_MouseDown(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
        DRAGGED_SHAPE = Index
        
        If SELECTED_SHAPE <> Index Then
             PREV_SELECTED_SHAPE = SELECTED_SHAPE
             SELECTED_SHAPE = Index
        End If
        
        distX = X
        distY = Y
        
        lblID.Caption = shp(Index).Tag
        
        ' looks better:
        shp(Index).ZOrder 0
        
        shp_Selector.Visible = False
End Sub

Private Sub shp_MouseMove(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If DRAGGED_SHAPE <> -1 Then
        shp(DRAGGED_SHAPE).Left = shp(DRAGGED_SHAPE).Left + X - distX
        shp(DRAGGED_SHAPE).Top = shp(DRAGGED_SHAPE).Top + Y - distY
        ' theLineCollection.updateAllLines
        theLineCollection.updateConntectedLines (shp(DRAGGED_SHAPE).Tag)
        bIS_MODIFIED = True
        
'' it's no longer required, since we placed an "if" that prevents
''  to prevent flickering (and unnecessary actions) in updateLine(),
''  and it solves problems.
''        ' to prevent undrawn areas when moving over too many
''        '   objects on the form:
''        Me.Refresh

' repaint still not good when there are many blocks...
'      (d4.tzr)
' solved by using updateConntectedLines() instead of updateAllLines().
       
    End If
End Sub

Private Sub shp_MouseUp(Index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    If DRAGGED_SHAPE <> -1 Then setSelector theBlockCollection(shp(DRAGGED_SHAPE).Tag)
    DRAGGED_SHAPE = -1
    
    ' #020105:
    If chkCONTINUED_CONNECTION.Value = vbChecked Then
        bSHOW_MESSAGE_WHEN_ALREADY_CONNECTED = False
        cmdConnect_Click
        bSHOW_MESSAGE_WHEN_ALREADY_CONNECTED = True
    End If
End Sub



Private Sub theBlockCollection_linkError(sERROR As String)
    mBox sERROR
End Sub

Private Sub theLineCollection_linkError(sERROR As String)
    mBox sERROR
End Sub

' the same sub, just public:
Public Sub cmdRun_ClickP()
    cmdRun_MouseDown vbLeftButton, 0, 0, 0
End Sub


Private Sub cmdRun_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    ' used instead of Click because Click event reacts on "enter" key
    '   (this is good for frmScreen.processKey KeyAscii).

    ''''''''''''''''''''''''''''
    ' save should be done before running,
    '   since information may be lost when
    '   calling functions.
    If Not Check_If_Saved Then Exit Sub