mylinecollection.cls

vb实现最短路径Dijkstra算法

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "myLineCollection"
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 = "Collection" ,"cLine"
Attribute VB_Ext_KEY = "Member0" ,"cLine"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
'  ==========================================
'  Dijkstra's algorithm to find Shortest Path
'  ==========================================
'
' E.W. Dijkstra is a Dutch professor in Computer
' Science, who did a lot of research in graphs.
'
' Dijkstra's algorithm is of use when working with
' directional graphs. It constructs the shortest path
' between a starting-node and a goal-node.
' It is assumed that every link between two nodes
' has a certain cost, and this algorithm finds the
' path between the two given nodes with the lowest cost.
'
' The idea of this VB project was to show the
' work of this algorithm in a visual way.
'
'    Screen-shot: dijkstra.gif
'
'
'    Visit my Homepage:
'    http://www.geocities.com/emu8086/vb/
'
'
'    Last Update: Saturday, July 20, 2002
'
'
'    Copyright 2002 Alexander Popov Emulation Soft.
'               All rights reserved.
'        http://www.geocities.com/emu8086/


Option Explicit

'local variable to hold collection
Private mCol As Collection

'To fire this event, use RaiseEvent with the following syntax:
'RaiseEvent linkError[(arg1, arg2, ... , argn)]
Public Event linkError(sERROR As String)

Public Sub AddCaptionToLine(sFrom As String, sTo As String, sCaption As String)
    Dim xL As cLine
    
    For Each xL In Me
         
        If ((xL.sFrom = sFrom) And (xL.sTo = sTo)) _
         Or ((xL.sTo = sFrom) And (xL.sFrom = sTo)) Then
            xL.sCaption = sCaption
            
            Form1.lblLineCap(xL.theObjectLine.index).Left = xL.theObjectLine.X1 + (xL.theObjectLine.X2 - xL.theObjectLine.X1) / 2 - Form1.lblLineCap(xL.theObjectLine.index).Width / 2
            Form1.lblLineCap(xL.theObjectLine.index).Top = xL.theObjectLine.Y1 + (xL.theObjectLine.Y2 - xL.theObjectLine.Y1) / 2 - Form1.lblLineCap(xL.theObjectLine.index).Height
        End If
        
    Next xL
    
End Sub

Public Function AddLine(sFrom As String, sTo As String, bShowArrow As Boolean, Optional sKey As String) As cLine

    If sFrom = "" Or sTo = "" Then
        RaiseEvent linkError("Cannot make a link!!!!")
        Exit Function
    End If
    

    'create a new object
    Dim objNewMember As cLine
    Set objNewMember = New cLine


    'set the properties passed into the method
    objNewMember.sFrom = sFrom
    objNewMember.sTo = sTo
    objNewMember.bShowArrow = bShowArrow
    ' objNewMember.sCaption = "" ' not intitialized yet.
    If Len(sKey) = 0 Then
        mCol.Add objNewMember
    Else
        mCol.Add objNewMember, sKey
    End If

    ' make connection


    MAX_LINE = MAX_LINE + 1
    Load Form1.ln(MAX_LINE)
    ' one arrow for each line:
    Load Form1.aDot(MAX_LINE)
    Load Form1.arrUp(MAX_LINE)
    Load Form1.arrDown(MAX_LINE)
    ' one caption for each line/arrow:
    Load Form1.lblLineCap(MAX_LINE)
    
    Set objNewMember.theObjectLine = Form1.ln(MAX_LINE)

    Dim iFrom As Integer
    Dim iTo As Integer

    iFrom = Form1.theBlockCollection.getIndexFromTag(sFrom)
    iTo = Form1.theBlockCollection.getIndexFromTag(sTo)
    
    With objNewMember.theObjectLine
        .Visible = True
        .X1 = Form1.shp(iFrom).Left + (Form1.shp(iFrom).Width / 2)
        .Y1 = Form1.shp(iFrom).Top + (Form1.shp(iFrom).Height / 2)
        .X2 = Form1.shp(iTo).Left + (Form1.shp(iTo).Width / 2)
        .Y2 = Form1.shp(iTo).Top + (Form1.shp(iTo).Height / 2)
    End With

    If objNewMember.bShowArrow Then
        Me.showArrow objNewMember.theObjectLine, sTo
    End If
    
    Form1.lblLineCap(MAX_LINE).Caption = ""
    Form1.lblLineCap(MAX_LINE).Left = objNewMember.theObjectLine.X1 + (objNewMember.theObjectLine.X2 - objNewMember.theObjectLine.X1) / 2 - Form1.lblLineCap(MAX_LINE).Width / 2
    Form1.lblLineCap(MAX_LINE).Top = objNewMember.theObjectLine.Y1 + (objNewMember.theObjectLine.Y2 - objNewMember.theObjectLine.Y1) / 2 - Form1.lblLineCap(MAX_LINE).Height
    Form1.lblLineCap(MAX_LINE).Visible = True
    Form1.lblLineCap(MAX_LINE).ZOrder 0
    
    'return the object created
    Set AddLine = objNewMember
    Set objNewMember = Nothing

