form1.frm

vb实现最短路径Dijkstra算法

    Form_MouseMove Button, Shift, X / Screen.TwipsPerPixelX + lblShapeCap(index).Left, Y / Screen.TwipsPerPixelY + lblShapeCap(index).Top
End Sub

Private Sub lblShapeCap_MouseUp(index As Integer, Button As Integer, Shift As Integer, X As Single, Y As Single)
    Form_MouseUp Button, Shift, X / Screen.TwipsPerPixelX + lblShapeCap(index).Left, Y / Screen.TwipsPerPixelY + lblShapeCap(index).Top
End Sub

Private Sub mnuAddRect_Click()
    'theBlocks.addShape 0
    theBlockCollection.AddShape 0, theBlockCollection.getFreeTagID()
End Sub

Private Sub mnuAddSquare_Click()
    theBlockCollection.AddShape 1, theBlockCollection.getFreeTagID()
End Sub

Private Sub mnuAddElipse_Click()
    theBlockCollection.AddShape 2, theBlockCollection.getFreeTagID()
End Sub

Private Sub mnuAddCircle_Click()
    theBlockCollection.AddShape 3, theBlockCollection.getFreeTagID()
End Sub

Private Sub Form_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim i As Integer
    
    For i = MAX_SHAPE To 1 Step -1
        
        If (shp(i).Visible = True) And _
            (X > shp(i).Left) And (X < shp(i).Left + shp(i).Width) _
            And (Y > shp(i).Top) And (Y < shp(i).Top + shp(i).Height) Then
            
               DRAGGED_SHAPE = i
               
               If SELECTED_SHAPE <> i Then
                    PREV_SELECTED_SHAPE = SELECTED_SHAPE
                    SELECTED_SHAPE = i
               End If
               
               distX = X - shp(i).Left
               distY = Y - shp(i).Top
               
               lblID.Caption = shp(i).Tag
               'Debug.Print "click in!", X, Y
               Exit For
               
        End If
        
    Next i


'Debug.Print "click out!", X, Y
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
        If DRAGGED_SHAPE <> -1 Then
            shp(DRAGGED_SHAPE).Left = X - distX
            shp(DRAGGED_SHAPE).Top = Y - distY
            theLineCollection.updateLines
            theBlockCollection(shp(DRAGGED_SHAPE).Tag).updateShapeCaptionPos
        End If
End Sub

Private Sub mnuChangeBackColor_Click()
    If SELECTED_SHAPE <> -1 Then
        CommonDialog1.ShowColor
        shp(SELECTED_SHAPE).BackColor = CommonDialog1.Color
    End If
End Sub

Private Sub mnuChangeBorderColor_Click()
    If SELECTED_SHAPE <> -1 Then
        CommonDialog1.ShowColor
        shp(SELECTED_SHAPE).BorderColor = CommonDialog1.Color
    End If
End Sub

Private Sub mnuChangeRect_Click()
    theBlockCollection.changeShape (0)
End Sub

Private Sub mnuChangeSize_Click()
    frmSize.Show , Me
End Sub

Private Sub mnuChangeSquare_Click()
    theBlockCollection.changeShape (1)
End Sub

Private Sub mnuChangeElipse_Click()
    theBlockCollection.changeShape (2)
End Sub

Private Sub mnuChangeCircle_Click()
    theBlockCollection.changeShape (3)
End Sub

Private Sub mnuDeleteBlock_Click()

    theBlockCollection.removeShape SELECTED_SHAPE
    
    SELECTED_SHAPE = -1
    
End Sub

Private Sub mnuDeleteLine_Click()

    theLineCollection.deleteLine SELECTED_SHAPE, PREV_SELECTED_SHAPE
    
End Sub

Private Sub mnuFindShortPath_Click()
    frmFindShortPath.Show
End Sub

Private Sub mnuFindAllPaths_Click()
    frmFindAllPaths.Show
End Sub

Private Sub mnuJoinLine_Click()
    If (PREV_SELECTED_SHAPE <> -1) And (SELECTED_SHAPE <> -1) Then
        theLineCollection.AddLine Form1.shp(PREV_SELECTED_SHAPE).Tag, Form1.shp(SELECTED_SHAPE).Tag, False
    Else
        MsgBox "Two objects should be selected!"
    End If
End Sub

Private Sub mnuJoinArrow_Click()
    If (PREV_SELECTED_SHAPE <> -1) And (SELECTED_SHAPE <> -1) Then
        theLineCollection.AddLine Form1.shp(PREV_SELECTED_SHAPE).Tag, Form1.shp(SELECTED_SHAPE).Tag, True
    Else
        MsgBox "Two objects should be selected!"
    End If
End Sub

Private Sub mnuAddCaptionToLine_Click()
    If (PREV_SELECTED_SHAPE <> -1) And (SELECTED_SHAPE <> -1) Then
        Dim s As String
        s = InputBox("Enter the caption")
        theLineCollection.AddCaptionToLine Form1.shp(PREV_SELECTED_SHAPE).Tag, Form1.shp(SELECTED_SHAPE).Tag, s
    Else
        MsgBox "Two objects should be selected!"
    End If
End Sub

Private Sub mnuAddCaptionToBlock_Click()
    If (SELECTED_SHAPE <> -1) Then
        Dim s As String
        s = InputBox("Enter the caption for a shape", "Caption", theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaption)
        theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaption = s
        theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).updateShapeCaptionPos
    Else
        MsgBox "Object should be selected!"
    End If
End Sub

Private Sub mnuAddCaptionUpperToBlock_Click()
    If (SELECTED_SHAPE <> -1) Then
        Dim s As String
        s = InputBox("Enter the caption for a shape", "Caption", theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaptionUpper)
        theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaptionUpper = s
        theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).bSetUpperCaptionDown = False
        theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).updateShapeCaptionPos
    Else
        MsgBox "Object should be selected!"
    End If
