myblockcollection.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 = "myBlockCollection"
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" ,"cBlock"
Attribute VB_Ext_KEY = "Member0" ,"cBlock"
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 Function AddShape(ShapeType As Integer, sKey As String) As cBlock
    'create a new object
    Dim objNewMember As cBlock
    Set objNewMember = New cBlock


    'set the properties passed into the method
    

    MAX_SHAPE = MAX_SHAPE + 1
    Load Form1.shp(MAX_SHAPE)
    Load Form1.lblShapeCap(MAX_SHAPE)
    Load Form1.lblShapeCapUpper(MAX_SHAPE)
        
    Set objNewMember.theObjectShape = Form1.shp(MAX_SHAPE)
   
    PREV_SELECTED_SHAPE = SELECTED_SHAPE
    SELECTED_SHAPE = MAX_SHAPE
        
    With objNewMember
        If ShapeType = 0 Then       ' rect
            .shapeWidth = 70
            .shapeHeight = 40
            .shapeBorderColor = vbBlack
            .shapeBackColor = vbGreen
        ElseIf ShapeType = 1 Then   ' square
            .shapeWidth = 50
            .shapeHeight = 50
            .shapeBorderColor = vbWhite
            .shapeBackColor = vbBlue
        ElseIf ShapeType = 2 Then   ' oval
            .shapeWidth = 70
            .shapeHeight = 30
            .shapeBorderColor = vbCyan
            .shapeBackColor = RGB(200, 55, 78)
        ElseIf ShapeType = 3 Then   ' circle
            .shapeWidth = 50
            .shapeHeight = 50
            .shapeBorderColor = vbRed
            .shapeBackColor = vbYellow
        End If
        .shapeLeft = Form1.ScaleWidth / 2 - .shapeWidth / 2
        .shapeTop = Form1.ScaleHeight / 2 - .shapeHeight / 2
        .Shape = ShapeType
        .theObjectShape.ZOrder 0
        .Visible = True
        .TagID = sKey 'getFreeTagID()
        
               
        Form1.lblShapeCap(MAX_SHAPE).Caption = ""
        Form1.lblShapeCap(MAX_SHAPE).ZOrder 0
        Form1.lblShapeCapUpper(MAX_SHAPE).Caption = ""
        Form1.lblShapeCapUpper(MAX_SHAPE).ZOrder 0
        .updateShapeCaptionPos
        Form1.lblShapeCap(MAX_SHAPE).Visible = True
        Form1.lblShapeCapUpper(MAX_SHAPE).Visible = True
    End With
    
    
    
    'If Len(sKey) = 0 Then
    '    mCol.Add objNewMember
    'Else
    '    mCol.Add objNewMember, sKey
    'End If

    mCol.Add objNewMember, objNewMember.TagID
    
    
    'return the object created
    Set AddShape = objNewMember
    Set objNewMember = Nothing


End Function

Public Property Get Item(vntIndexKey As Variant) As cBlock
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 changeShape(iType As Integer)
    If SELECTED_SHAPE <> -1 Then
        Form1.shp(SELECTED_SHAPE).Shape = iType
        If (iType = 1) Or (iType = 3) Then
            Form1.shp(SELECTED_SHAPE).Height = Form1.shp(SELECTED_SHAPE).Width
        End If
    End If
End Sub

Public Sub removeShape(index As Integer)
    
    If index = -1 Then Exit Sub
       
    Dim xL As cLine
    Dim sName As String
    
    sName = Form1.shp(index).Tag
    
    For Each xL In Form1.theLineCollection
        If (xL.sFrom = sName) Or (xL.sTo = sName) Then
            RaiseEvent linkError("Cannot delete object with links")
            Exit Sub
        End If
    Next xL
    
    Form1.shp(index).Visible = False
    
    Me.Remove sName  ' actual delete (won't be loaded on next load).

End Sub

Public Function getFreeTagID() As String

    Dim xB As cBlock
    
    Dim index As Integer
    Dim sName As String
    index = 1
    
    sName = "id" & index
    
    Do While (getIndexFromTag(sName) <> -1)
        index = index + 1
        sName = "id" & index
    Loop

    getFreeTagID = sName
End Function

Public Function getIndexFromTag(sTag As String) As Integer
    Dim xB As cBlock
    
    For Each xB In Me
        If (xB.TagID = sTag) Then
            getIndexFromTag = xB.theObjectShape.index
            Exit Function
        End If
    Next xB
  
    getIndexFromTag = -1    ' not found!
    
End Function

' it may never happen...
' check anyway...
Public Sub checkLinks()

    Dim xL As cLine
    
    For Each xL In Form1.theLineCollection
        If Me.getIndexFromTag(xL.sFrom) = -1 Then
             RaiseEvent linkError("Line #" & xL.theObjectLine.index & " has wrong FROM")
        ElseIf Me.getIndexFromTag(xL.sTo) = -1 Then
             RaiseEvent linkError("Line #" & xL.theObjectLine.index & " has wrong TO")
        End If
    Next xL
    
End Sub