End Function

Public Property Get Item(vntIndexKey As Variant) As cLine
Attribute Item.VB_UserMemId = 0
    'used when referencing an element in the collection
    'vntIndexKey contains either the Index or Key to the collection,
    'this is why it is declared as a Variant
    'Syntax: Set foo = x.Item(xyz) or Set foo = x.Item(5)
  Set Item = mCol(vntIndexKey)
End Property



Public Property Get Count() As Long
    'used when retrieving the number of elements in the
    'collection. Syntax: Debug.Print x.Count
    Count = mCol.Count
End Property


Public Sub Remove(vntIndexKey As Variant)
    'used when removing an element from the collection
    'vntIndexKey contains either the Index or Key, which is why
    'it is declared as a Variant
    'Syntax: x.Remove(xyz)


    mCol.Remove vntIndexKey
End Sub


Public Property Get NewEnum() As IUnknown
Attribute NewEnum.VB_UserMemId = -4
Attribute NewEnum.VB_MemberFlags = "40"
    'this property allows you to enumerate
    'this collection with the For...Each syntax
    Set NewEnum = mCol.[_NewEnum]
End Property


Private Sub Class_Initialize()
    'creates the collection when this class is created
    Set mCol = New Collection
End Sub


Private Sub Class_Terminate()
    'destroys collection when this class is terminated
    Set mCol = Nothing
End Sub



Public Sub deleteLine(xFrom As Integer, xTo As Integer)

    If xFrom = -1 Or xTo = -1 Then
        RaiseEvent linkError("Cannot delete a line!!!!")
        Exit Sub
    End If

    Dim i As Integer
    
    Dim sNameFrom As String
    Dim sNameTo As String
    
    Dim lineIndex As Integer
    
    sNameFrom = Form1.shp(xFrom).Tag
    sNameTo = Form1.shp(xTo).Tag
    
    For i = Me.Count To 1 Step -1
    
        If ((Me(i).sFrom = sNameFrom) And (Me(i).sTo = sNameTo)) Or _
           ((Me(i).sFrom = sNameTo) And (Me(i).sTo = sNameFrom)) Then
            
            Me(i).theObjectLine.Visible = False
            Me(i).sFrom = ""
            Me(i).sTo = ""
            
            lineIndex = Me(i).theObjectLine.index
            Form1.aDot(lineIndex).Visible = False
            Form1.arrUp(lineIndex).Visible = False
            Form1.arrDown(lineIndex).Visible = False
            Form1.lblLineCap(lineIndex).Visible = False
            
            Me.Remove i    ' actual delete (won't be loaded on next load).
            
        End If

    Next i

End Sub




Public Sub updateLines()

    Dim xL As cLine
    
    Dim iFrom As Integer
    Dim iTo As Integer
    
    Dim lineIndex As Integer

    For Each xL In Me 'Form1.theLineCollection

        With Form1.theBlockCollection
            iFrom = .getIndexFromTag(xL.sFrom)
            iTo = .getIndexFromTag(xL.sTo)
        End With
        
        With xL.theObjectLine
            .X1 = Form1.shp(iFrom).Left + (Form1.shp(iFrom).Width / 2)
            .Y1 = Form1.shp(iFrom).Top + (Form1.shp(iFrom).Height / 2)
            .X2 = Form1.shp(iTo).Left + (Form1.shp(iTo).Width / 2)
            .Y2 = Form1.shp(iTo).Top + (Form1.shp(iTo).Height / 2)
            
            lineIndex = .index
    
            Form1.lblLineCap(lineIndex).Left = .X1 + (.X2 - .X1) / 2 - Form1.lblLineCap(lineIndex).Width / 2
            Form1.lblLineCap(lineIndex).Top = .Y1 + (.Y2 - .Y1) / 2 - Form1.lblLineCap(lineIndex).Height
                        
        End With
        

        If xL.bShowArrow Then
            Me.showArrow xL.theObjectLine, xL.sTo
        End If
        
    Next xL
    
End Sub

Private Function getCollectionIndex_from_objectIndex(lineIndex As Integer) As Integer
    Dim i As Integer
    
    For i = 1 To Me.Count
        If Me(i).theObjectLine.index = lineIndex Then
            getCollectionIndex_from_objectIndex = i
            Exit Function
        End If
    Next i
    
    getCollectionIndex_from_objectIndex = -1 ' not found!
    
End Function