End Sub

Private Sub mnuAddCaptionLowerToBlock_Click()
    mnuAddCaptionUpperToBlock_Click
    theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).bSetUpperCaptionDown = True
    theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).updateShapeCaptionPos
End Sub

Private Sub mnuLoad_Click()
    
    CommonDialog1.Flags = cdlOFNHideReadOnly
    CommonDialog1.Filter = "Trace ZR Flow Data|*.tzr|All Files|*.*"
    CommonDialog1.DefaultExt = "tzr"
    CommonDialog1.ShowOpen

    load_FILE CommonDialog1.FileName
    
End Sub

Private Sub load_FILE(sFILE As String)
On Error GoTo err_lf

    Dim i As Integer
    
    Dim mFileNum As Integer
    mFileNum = FreeFile
    
    If sFILE = "" Then Exit Sub
    
    ' unload all previous objects:
    For i = 1 To MAX_SHAPE
        Unload shp(i)
        Unload lblShapeCap(i)
        Unload lblShapeCapUpper(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)

        Line Input #mFileNum, tempS
        xS.shapeLeft = Val(tempS)
        Line Input #mFileNum, tempS
        xS.shapeTop = Val(tempS)
        Line Input #mFileNum, tempS
        xS.shapeWidth = Val(tempS)
        Line Input #mFileNum, tempS
        xS.shapeHeight = Val(tempS)
        Line Input #mFileNum, tempS
        xS.shapeBackColor = Val(tempS)
        Line Input #mFileNum, tempS
        xS.shapeBorderColor = Val(tempS)
        Line Input #mFileNum, tempS
        xS.sCaption = tempS
        Line Input #mFileNum, tempS
        xS.sCaptionUpper = tempS
        Line Input #mFileNum, tempS
        xS.bSetUpperCaptionDown = Val(tempS)
        xS.updateShapeCaptionPos
        xS.Visible = True
    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
        Set xL = theLineCollection.AddLine(sFrom, sTo, Val(tempS))
        Line Input #mFileNum, tempS
        xL.sCaption = tempS
    Next i
    
    theLineCollection.updateLines
    
    Close mFileNum
    
    
    update_from_to
    
    Exit Sub
err_lf:
    MsgBox "Load: " & sFILE & vbNewLine & Err.Description
End Sub

Private Sub mnuLoadDiakstaFile_Click()
    load_FILE Add_BackSlash(App.Path) & "dijkstra.tzr"
End Sub

Private Sub mnuLoadAllPathFile_Click()
    load_FILE Add_BackSlash(App.Path) & "allPath.tzr"
End Sub

Private Sub mnuSave_Click()
    
    CommonDialog1.Flags = cdlOFNHideReadOnly + cdlOFNOverwritePrompt
    CommonDialog1.Filter = "Trace ZR Flow Data|*.tzr|All Files|*.*"
    CommonDialog1.DefaultExt = "tzr"
    CommonDialog1.ShowSave

    Dim mFileNum As Integer
    mFileNum = FreeFile
    
    If CommonDialog1.FileName = "" Then Exit Sub
    
    Open CommonDialog1.FileName 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 & xB.theObjectShape.Tag & ".TYPE"
        Print #mFileNum, xB.shapeLeft & sDl & xB.theObjectShape.Tag & ".LEFT"
        Print #mFileNum, xB.shapeTop & sDl & xB.theObjectShape.Tag & ".TOP"
        Print #mFileNum, xB.shapeWidth & sDl & xB.theObjectShape.Tag & ".WIDTH"
        Print #mFileNum, xB.shapeHeight & sDl & xB.theObjectShape.Tag & ".HEIGHT"
        Print #mFileNum, xB.shapeBackColor & sDl & xB.theObjectShape.Tag & ".BACKCOLOR"
        Print #mFileNum, xB.shapeBorderColor & sDl & xB.theObjectShape.Tag & ".BORDERCOLOR"
        Print #mFileNum, xB.sCaption
        Print #mFileNum, xB.sCaptionUpper
        If xB.bSetUpperCaptionDown Then
            Print #mFileNum, "1" & sDl & "Caption down"
        Else
            Print #mFileNum, "0" & sDl & "Caption up"
        End If
        
    Next xB
    
    Dim xL As cLine
    
    Print #mFileNum, "  "
    Print #mFileNum, "---- LINES ---- from,to ----"
    
    For Each xL In theLineCollection
        Print #mFileNum, xL.sFrom & "," & xL.sTo
        If xL.bShowArrow Then
            Print #mFileNum, "1" & sDl & "Arrow"
        Else
            Print #mFileNum, "0" & sDl & "Line"
        End If
        Print #mFileNum, xL.sCaption '& sDl & "Caption"
    Next xL
    
    Close mFileNum
    
End Sub

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

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

' 020720
Private Sub update_from_to()
On Error GoTo err_uft
Dim sFrom As String
Dim sTo As String
sFrom = "?"
sTo = "?"

If PREV_SELECTED_SHAPE <> -1 Then
    sFrom = theBlockCollection(Form1.shp(PREV_SELECTED_SHAPE).Tag).sCaption
End If

If SELECTED_SHAPE <> -1 Then
    sTo = theBlockCollection(Form1.shp(SELECTED_SHAPE).Tag).sCaption
End If

lblFromTo.Caption = "From: " & sFrom & "  To: " & sTo
Exit Sub
err_uft:
Debug.Print "update_from_to: " & Err.Description
End Sub


Private Sub lblURL_Click()
   Call ShellExecute(Me.hwnd, "open", "http://www.geocities.com/emu8086/vb/", "", App.Path, SW_SHOWDEFAULT)
End Sub