Public Sub showArrow(lineObj As Line, arrowTo As String)

    Dim mSin As Double
    Dim mCos As Double
    Dim pril As Double
    Dim prot As Double
    Dim gip As Double
    
    Dim arINDEX As Integer
    
    arINDEX = lineObj.index
    
    pril = (lineObj.X1 - lineObj.X2)
    prot = (lineObj.Y1 - lineObj.Y2)
    
    gip = Sqr(pril ^ 2 + prot ^ 2)
    
    mSin = prot / gip
    mCos = pril / gip
    
    'Form1.Text1.Text = "sin: " & mSin & " cos:" & mCos
    
    Dim iXRadius As Double
    Dim iYRadius As Double
    Dim iXcor As Double
    Dim iYcor As Double
    iXRadius = Form1.theBlockCollection(arrowTo).shapeWidth / 2 + Form1.aDot(arINDEX).Width / 2
    iYRadius = Form1.theBlockCollection(arrowTo).shapeHeight / 2 + Form1.aDot(arINDEX).Height / 2
     
    ' Debug.Print iXRadius, iYRadius
     
    iXcor = Form1.theBlockCollection(arrowTo).shapeLeft + Form1.theBlockCollection(arrowTo).shapeWidth / 2
    iYcor = Form1.theBlockCollection(arrowTo).shapeTop + Form1.theBlockCollection(arrowTo).shapeHeight / 2
     
    Dim X As Double
    Dim Y As Double
    
    X = mCos * iXRadius + iXcor
    Y = mSin * iYRadius + iYcor
    
    Form1.aDot(arINDEX).Left = X - Form1.aDot(arINDEX).Width / 2
    Form1.aDot(arINDEX).Top = Y - Form1.aDot(arINDEX).Height / 2
       
    
   
   Dim new_mSin1 As Double
   Dim new_mCos1 As Double
   Dim new_mSin2 As Double
   Dim new_mCos2 As Double
   
   Dim arrow_angle As Double
   Dim arrow_len As Double
   
   arrow_angle = 0.2
   arrow_len = 20
   
   If (mSin >= 0) And (mCos >= 0) Then
        new_mSin1 = Sin(Arcsin(mSin) - arrow_angle)
        new_mSin2 = Sin(Arcsin(mSin) + arrow_angle)
        new_mCos1 = Cos(Arccos(mCos) - arrow_angle)
        new_mCos2 = Cos(Arccos(mCos) + arrow_angle)
   ElseIf (mSin <= 0) And (mCos >= 0) Then
        new_mSin1 = Sin(Arcsin(mSin) - arrow_angle)
        new_mSin2 = Sin(Arcsin(mSin) + arrow_angle)
        new_mCos1 = Cos(Arccos(mCos) + arrow_angle)
        new_mCos2 = Cos(Arccos(mCos) - arrow_angle)
   ElseIf (mSin >= 0) And (mCos <= 0) Then
        new_mSin1 = Sin(Arcsin(mSin) + arrow_angle)
        new_mSin2 = Sin(Arcsin(mSin) - arrow_angle)
        new_mCos1 = Cos(Arccos(mCos) - arrow_angle)
        new_mCos2 = Cos(Arccos(mCos) + arrow_angle)
   ElseIf (mSin <= 0) And (mCos <= 0) Then
        new_mSin1 = Sin(Arcsin(mSin) + arrow_angle)
        new_mSin2 = Sin(Arcsin(mSin) - arrow_angle)
        new_mCos1 = Cos(Arccos(mCos) + arrow_angle)
        new_mCos2 = Cos(Arccos(mCos) - arrow_angle)
   End If
   
   
   Form1.arrUp(arINDEX).X1 = Form1.aDot(arINDEX).Left + Form1.aDot(arINDEX).Width / 2
   Form1.arrUp(arINDEX).Y1 = Form1.aDot(arINDEX).Top + Form1.aDot(arINDEX).Height / 2
   Form1.arrDown(arINDEX).X1 = Form1.arrUp(arINDEX).X1
   Form1.arrDown(arINDEX).Y1 = Form1.arrUp(arINDEX).Y1
   
   Form1.arrUp(arINDEX).X2 = (new_mCos1) * (iXRadius + arrow_len) + iXcor
   Form1.arrUp(arINDEX).Y2 = (new_mSin1) * (iYRadius + arrow_len) + iYcor
   Form1.arrDown(arINDEX).X2 = (new_mCos2) * (iXRadius + arrow_len) + iXcor
   Form1.arrDown(arINDEX).Y2 = (new_mSin2) * (iYRadius + arrow_len) + iYcor
    
    
   Form1.arrUp(arINDEX).Visible = True
   Form1.arrUp(arINDEX).ZOrder 0
   Form1.arrDown(arINDEX).Visible = True
   Form1.arrDown(arINDEX).ZOrder 0
   Form1.aDot(arINDEX).Visible = True
   Form1.aDot(arINDEX).ZOrder 0
    
End Sub